home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _44486a93ea6f22345a7430810bd794a0 < prev    next >
Encoding:
Text File  |  2004-06-01  |  7.3 KB  |  197 lines
  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     => ['', -wraplength => '5i'],    
  16.         -title    => 'Menu Demonstration',
  17.         -iconname => 'menus',
  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(-label => '~File', -tearoff => 0);
  42.     $f->command(-label => 'Open ...',    -command => [\&menus_error, 'Open'],
  43.             -image => $toplevel->Getimage("openfile"), -compound => "left");
  44.     $f->command(-label => 'New',         -command => [\&menus_error, 'New'],
  45.             -image => $toplevel->Getimage("file"), -compound => "left");
  46.     $f->command(-label => 'Save',        -command => [\&menus_error, 'Save']);
  47.     $f->command(-label => 'Save As ...', -command => [\&menus_error, 'Save As']);
  48.     $f->separator;
  49.     $f->command(-label => 'Setup ...',   -command => [\&menus_error, 'Setup']);
  50.     $f->command(-label => 'Print ...',   -command => [\&menus_error, 'Print']);
  51.     $f->separator;
  52.     $f->command(-label => 'Quit',        -command => [$TOP => 'bell']);
  53.  
  54.     my $b = $menubar->cascade(-label => '~Basic', -tearoff => 0);
  55.     $b->command(-label => 'Long entry that does nothing');
  56.     my $label;
  57.     foreach $label (qw/A B C D E F/) {
  58.     $b->command(
  59.              -label => "Print letter \"$label\"",
  60.              -underline => 14,
  61.          -accelerator => "$modifier+$label",
  62.              -command => sub {print "$label\n"},
  63.         );
  64.     $TOP->bind("<$modifier-${label}>" => sub {print "$label\n"});
  65.     }
  66.     my $c = $menubar->cascade(-label => '~Cascades', -tearoff => 0);
  67.     $c->command(
  68.         -label       => 'Print hello',
  69.         -command     => sub {print "Hello\n"},
  70.     -accelerator => "$modifier+H",
  71.         -underline   => 6,
  72.     );
  73.     $TOP->bind("<$modifier-h>" => sub {print "Hello\n"});
  74.     $c->command(
  75.         -label       => 'Print goodbye',
  76.         -command     => sub {print "Goodbye\n"},
  77.     -accelerator => "$modifier+G",
  78.         -underline   => 6,
  79.     );
  80.     $TOP->bind("<$modifier-g>" => sub {print "Goodbye\n"});
  81.     my $cc = $c->cascade(-label => '~Check buttons', -tearoff => 0);
  82.  
  83.     $cc->checkbutton(-label => 'Oil checked', -variable => \$OIL);
  84.     $cc->checkbutton(-label => 'Transmission checked', -variable => \$TRANS);
  85.     $cc->checkbutton(-label => 'Brakes checked', -variable => \$BRAKES);
  86.     $cc->checkbutton(-label => 'Lights checked', -variable => \$LIGHTS);
  87.     $cc->separator;
  88.     $cc->command(
  89.         -label => 'See current values',
  90.     -command => [\&see_vars, $MW, [
  91.                                        ['oil',     \$OIL],
  92.                                        ['trans',   \$TRANS],
  93.                                        ['brakes',  \$BRAKES],
  94.                                        ['lights',  \$LIGHTS],
  95.                                       ],
  96.                     ],
  97.     );
  98.     my $cc_menu = $cc->cget(-menu);
  99.     $cc_menu->invoke(1);
  100.     $cc_menu->invoke(3);
  101.  
  102.     my $rc = $c->cascade(-label => '~Radio buttons', -tearoff => 0);
  103.  
  104.     foreach $label (qw/10 14 18 24 32/) {
  105.     $rc->radiobutton(
  106.             -label    => "$label point",
  107.             -variable => \$POINT_SIZE,
  108.             -value    => $label,
  109.         );
  110.     }
  111.     $rc->separator;
  112.     foreach $label (qw/Roman Bold Italic/) {
  113.     $rc->radiobutton(
  114.             -label    => $label,
  115.             -variable => \$FONT_STYLE,
  116.             -value    => $label,
  117.         );
  118.     }
  119.     $rc->separator;
  120.     $rc->command(
  121.         -label => 'See current values',
  122.     -command => [\&see_vars, $MW, [
  123.                                       ['point size', \$POINT_SIZE],
  124.                                       ['font style', \$FONT_STYLE],
  125.                                      ],
  126.                     ],
  127.     );
  128.     my $rc_menu = $rc->cget(-menu);
  129.     $rc_menu->invoke(1);
  130.     $rc_menu->invoke(7);
  131.  
  132.     my $i = $menubar->cascade(-label => '~Icons', -tearoff => 0);
  133.     $i->command(
  134.         -bitmap => '@'.Tk->findINC('demos/images/pattern'),
  135.     -command => sub {
  136.         $TOP->messageBox(
  137.                  -title => 'Bitmap Menu Entry', 
  138.                  -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.', 
  139.                  -type => 'ok'),
  140.         },
  141.     -hidemargin => 1,
  142.     );
  143.     foreach $label (qw/info questhead error/) {
  144.     $i->command(
  145.             -bitmap  => $label,
  146.             -command => sub {print "You invoked the \"$label\" bitmap\n"},
  147.             -hidemargin => 1,
  148.         );
  149.     }
  150.     $i->cget(-menu)->entryconfigure(2, -columnbreak => 1);
  151.  
  152.     my $m = $menubar->cascade(-label => '~More', -tearoff => 0);
  153.     foreach $label ('An entry', 'Another entry', 'Does nothing',
  154.             'Does almost nothing', 'Make life meaningful') {
  155.     $m->command(
  156.             -label   => $label,
  157.         -command => sub {print "You invoked \"$label\"\n"},
  158.         );
  159.     }
  160.  
  161.     my $k = $menubar->cascade(-label => 'C~olors');
  162.     foreach $label (qw/red orange yellow green blue/) {
  163.     $k->command(
  164.             -label      => $label,
  165.             -background => $label,
  166.         -command => sub {print "You invoked \"$label\"\n"},
  167.         );
  168.     }
  169.  
  170.     my $status_bar;
  171.     $TOP->Label(
  172.         qw/-relief sunken -borderwidth 1 -anchor w/,
  173.         -font => 'Helvetica 10', -textvariable => \$status_bar)->
  174.     pack(qw/-padx 2 -pady 2 -expand yes -fill both/);
  175.     $menubar->bind('<<MenuSelect>>' => sub {
  176.     $status_bar = undef;
  177.     $status_bar = $_[0]->entrycget('active', -label);
  178.     $TOP->idletasks;
  179.     });
  180.  
  181. } # end menus
  182.  
  183. sub menus_error {
  184.  
  185.     # Generate a background error, which may even be displayed in a window if
  186.     # using ErrorDialog.
  187.  
  188.     my($msg) = @_;
  189.  
  190.     $msg = "This is just a demo: no action has been defined for \"$msg\".";
  191.     $TOP->BackTrace($msg);
  192.  
  193. } # end menus_error
  194.  
  195.  
  196. 1;
  197.