From Code to Community: Sponsoring The Perl and Raku Conference 2025 Learn more

NI-S / Tk-804.025_beta15 / demos / demos / widget_lib / menbut.pl 

            

              
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

              
# menbut.pl
use vars qw/$TOP/;
sub menbut {
    my($demo) = @_;
    $TOP = $MW->WidgetDemo(
        -name             => $demo,
        -text             => '',
        -title            => 'Menubutton Demo',
        -iconname         => 'Menubutton',
    );
    my @menubuttons;
    foreach (qw/below right left above/) {
        my $pos = ucfirst;
        my $menubutton = $TOP->Menubutton(qw/-underline 0 -relief raised/,
                                          -text => $pos, -direction => $_);
        push @menubuttons, $menubutton;
        my $menu = $menubutton->menu(qw/-tearoff 0/);
        $menubutton->configure(-menu => $menu);
        $menubutton->command(-label => "$pos menu: first item", -command =>
        sub {print "You selected the first item from the $pos menu.\n"});
        $menubutton->command(-label => "$pos menu: second item", -command =>
           sub {print "You selected the second item from the $pos menu.\n"});
    }
    $menubuttons[0]->grid(qw/-row 0 -column 1 -sticky n/);
    $menubuttons[3]->grid(qw/-row 2 -column 1 -sticky n/);
    $menubuttons[1]->grid(qw/-row 1 -column 0 -sticky w/);
    $menubuttons[2]->grid(qw/-row 1 -column 2 -sticky e/);
    my $body = $TOP->Frame;
    $body->grid(qw/-row 1 -column 1 -sticky news/);
    $body->Label(qw/-wraplength 300 -justify left/, -font => 'Helvetica 14',
                -text => 'This is a demonstration of menubuttons. The "Below" menubutton pops its menu below the button; the "Right" button pops to the right, etc. There are two option menus directly below this text; one is just a standard menu and the other is a 16-color palette.')->pack(qw/-side top -padx 25
                                                        -pady 25/);
    $bbutt = $body->Frame->pack(qw/-padx 25 -pady 25/);
    $bbutt->Optionmenu(-options => [qw/one two three/])->pack(qw/-side left
                                                        -padx 25 -pady 25/);
    my $palette;
    my(@colors) = qw/Black red4 DarkGreen  NavyBlue gray75 Red Green Blue
        gray50 Yellow Cyan Magenta White Brown  DarkSeaGreen  DarkViolet/;
    my $colors =  native_optionmenu(
        $bbutt,
        \$palette,
        [sub {print "args=@_.\n"}, 'First'],
        @colors,
    );
    $colors->pack(qw/-side left -padx 25 -pady 25/);
    my $menu = $colors->cget(-menu);
    my $topborder    = 'gray50';
    my $bottomborder = 'gray75';
    foreach my $i (0 .. $#colors) {
        # Create a 16 pixel x 16 pixel solid color swatch.
        # Add a black ring around the currently selected item.
        my $color = $menu->entrycget($i, -label);
        my $p = $TOP->Photo(qw/-width 16 -height 16/);
        $p->put($topborder,    qw/-to  0  0 16  1/);
        $p->put($topborder,    qw/-to  0  1  1 16/);
        $p->put($bottomborder, qw/-to  1 15 16 16/);
        $p->put($bottomborder, qw/-to 15  1 16 15/);
        $p->put($color,        qw/-to  1  1 15 15/);
        my $r = $TOP->Photo(qw/-width 16 -height 16/);
        $r->put(qw/black          -to  0  0 16  2/);
        $r->put(qw/black          -to  0  2  2 16/);
        $r->put(qw/black          -to  2 14 16 16/);
        $r->put(qw/black          -to 14  2 16 14/);
        $r->put($color       , qw/-to  2  2 14 14/);
        $menu->entryconfigure($i, -columnbreak => 1) unless $i % 4;
        $menu->entryconfigure($i,
            -image       => $p,
            -hidemargin  => 1,
            -selectimage => $r,
        );
    } # forend all colors
    $menu->configure(-tearoff => 1);
} # end menbut
sub native_optionmenu {
    my($parent, $varref, $command, @optionvals) = @_;
    $$varref = $optionvals[0];
    my $mb = $parent->Menubutton(
        -textvariable       => $varref,
        -indicatoron        => 1,
        -relief             => 'raised',
        -borderwidth        => 2,
        -highlightthickness => 2,
        -anchor             => 'c',
        -direction          => 'flush',
    );
    my $menu = $mb->Menu(-tearoff => 0);
    $mb->configure(-menu => $menu);
    my $callback = ref($command) =~ /CODE/ ? [$command] : $command;
    foreach (@optionvals) {
        $menu->radiobutton(
            -label     => $_,
            -variable  => $varref,
            -command   => [@$callback, $_],
        );
    }
   $mb;
} # end native_optionmenu
1;