Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # menus.pl |
2 | ||
3 | use subs qw/menus_error/; | |
4 | use vars qw/$TOP/; | |
5 | ||
6 | sub menus { | |
7 | ||
8 | # This demonstration script creates a window with a bunch of menus | |
9 | # and cascaded menus using a menubar. A <<MenuSelect>> virtual event | |
10 | # tracks the active menu item. | |
11 | ||
12 | my ($demo) = @_; | |
13 | $TOP = $MW->WidgetDemo( | |
14 | -name => $demo, | |
15 | -text => '', | |
16 | -title => 'Menu Demonstration', | |
17 | -iconname => 'menus', | |
18 | ); | |
19 | ||
20 | my $toplevel = $TOP->toplevel; | |
21 | my $menubar = $toplevel->Menu(-type => 'menubar'); | |
22 | $toplevel->configure(-menu => $menubar); | |
23 | ||
24 | my $modifier = 'Meta'; # Unix | |
25 | if ($^O eq 'MSWin32') { | |
26 | $modifier = 'Control'; | |
27 | } elsif ($^O eq 'MacOS') { # one of these days | |
28 | $modifier = 'Command'; | |
29 | } | |
30 | ||
31 | my $f = $menubar->cascade(-label => '~File', -tearoff => 0); | |
32 | $f->command(-label => 'Open ...', -command => [\&menus_error, 'Open']); | |
33 | $f->command(-label => 'New', -command => [\&menus_error, 'New']); | |
34 | $f->command(-label => 'Save', -command => [\&menus_error, 'Save']); | |
35 | $f->command(-label => 'Save As ...', -command => [\&menus_error, 'Save As']); | |
36 | $f->separator; | |
37 | $f->command(-label => 'Setup ...', -command => [\&menus_error, 'Setup']); | |
38 | $f->command(-label => 'Print ...', -command => [\&menus_error, 'Print']); | |
39 | $f->separator; | |
40 | $f->command(-label => 'Quit', -command => [$TOP => 'bell']); | |
41 | ||
42 | my $b = $menubar->cascade(-label => '~Basic', -tearoff => 0); | |
43 | $b->command(-label => 'Long entry that does nothing'); | |
44 | my $label; | |
45 | foreach $label (qw/A B C D E F/) { | |
46 | $b->command( | |
47 | -label => "Print letter \"$label\"", | |
48 | -underline => 14, | |
49 | -accelerator => "$modifier+$label", | |
50 | -command => sub {print "$label\n"}, | |
51 | ); | |
52 | $TOP->bind("<$modifier-${label}>" => sub {print "$label\n"}); | |
53 | } | |
54 | my $c = $menubar->cascade(-label => '~Cascades', -tearoff => 0); | |
55 | $c->command( | |
56 | -label => 'Print hello', | |
57 | -command => sub {print "Hello\n"}, | |
58 | -accelerator => "$modifier+H", | |
59 | -underline => 6, | |
60 | ); | |
61 | $TOP->bind("<$modifier-h>" => sub {print "Hello\n"}); | |
62 | $c->command( | |
63 | -label => 'Print goodbye', | |
64 | -command => sub {print "Goodbye\n"}, | |
65 | -accelerator => "$modifier+G", | |
66 | -underline => 6, | |
67 | ); | |
68 | $TOP->bind("<$modifier-g>" => sub {print "Goodbye\n"}); | |
69 | my $cc = $c->cascade(-label => '~Check buttons'); | |
70 | ||
71 | $cc->checkbutton(-label => 'Oil checked', -variable => \$OIL); | |
72 | $cc->checkbutton(-label => 'Transmission checked', -variable => \$TRANS); | |
73 | $cc->checkbutton(-label => 'Brakes checked', -variable => \$BRAKES); | |
74 | $cc->checkbutton(-label => 'Lights checked', -variable => \$LIGHTS); | |
75 | $cc->separator; | |
76 | $cc->command( | |
77 | -label => 'See current values', | |
78 | -command => [\&see_vars, $MW, [ | |
79 | ['oil', \$OIL], | |
80 | ['trans', \$TRANS], | |
81 | ['brakes', \$BRAKES], | |
82 | ['lights', \$LIGHTS], | |
83 | ], | |
84 | ], | |
85 | ); | |
86 | my $cc_menu = $cc->cget(-menu); | |
87 | $cc_menu->invoke(1); | |
88 | $cc_menu->invoke(3); | |
89 | ||
90 | my $rc = $c->cascade(-label => '~Radio buttons'); | |
91 | ||
92 | foreach $label (qw/10 14 18 24 32/) { | |
93 | $rc->radiobutton( | |
94 | -label => "$label point", | |
95 | -variable => \$POINT_SIZE, | |
96 | -value => $label, | |
97 | ); | |
98 | } | |
99 | $rc->separator; | |
100 | foreach $label (qw/Roman Bold Italic/) { | |
101 | $rc->radiobutton( | |
102 | -label => $label, | |
103 | -variable => \$FONT_STYLE, | |
104 | -value => $label, | |
105 | ); | |
106 | } | |
107 | $rc->separator; | |
108 | $rc->command( | |
109 | -label => 'See current values', | |
110 | -command => [\&see_vars, $MW, [ | |
111 | ['point size', \$POINT_SIZE], | |
112 | ['font style', \$FONT_STYLE], | |
113 | ], | |
114 | ], | |
115 | ); | |
116 | my $rc_menu = $rc->cget(-menu); | |
117 | $rc_menu->invoke(1); | |
118 | $rc_menu->invoke(7); | |
119 | ||
120 | my $i = $menubar->cascade(-label => '~Icons', -tearoff => 0); | |
121 | $i->command( | |
122 | -bitmap => '@'.Tk->findINC('demos/images/pattern'), | |
123 | -command => [$DIALOG_ICON => 'Show'], | |
124 | -hidemargin => 1, | |
125 | ); | |
126 | foreach $label (qw/info questhead error/) { | |
127 | $i->command( | |
128 | -bitmap => $label, | |
129 | -command => sub {print "You invoked the \"$label\" bitmap\n"}, | |
130 | -hidemargin => 1, | |
131 | ); | |
132 | } | |
133 | $i->cget(-menu)->entryconfigure(2, -columnbreak => 1); | |
134 | ||
135 | my $m = $menubar->cascade(-label => '~More', -tearoff => 0); | |
136 | foreach $label ('An entry', 'Another entry', 'Does nothing', | |
137 | 'Does almost nothing', 'Make life meaningful') { | |
138 | $m->command( | |
139 | -label => $label, | |
140 | -command => sub {print "You invoked \"$label\"\n"}, | |
141 | ); | |
142 | } | |
143 | ||
144 | my $k = $menubar->cascade(-label => 'C~olors'); | |
145 | foreach $label (qw/red orange yellow green blue/) { | |
146 | $k->command( | |
147 | -label => $label, | |
148 | -background => $label, | |
149 | -command => sub {print "You invoked \"$label\"\n"}, | |
150 | ); | |
151 | } | |
152 | ||
153 | $TOP->Label(qw/-wraplength 4.5i -justify left -text/ => 'This window contains a menubar with cascaded menus. You can post a menu from the keyboard by typing Alt+x, where "x" is the character underlined on the menu. You can then traverse among the menus using the arrow keys. When a menu is posted, you can invoke the current entry by typing space, or you can invoke any entry by typing its underlined character. If a menu entry has an accelerator, you can invoke the entry without posting the menu just by typing the accelerator. The rightmost menu can be torn off into a palette by selecting the first item in the menu.', -font => $FONT)->pack; | |
154 | ||
155 | my $status_bar = ' '; | |
156 | $TOP->Label(qw/-relief sunken -borderwidth 1 -anchor w/, | |
157 | -font => 'Helvetica 10', -textvariable => \$status_bar)-> | |
158 | pack(qw/-padx 2 -pady 2 -expand yes -fill both/); | |
159 | $menubar->bind('<<MenuSelect>>' => sub { | |
160 | my $label = undef; | |
161 | my $w = $Tk::event->W; | |
162 | $label = $w->entrycget('active', -label); | |
163 | $status_bar = $label; | |
164 | $TOP->idletasks; | |
165 | }); | |
166 | ||
167 | } # end menus | |
168 | ||
169 | sub menus_error { | |
170 | ||
171 | # Generate a background error, which may even be displayed in a window if | |
172 | # using ErrorDialog. | |
173 | ||
174 | my($msg) = @_; | |
175 | ||
176 | $msg = "This is just a demo: no action has been defined for \"$msg\"."; | |
177 | $TOP->BackTrace($msg); | |
178 | ||
179 | } # end menus_error | |
180 | ||
181 | ||
182 | 1; |