home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _badea6ae0f7863c53f6b857497878d53 < prev    next >
Text File  |  2004-06-01  |  4KB  |  123 lines
  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;
  123.