The Perl Toolchain Summit 2025 Needs You: You can help 🙏 Learn more

SREZIC / Tk-804.036 / demos / demos / widget_lib / WidgetDemo.pm 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130

              
package WidgetDemo;
use 5.005_03;
use vars qw($VERSION);
$VERSION = '4.012'; # sprintf '4.%03d', q$Revision: #11 $ =~ /\D(\d+)\s*$/;
use Tk 800.000;
use Carp;
use Tk;
use Tk::Toplevel;
use strict;
use base  'Tk::Toplevel';
Construct Tk::Widget 'WidgetDemo';
# %WIDGDEMO is a class global that tracks all WidgetDemo composite widgets,
# providing a means of destroying a previous instance of a demonstration.
my %WIDGDEMO;                   # class hash of active widget demonstrations
sub Populate {
    my($self, $args) = @_;
    my (%arg_defaults) = (
        -name             => 'Unknown Demo Name',
        -font             => 'Helvetica 12',
        -text             => 'Unknown Demo Text',
        -geometry_manager => 'pack',
    );
    my $name = $arg_defaults{-name};
    $arg_defaults{-title} = "$name Demonstration",
    $arg_defaults{-iconname} = $name;
    my(@margs, %ahsh, @args);
    @margs = grep ! defined $args->{$_}, keys %arg_defaults;
    %ahsh = %$args;
    @ahsh{@margs} = @arg_defaults{@margs};
    my($demo, $font, $text, $title, $iconname, $gm) =
        @ahsh{-name, -font, -text, -title, -iconname, -geometry_manager};
    delete $args->{-name};
    delete $args->{-font};
    delete $args->{-iconname};
    delete $args->{-geometry_manager};
    $WIDGDEMO{$demo}->destroy if Exists($WIDGDEMO{$demo});
    $WIDGDEMO{$demo} = $self;
    $self->SUPER::Populate($args);
    $self->iconname($iconname);
    my(@label_attributes) = ();
    if (ref($text) eq 'ARRAY') {
        @label_attributes = @$text[1 .. $#{$text}];
        $text = $text->[0];
    }
    my $msg = $self->Label(
        -font       => $font,
        -wraplength => '4i',
        -justify    => 'left',
        -text       => $text,
        @label_attributes,
    );
    my $demo_frame = $self->Frame;
    $self->Advertise('WidgetDemo' => $demo_frame); # deprecated
    my $buttons = $self->Frame;
    my $dismiss = $buttons->Button(
        -text    => 'Dismiss',
        -command => [$self => 'destroy'],
    );
    my $see = $buttons->Button(-text => 'See Code',
                               -command => [\&main::see_code, $demo]);
    if ($gm eq 'pack') {
        $buttons->pack(qw/-side bottom -fill x -pady 2m/);
        $dismiss->pack(qw/-side left -expand 1/);
        $see->pack(qw/-side left -expand 1/);
        $msg->pack;
        $demo_frame->pack(qw/-fill both -expand 1 -anchor n/);
    } elsif ($gm eq 'grid') {
        $msg->grid;
        $demo_frame->grid(-sticky => "news");
        $demo_frame->gridColumnconfigure(0,-weight=>1);
        $demo_frame->gridRowconfigure(0,-weight=>1);
        $self->gridColumnconfigure(qw/0 -weight 1/);
        $self->gridRowconfigure(qw/1 -weight 1/);
        $buttons->grid(qw/-pady 2m -sticky ew/);
        $buttons->gridColumnconfigure(qw/0 -weight 1/);
        $buttons->gridColumnconfigure(qw/1 -weight 1/);
        $dismiss->grid(qw/-row 0 -column 0/);
        $see->grid(qw/-row 0 -column 1/);
    } else {
        croak "Only pack or grid geometry management supported.";
    }
    $self->Delegates('Construct' => $demo_frame);
    $self->ConfigSpecs(
        -text => [qw/METHOD text Text NoText/],
    );
    $self->{msg} = $msg;
    return $self;
} # end Populate
sub Top {return $_[0]->Subwidget('WidgetDemo')}      # deprecated
*top = *top = \&Top;  # peacify -w
sub text {
    my ($self, $text) = @_;
    my(@label_attributes) = ();
    if (ref($text) eq 'ARRAY') {
        @label_attributes = @$text[1 .. $#{$text}];
        $text = $text->[0];
    }
    $self->{msg}->configure(
        -text       => $text,
        @label_attributes,
    );
} # end text
1;