home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _db43f72f6bd8bd33e03ba48bf53c76aa < prev    next >
Encoding:
Text File  |  2004-06-01  |  7.2 KB  |  217 lines
  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 the unique Perl/Tk -menuitems way.
  10.     # A <<MenuSelect>> virtual event tracks the active menu item.
  11.  
  12.     my ($demo) = @_;
  13.     $TOP = $MW->WidgetDemo(
  14.         -name     => $demo,
  15.         -text     => ['', -wraplength => '5i'],               
  16.         -title    => 'Menuitems Demonstration',
  17.         -iconname => 'menus2',
  18.     );
  19.  
  20.     my $ws = $TOP->windowingsystem;
  21.  
  22.     my $text = ($ws eq 'classic' or $ws eq 'aqua') ?
  23.         'This window contains a menubar with cascaded menus.  You can invoke entries with an accelerator by typing Command+x, where "x" is the character next to the command key symbol. The rightmost menu can be torn off into a palette by dragging outside of its bounds and releasing the mouse.' :
  24.         '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.';
  25.  
  26.     $TOP->configure(-text => $text);
  27.  
  28.     my $toplevel = $TOP->toplevel; # get $TOP's Toplevel widget reference
  29.     my $menubar = $toplevel->Menu(-type => 'menubar');
  30.     $toplevel->configure(-menu => $menubar);
  31.  
  32.     my $modifier;
  33.     if ( $ws eq 'classic' or $ws eq 'aqua') {
  34.     $modifier = 'Command';
  35.     } elsif ($Tk::platform eq 'windows') {
  36.     $modifier = 'Control';
  37.     } else {
  38.     $modifier = 'Meta';
  39.     }
  40.     
  41.     my $f = $menubar->Cascade(qw/-label ~File -tearoff 0 -menuitems/ =>
  42.         [
  43.          [Button => 'Open ...',    -command => [\&menus_error2, 'Open'],
  44.                      -image   => $toplevel->Getimage("openfile"),
  45.                      -compound=> "left",
  46.      ],
  47.      [Button => 'New',         -command => [\&menus_error2, 'New'],
  48.                      -image   => $toplevel->Getimage("file"),
  49.                      -compound=> "left",
  50.      ],
  51.      [Button => 'Save',        -command => [\&menus_error2, 'Save']],
  52.      [Button => 'Save As ...', -command => [\&menus_error2, 'Save As']],
  53.      [Separator => ''],
  54.      [Button => 'Setup ...',   -command => [\&menus_error2, 'Setup']],
  55.      [Button => 'Print ...',   -command => [\&menus_error2, 'Print']],
  56.      [Separator => ''],
  57.      [Button => 'Quit',        -command => [$TOP => 'bell']],
  58.     ],
  59.     );
  60.  
  61.     my $b = $menubar->Cascade(qw/-label ~Basic -tearoff 0 -menuitems/ =>
  62.         [
  63.      [Button => 'Long entry that does nothing'],
  64.       map (
  65.            [Button       => "Print letter \"~$_\"",
  66.             -command     => [sub {print "$_[0]\n"}, $_],
  67.             -accelerator => "Meta+$_" ],
  68.            ('a' .. 'g')
  69.       ),
  70.         ],
  71.     );
  72.  
  73.     my $menu_cb = '~Check buttons';
  74.     my $menu_rb = '~Radio buttons';
  75.  
  76.     my $c = $menubar->Cascade(qw/-label ~Cascades -tearoff 0 -menuitems/ =>
  77.         [
  78.      [Button => 'Print ~hello',   -command => sub {print "Hello\n"},
  79.       -accelerator => 'Control+a'],
  80.      [Button => 'Print ~goodbye', -command => sub {print "Goodbye\n"},
  81.       -accelerator => 'Control+b'],
  82.      [Cascade => $menu_cb, -tearoff => 0, -menuitems =>
  83.       [
  84.        [Checkbutton => 'Oil checked',          -variable => \$OIL],
  85.        [Checkbutton => 'Transmission checked', -variable => \$TRANS],
  86.        [Checkbutton => 'Brakes checked',       -variable => \$BRAKES],
  87.        [Checkbutton => 'Lights checked',       -variable => \$LIGHTS],
  88.        [Separator => ''],
  89.        [Button => 'See current values', -command =>
  90.         [\&see_vars, $TOP, [
  91.                 ['oil',     \$OIL],
  92.                 ['trans',   \$TRANS],
  93.                 ['brakes',  \$BRAKES],
  94.                 ['lights',  \$LIGHTS],
  95.                 ],
  96.             ], # end see_vars
  97.        ], # end button
  98.       ], # end checkbutton menuitems
  99.      ], # end checkbuttons cascade
  100.      [Cascade => $menu_rb, -tearoff => 0, -menuitems =>
  101.       [
  102.        map (
  103.         [Radiobutton => "$_ point", -variable => \$POINT_SIZE,
  104.          -value => $_,
  105.          ],
  106.         (qw/10 14 18 24 32/),
  107.         ),
  108.        [Separator => ''],
  109.        map (
  110.         [Radiobutton => "$_", -variable => \$FONT_STYLE,
  111.          -value => $_,
  112.          ],
  113.         (qw/Roman Bold Italic/),
  114.         ),
  115.        [Separator => ''],
  116.        [Button => 'See current values', -command =>
  117.         [\&see_vars, $TOP, [
  118.                 ['point size', \$POINT_SIZE],
  119.                 ['font style', \$FONT_STYLE],
  120.                 ],
  121.          ], # end see_vars
  122.         ], # end button
  123.        ], # end radiobutton menuitems
  124.       ], # end radiobuttons cascade
  125.          ],
  126.     );
  127.  
  128.     $TOP->bind('<Control-a>' => sub {print "Hello\n"});
  129.     $TOP->bind('<Control-b>' => sub {print "Goodbye\n"});
  130.  
  131.     # Fetch the Cascades menu, and from that get the checkbutton and
  132.     # radiobutton cascade menus and invoke a few menu items.
  133.  
  134.     my $cm = $c->cget(-menu);
  135.     $menu_cb = substr $menu_cb, 1;
  136.     my $cc = $cm->entrycget($menu_cb, -menu);
  137.     $cc->invoke(1);
  138.     $cc->invoke(3);
  139.     $menu_rb = substr $menu_rb, 1;
  140.     my $cr = $cm->entrycget($menu_rb, -menu);
  141.     $cr->invoke(1);
  142.     $cr->invoke(7);
  143.  
  144.     my $i = $menubar->Cascade(qw/-label ~Icons -tearoff 0 -menuitems/ =>
  145.         [
  146.      [Button   => '', -bitmap => '@'.Tk->findINC('demos/images/pattern'),
  147.       -command => sub {
  148.           $TOP->messageBox(
  149.                    -title => 'Bitmap Menu Entry', 
  150.                    -message => 'The menu entry you invoked displays a bitmap rather than a text string.  Other than this, it is just like any other menu entry.', 
  151.                    -type => 'ok'),
  152.           },
  153.       ],
  154.      map (
  155.           [Button  => '', -bitmap => $_,
  156.           -command =>
  157.            [sub {print "You invoked the \"$_[0]\" bitmap\n"}, $_]],
  158.           (qw/info questhead error/),
  159.           ),
  160.         ],
  161.     );
  162.     my $im = $i->cget(-menu);
  163.     $im->entryconfigure(2, -columnbreak => 1);
  164.  
  165.     my $m = $menubar->Cascade(qw/-label ~More -tearoff 0 -menuitems/ =>
  166.         [
  167.      map (
  168.           [Button   => $_,
  169.            -command =>
  170.            [sub {print "You invoked \"$_[0]\"\n"}, $_]],
  171.           ('An entry', 'Another entry', 'Does nothing',
  172.            'Does almost nothing', 'Make life meaningful'),
  173.           ),
  174.         ],
  175.     );
  176.  
  177.     my $k = $menubar->cascade(qw/-label C~olors -tearoff 1 -menuitems/ =>
  178.         [
  179.      map (
  180.           [Button      => $_,
  181.            -background => $_,
  182.            -command    =>
  183.            [sub {print "You invoked \"$_[0]\"\n"}, $_]],
  184.           (qw/red orange yellow green blue/),
  185.           ),
  186.         ],
  187.     );
  188.  
  189.     my $status_bar;
  190.     $TOP->Label(
  191.         qw/-relief sunken -borderwidth 1 -anchor w/,
  192.         -font => 'Helvetica 10', -textvariable => \$status_bar)->
  193.     pack(qw/-padx 2 -pady 2 -expand yes -fill both/);
  194.     $menubar->bind('<<MenuSelect>>' => sub {
  195.     $status_bar = undef;
  196.     $status_bar = $_[0]->entrycget('active', -label);
  197.     $TOP->idletasks;
  198.     });
  199.  
  200. } # end menus2
  201.  
  202. sub menus_error2 {
  203.  
  204.  
  205.     # Generate a background error, which may even be displayed in a window if
  206.     # using ErrorDialog.
  207.  
  208.     my($msg) = @_;
  209.  
  210.     $msg = "This is just a demo: no action has been defined for \"$msg\".";
  211.     $TOP->BackTrace($msg);
  212.  
  213. } # end menus_error
  214.  
  215.  
  216. 1;
  217.