home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _dc0214f856cab5574c7b6833ed2bb5a2 < prev    next >
Text File  |  2004-06-01  |  4KB  |  181 lines
  1. package Tk::Menu::Item;
  2.  
  3. require Tk::Menu;
  4.  
  5. use Carp;
  6. use strict;
  7.  
  8. use vars qw($VERSION);
  9. $VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Menu/Item.pm#4 $
  10.  
  11. sub PreInit
  12. {
  13.  # Dummy (virtual) method
  14.  my ($class,$menu,$minfo) = @_;
  15. }
  16.  
  17. sub new
  18. {
  19.  my ($class,$menu,%minfo) = @_;
  20.  my $kind = $class->kind;
  21.  my $name = $minfo{'-label'};
  22.  if (defined $kind)
  23.   {
  24.    my $invoke = delete $minfo{'-invoke'};
  25.    if (defined $name)
  26.     {
  27.      # Use ~ in name/label to set -underline
  28.      if (defined($minfo{-label}) && !defined($minfo{-underline}))
  29.       {
  30.        my $cleanlabel = $minfo{-label};
  31.        my $underline = ($cleanlabel =~ s/^(.*)~/$1/) ? length($1): undef;
  32.        if (defined($underline) && ($underline >= 0))
  33.         {
  34.          $minfo{-underline} = $underline;
  35.          $name = $cleanlabel if ($minfo{-label} eq $name);
  36.          $minfo{-label} = $cleanlabel;
  37.         }
  38.       }
  39.     }
  40.    else
  41.     {
  42.      $name = $minfo{'-bitmap'} || $minfo{'-image'};
  43.      croak('No -label') unless defined($name);
  44.      $minfo{'-label'} = $name;
  45.     }
  46.    $class->PreInit($menu,\%minfo);
  47.    $menu->add($kind,%minfo);
  48.    $menu->invoke('last') if ($invoke);
  49.   }
  50.  else
  51.   {
  52.    $menu->add('separator');
  53.   }
  54.  return bless [$menu,$name],$class;
  55. }
  56.  
  57. sub configure
  58. {
  59.  my $obj = shift;
  60.  my ($menu,$name) = @$obj;
  61.  my %args = @_;
  62.  $obj->[1] = $args{'-label'} if exists $args{'-label'};
  63.  $menu->entryconfigure($name,@_);
  64. }
  65.  
  66. sub cget
  67. {
  68.  my $obj = shift;
  69.  my ($menu,$name) = @$obj;
  70.  $menu->entrycget($name,@_);
  71. }
  72.  
  73. sub parentMenu
  74. {
  75.  my $obj = shift;
  76.  return $obj->[0];
  77. }
  78.  
  79. # Default "kind" is a command
  80. sub kind { return 'command' }
  81.  
  82. # Now the derived packages
  83.  
  84. package Tk::Menu::Separator;
  85. use base qw(Tk::Menu::Item);
  86. Construct Tk::Menu 'Separator';
  87. sub kind { return undef }
  88.  
  89. package Tk::Menu::Button;
  90. use base qw(Tk::Menu::Item);
  91. Construct Tk::Menu 'Button';
  92. Construct Tk::Menu 'Command';
  93.  
  94. #package Tk::Menu::Command;
  95. #use base qw(Tk::Menu::Button);
  96. #Construct Tk::Menu 'Command';
  97.  
  98. package Tk::Menu::Cascade;
  99. use base qw(Tk::Menu::Item);
  100. Construct Tk::Menu 'Cascade';
  101. sub kind { return 'cascade' }
  102. use Carp;
  103.  
  104. sub PreInit
  105. {
  106.  my ($class,$menu,$minfo) = @_;
  107.  my $tearoff   = delete $minfo->{-tearoff};
  108.  my $items     = delete $minfo->{-menuitems};
  109.  my $widgetvar = delete $minfo->{-menuvar};
  110.  my $command   = delete $minfo->{-postcommand};
  111.  my $name = delete $minfo->{'Name'};
  112.  $name = $minfo->{'-label'} unless defined $name;
  113.  my @args = ();
  114.  push(@args, '-tearoff' => $tearoff) if (defined $tearoff);
  115.  push(@args, '-menuitems' => $items) if (defined $items);
  116.  push(@args, '-postcommand' => $command) if (defined $command);
  117.  my $submenu = $minfo->{'-menu'};
  118.  unless (defined $submenu)
  119.   {
  120.    $minfo->{'-menu'} = $submenu = $menu->Menu(Name => $name, @args);
  121.   }
  122.  $$widgetvar = $submenu if (defined($widgetvar) && ref($widgetvar));
  123. }
  124.  
  125. sub menu
  126. {
  127.  my ($self,%args) = @_;
  128.  my $w = $self->parentMenu;
  129.  my $menu = $self->cget('-menu');
  130.  if (!defined $menu)
  131.   {
  132.    require Tk::Menu;
  133.    $w->ColorOptions(\%args);
  134.    my $name = $self->cget('-label');
  135.    warn "Had to (re-)reate menu for $name";
  136.    $menu = $w->Menu(Name => $name, %args);
  137.    $self->configure('-menu'=>$menu);
  138.   }
  139.  else
  140.   {
  141.    $menu->configure(%args) if %args;
  142.   }
  143.  return $menu;
  144. }
  145.  
  146. # Some convenience methods
  147.  
  148. sub separator   {  shift->menu->Separator(@_);   }
  149. sub command     {  shift->menu->Command(@_);     }
  150. sub cascade     {  shift->menu->Cascade(@_);     }
  151. sub checkbutton {  shift->menu->Checkbutton(@_); }
  152. sub radiobutton {  shift->menu->Radiobutton(@_); }
  153.  
  154. sub pack
  155. {
  156.  my $w = shift;
  157.  if ($^W)
  158.   {
  159.    require Carp;
  160.    Carp::carp("Cannot 'pack' $w - done automatically")
  161.   }
  162. }
  163.  
  164. package Tk::Menu::Checkbutton;
  165. use base qw(Tk::Menu::Item);
  166. Construct Tk::Menu 'Checkbutton';
  167. sub kind { return 'checkbutton' }
  168.  
  169. package Tk::Menu::Radiobutton;
  170. use base qw(Tk::Menu::Item);
  171. Construct Tk::Menu 'Radiobutton';
  172. sub kind { return 'radiobutton' }
  173.  
  174. package Tk::Menu::Item;
  175.  
  176. 1;
  177. __END__
  178.  
  179. =cut
  180.  
  181.