| 1 | # menus2.pl |
| 2 | |
| 3 | use subs qw/menus_error2/; |
| 4 | use vars qw/$TOP/; |
| 5 | |
| 6 | sub menus2 { |
| 7 | |
| 8 | # This demonstration script creates a window with a bunch of menus |
| 9 | # and cascaded menus, but uses -menuitems rather than the Tcl/Tk way. |
| 10 | |
| 11 | my ($demo) = @_; |
| 12 | $TOP = $MW->WidgetDemo( |
| 13 | -name => $demo, |
| 14 | -text => '', |
| 15 | -title => 'Menuitems Demonstration', |
| 16 | -iconname => 'menus2', |
| 17 | ); |
| 18 | |
| 19 | my $menubar = $TOP->Frame(-relief => 'raised', -borderwidth => 2); |
| 20 | $menubar->grid(qw/-sticky ew/); |
| 21 | my $f = $menubar->Menubutton(qw/-text File -underline 0 -menuitems/ => |
| 22 | [ |
| 23 | [Button => 'Open ...', -command => [\&menus_error2, 'Open']], |
| 24 | [Button => 'New', -command => [\&menus_error2, 'New']], |
| 25 | [Button => 'Save', -command => [\&menus_error2, 'Save']], |
| 26 | [Button => 'Save As ...', -command => [\&menus_error2, 'Save As']], |
| 27 | [Separator => ''], |
| 28 | [Button => 'Setup ...', -command => [\&menus_error2, 'Setup']], |
| 29 | [Button => 'Print ...', -command => [\&menus_error2, 'Print']], |
| 30 | [Separator => ''], |
| 31 | [Button => 'Quit', -command => [$TOP => 'bell']], |
| 32 | ])->grid(qw/-row 0 -column 0 -sticky w/); |
| 33 | |
| 34 | my $b = $menubar->Menubutton(qw/-text Basic -underline 0 -menuitems/ => |
| 35 | [ |
| 36 | [Button => 'Long entry that does nothing'], |
| 37 | map ( |
| 38 | [Button => "Print letter \"~$_\"", |
| 39 | -command => [sub {print "$_[0]\n"}, $_], |
| 40 | -accelerator => "Meta+$_" ], |
| 41 | ('a' .. 'g') |
| 42 | ), |
| 43 | ])->grid(qw/-row 0 -column 1 -sticky w/); |
| 44 | |
| 45 | my $menu_cb = '~Check buttons'; |
| 46 | my $menu_rb = '~Radio buttons'; |
| 47 | my $c = $menubar->Menubutton(qw/-text Cascades -underline 0 -menuitems/ => |
| 48 | [ |
| 49 | [Button => 'Print ~hello', -command => sub {print "Hello\n"}, |
| 50 | -accelerator => 'Control+a'], |
| 51 | [Button => 'Print ~goodbye', -command => sub {print "Goodbye\n"}, |
| 52 | -accelerator => 'Control+b'], |
| 53 | [Cascade => $menu_cb, -menuitems => |
| 54 | [ |
| 55 | [Checkbutton => 'Oil checked', -variable => \$OIL], |
| 56 | [Checkbutton => 'Transmission checked', -variable => \$TRANS], |
| 57 | [Checkbutton => 'Brakes checked', -variable => \$BRAKES], |
| 58 | [Checkbutton => 'Lights checked', -variable => \$LIGHTS], |
| 59 | [Separator => ''], |
| 60 | [Button => 'See current values', -command => |
| 61 | [\&see_vars, $TOP, [ |
| 62 | ['oil', \$OIL], |
| 63 | ['trans', \$TRANS], |
| 64 | ['brakes', \$BRAKES], |
| 65 | ['lights', \$LIGHTS], |
| 66 | ], |
| 67 | ], # end see_vars |
| 68 | ], # end button |
| 69 | ], # end checkbutton menuitems |
| 70 | ], # end checkbuttons cascade |
| 71 | [Cascade => $menu_rb, -menuitems => |
| 72 | [ |
| 73 | map ( |
| 74 | [Radiobutton => "$_ point", -variable => \$POINT_SIZE, |
| 75 | -value => $_, |
| 76 | ], |
| 77 | (qw/10 14 18 24 32/), |
| 78 | ), |
| 79 | [Separator => ''], |
| 80 | map ( |
| 81 | [Radiobutton => "$_", -variable => \$FONT_STYLE, |
| 82 | -value => $_, |
| 83 | ], |
| 84 | (qw/Roman Bold Italic/), |
| 85 | ), |
| 86 | [Separator => ''], |
| 87 | [Button => 'See current values', -command => |
| 88 | [\&see_vars, $TOP, [ |
| 89 | ['point size', \$POINT_SIZE], |
| 90 | ['font style', \$FONT_STYLE], |
| 91 | ], |
| 92 | ], # end see_vars |
| 93 | ], # end button |
| 94 | ], # end radiobutton menuitems |
| 95 | ], # end radiobuttons cascade |
| 96 | ])->grid(qw/-row 0 -column 2 -sticky w/); |
| 97 | |
| 98 | $TOP->bind('<Control-a>' => sub {print "Hello\n"}); |
| 99 | $TOP->bind('<Control-b>' => sub {print "Goodbye\n"}); |
| 100 | |
| 101 | # Fetch the Cascades menu, and from that get the checkbutton and |
| 102 | # radiobutton cascade menus and invoke a few menu items. |
| 103 | |
| 104 | my $cm = $c->cget(-menu); |
| 105 | $menu_cb = substr $menu_cb, 1; |
| 106 | my $cc = $cm->entrycget($menu_cb, -menu); |
| 107 | $cc->invoke(1); |
| 108 | $cc->invoke(3); |
| 109 | $menu_rb = substr $menu_rb, 1; |
| 110 | my $cr = $cm->entrycget($menu_rb, -menu); |
| 111 | $cr->invoke(1); |
| 112 | $cr->invoke(7); |
| 113 | |
| 114 | my $i = $menubar->Menubutton(qw/-text Icons -underline 0 -menuitems/ => |
| 115 | [ |
| 116 | [Button => '', -bitmap => '@'.Tk->findINC('demos/images/pattern'), |
| 117 | -command => [$DIALOG_ICON => 'Show']], |
| 118 | map ( |
| 119 | [Button => '', -bitmap => $_, |
| 120 | -command => |
| 121 | [sub {print "You invoked the \"$_[0]\" bitmap\n"}, $_]], |
| 122 | (qw/info questhead error/), |
| 123 | ), |
| 124 | ])->grid(qw/-row 0 -column 3 -sticky w/); |
| 125 | |
| 126 | my $m = $menubar->Menubutton(qw/-text More -underline 0 -menuitems/ => |
| 127 | [ |
| 128 | map ( |
| 129 | [Button => $_, |
| 130 | -command => |
| 131 | [sub {print "You invoked \"$_[0]\"\n"}, $_]], |
| 132 | ('An entry', 'Another entry', 'Does nothing', |
| 133 | 'Does almost nothing', 'Make life meaningful'), |
| 134 | ), |
| 135 | ])->grid(qw/-row 0 -column 4 -sticky w/); |
| 136 | |
| 137 | my $k = $menubar->Menubutton(qw/-text Colors -underline 1 -menuitems/ => |
| 138 | [ |
| 139 | map ( |
| 140 | [Button => $_, |
| 141 | -background => $_, |
| 142 | -command => |
| 143 | [sub {print "You invoked \"$_[0]\"\n"}, $_]], |
| 144 | (qw/red orange yellow green blue/), |
| 145 | ), |
| 146 | ])->grid(qw/-row 0 -column 5 -sticky w/); |
| 147 | |
| 148 | my $details = $TOP->Label(qw/-wraplength 4i -justify left -text/ => 'This window contains a collection of menus and 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.', -font => $FONT)->grid; |
| 149 | |
| 150 | } # end menus |
| 151 | |
| 152 | sub menus_error2 { |
| 153 | |
| 154 | |
| 155 | # Generate a background error, which may even be displayed in a window if |
| 156 | # using ErrorDialog. |
| 157 | |
| 158 | my($msg) = @_; |
| 159 | |
| 160 | $msg = "This is just a demo: no action has been defined for \"$msg\"."; |
| 161 | $TOP->BackTrace($msg); |
| 162 | |
| 163 | } # end menus_error |
| 164 | |
| 165 | |
| 166 | 1; |