Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # menbut.pl |
2 | ||
3 | use vars qw/$TOP/; | |
4 | ||
5 | sub menbut { | |
6 | my($demo) = @_; | |
7 | $TOP = $MW->WidgetDemo( | |
8 | -name => $demo, | |
9 | -text => '', | |
10 | -title => 'Menubutton Demo', | |
11 | -iconname => 'Menubutton', | |
12 | ); | |
13 | ||
14 | my @menubuttons; | |
15 | foreach (qw/below right left above/) { | |
16 | my $pos = ucfirst; | |
17 | my $menubutton = $TOP->Menubutton(qw/-underline 0 -relief raised/, | |
18 | -text => $pos, -direction => $_); | |
19 | push @menubuttons, $menubutton; | |
20 | my $menu = $menubutton->menu(qw/-tearoff 0/); | |
21 | $menubutton->configure(-menu => $menu); | |
22 | $menubutton->command(-label => "$pos menu: first item", -command => | |
23 | sub {print "You selected the first item from the $pos menu.\n"}); | |
24 | $menubutton->command(-label => "$pos menu: second item", -command => | |
25 | sub {print "You selected the second item from the $pos menu.\n"}); | |
26 | } | |
27 | $menubuttons[0]->grid(qw/-row 0 -column 1 -sticky n/); | |
28 | $menubuttons[3]->grid(qw/-row 2 -column 1 -sticky n/); | |
29 | $menubuttons[1]->grid(qw/-row 1 -column 0 -sticky w/); | |
30 | $menubuttons[2]->grid(qw/-row 1 -column 2 -sticky e/); | |
31 | ||
32 | my $body = $TOP->Frame; | |
33 | $body->grid(qw/-row 1 -column 1 -sticky news/); | |
34 | $body->Label(qw/-wraplength 300 -justify left/, -font => 'Helvetica 14', | |
35 | -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 | |
36 | -pady 25/); | |
37 | $bbutt = $body->Frame->pack(qw/-padx 25 -pady 25/); | |
38 | $bbutt->Optionmenu(-options => [qw/one two three/])->pack(qw/-side left | |
39 | -padx 25 -pady 25/); | |
40 | ||
41 | my $palette; | |
42 | my(@colors) = qw/Black red4 DarkGreen NavyBlue gray75 Red Green Blue | |
43 | gray50 Yellow Cyan Magenta White Brown DarkSeaGreen DarkViolet/; | |
44 | ||
45 | my $colors = native_optionmenu( | |
46 | $bbutt, | |
47 | \$palette, | |
48 | [sub {print "args=@_.\n"}, 'First'], | |
49 | @colors, | |
50 | ); | |
51 | $colors->pack(qw/-side left -padx 25 -pady 25/); | |
52 | ||
53 | my $menu = $colors->cget(-menu); | |
54 | my $topborder = 'gray50'; | |
55 | my $bottomborder = 'gray75'; | |
56 | ||
57 | foreach my $i (0 .. $#colors) { | |
58 | ||
59 | # Create a 16 pixel x 16 pixel solid color swatch. | |
60 | # Add a black ring around the currently selected item. | |
61 | ||
62 | my $color = $menu->entrycget($i, -label); | |
63 | my $p = $TOP->Photo(qw/-width 16 -height 16/); | |
64 | $p->put($topborder, qw/-to 0 0 16 1/); | |
65 | $p->put($topborder, qw/-to 0 1 1 16/); | |
66 | $p->put($bottomborder, qw/-to 1 15 16 16/); | |
67 | $p->put($bottomborder, qw/-to 15 1 16 15/); | |
68 | $p->put($color, qw/-to 1 1 15 15/); | |
69 | ||
70 | my $r = $TOP->Photo(qw/-width 16 -height 16/); | |
71 | $r->put(qw/black -to 0 0 16 2/); | |
72 | $r->put(qw/black -to 0 2 2 16/); | |
73 | $r->put(qw/black -to 2 14 16 16/); | |
74 | $r->put(qw/black -to 14 2 16 14/); | |
75 | $r->put($color , qw/-to 2 2 14 14/); | |
76 | ||
77 | $menu->entryconfigure($i, -columnbreak => 1) unless $i % 4; | |
78 | $menu->entryconfigure($i, | |
79 | -image => $p, | |
80 | -hidemargin => 1, | |
81 | -selectimage => $r, | |
82 | ); | |
83 | ||
84 | } # forend all colors | |
85 | ||
86 | $menu->configure(-tearoff => 1); | |
87 | ||
88 | } # end menbut | |
89 | ||
90 | sub native_optionmenu { | |
91 | ||
92 | my($parent, $varref, $command, @optionvals) = @_; | |
93 | ||
94 | $$varref = $optionvals[0]; | |
95 | ||
96 | my $mb = $parent->Menubutton( | |
97 | -textvariable => $varref, | |
98 | -indicatoron => 1, | |
99 | -relief => 'raised', | |
100 | -borderwidth => 2, | |
101 | -highlightthickness => 2, | |
102 | -anchor => 'c', | |
103 | -direction => 'flush', | |
104 | ); | |
105 | my $menu = $mb->Menu(-tearoff => 0); | |
106 | $mb->configure(-menu => $menu); | |
107 | ||
108 | my $callback = ref($command) =~ /CODE/ ? [$command] : $command; | |
109 | ||
110 | foreach (@optionvals) { | |
111 | $menu->radiobutton( | |
112 | -label => $_, | |
113 | -variable => $varref, | |
114 | -command => [@$callback, $_], | |
115 | ); | |
116 | } | |
117 | ||
118 | $mb; | |
119 | ||
120 | } # end native_optionmenu | |
121 | ||
122 | 1; |