home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / Menu / Item.pm
Encoding:
Perl POD Document  |  1997-08-10  |  5.1 KB  |  220 lines

  1. package Tk::Menu::Item;
  2.  
  3. require Tk::Menu;
  4.  
  5. use Carp;
  6. use strict;
  7.  
  8. sub PreInit
  9. {
  10.  # Dummy (virtual) method
  11.  my ($class,$menu,$minfo) = @_;
  12. }
  13.  
  14. sub new
  15. {
  16.  my ($class,$menu,%minfo) = @_;
  17.  my $kind = $class->kind;
  18.  my $name = $minfo{'-label'};
  19.  if (defined $kind)
  20.   {
  21.    my $invoke = delete $minfo{'-invoke'};
  22.    if (defined $name)
  23.     {
  24.      # Use ~ in name/label to set -underline
  25.      if (defined($minfo{-label}) && !defined($minfo{-underline}))
  26.       {
  27.        my $cleanlabel = $minfo{-label};
  28.        my $underline = ($cleanlabel =~ s/^(.*)~/$1/) ? length($1): undef;
  29.        if (defined($underline) && ($underline >= 0))
  30.         {
  31.          $minfo{-underline} = $underline;
  32.          $name = $cleanlabel if ($minfo{-label} eq $name);
  33.          $minfo{-label} = $cleanlabel;
  34.         }
  35.       }
  36.     }
  37.    else
  38.     {
  39.      $name = $minfo{'-bitmap'} || $minfo{'-image'};
  40.      croak("No -label") unless defined($name);
  41.      $minfo{'-label'} = $name;
  42.     }
  43.    $class->PreInit($menu,\%minfo);    
  44.    $menu->add($kind,%minfo);          
  45.    $menu->invoke('last') if ($invoke);
  46.   }
  47.  else
  48.   {
  49.    $menu->add('separator');
  50.   }
  51.  return bless [$menu,$name],$class;
  52.  
  53. sub configure
  54. {
  55.  my $obj = shift;
  56.  my ($menu,$name) = @$obj;
  57.  $menu->entryconfigure($name,@_);
  58. }
  59.  
  60. sub cget
  61. {
  62.  my $obj = shift;
  63.  my ($menu,$name) = @$obj;
  64.  $menu->entrycget($name,@_);
  65. }
  66.  
  67. sub parentMenu
  68. {
  69.  my $obj = shift;
  70.  return $obj->[0];
  71. }
  72.  
  73. # Default "kind" is a command
  74. sub kind { return 'command' }
  75.  
  76. # Now the derived packages 
  77.  
  78. package Tk::Menu::Separator;
  79. @Tk::Menu::Separator::ISA = qw(Tk::Menu::Item);
  80. Construct Tk::Menu 'Separator';
  81. sub kind { return undef }
  82.  
  83. package Tk::Menu::Button;
  84. @Tk::Menu::Button::ISA = qw(Tk::Menu::Item);
  85. Construct Tk::Menu 'Button';
  86.  
  87. package Tk::Menu::Command;
  88. @Tk::Menu::Command::ISA = qw(Tk::Menu::Button);
  89. Construct Tk::Menu 'Command';
  90.  
  91. package Tk::Menu::Cascade;
  92. @Tk::Menu::Cascade::ISA = qw(Tk::Menu::Item);
  93. Construct Tk::Menu 'Cascade';
  94. sub kind { return 'cascade' }
  95.  
  96. sub PreInit
  97. {
  98.  my ($class,$menu,$minfo) = @_;
  99.  my $tearoff   = delete $minfo->{-tearoff};
  100.  my $items     = delete $minfo->{-menuitems};
  101.  my $widgetvar = delete $minfo->{-menuvar};
  102.  my @args = ();
  103.  push(@args, '-tearoff' => $tearoff) if (defined $tearoff);
  104.  push(@args, '-menuitems' => $items) if (defined $items);
  105.  my $submenu = $menu->Menu(@args);
  106.  $minfo->{'-menu'} = $submenu;
  107.  $$widgetvar = $submenu if (defined($widgetvar) && ref($widgetvar));
  108. }
  109.  
  110. sub menu
  111. {
  112.  my ($self,%args) = @_;
  113.  my $w = $self->parentMenu;
  114.  my $menu = $self->cget('-menu');
  115.  if (!defined $menu)
  116.   {
  117.    require Tk::Menu;
  118.    $w->ColorOptions(\%args); 
  119.    $menu = $w->Menu(%args);
  120.    $self->configure('-menu'=>$menu);
  121.   }
  122.  else
  123.   {
  124.    $menu->configure(%args);
  125.   }
  126.  return $menu;
  127. }
  128.  
  129. package Tk::Menu::Checkbutton;
  130. @Tk::Menu::Checkbutton::ISA = qw(Tk::Menu::Item);
  131. Construct Tk::Menu 'Checkbutton';
  132. sub kind { return 'checkbutton' }
  133.  
  134. package Tk::Menu::Radiobutton;
  135. @Tk::Menu::Radiobutton::ISA = qw(Tk::Menu::Item);
  136. Construct Tk::Menu 'Radiobutton';
  137. sub kind { return 'radiobutton' }
  138.  
  139. package Tk::Menu::Item;
  140.  
  141. 1;
  142. __END__
  143.  
  144. =head1 NAME
  145.  
  146. Tk::Menu::Item - Base class for Menu items
  147.  
  148. =head1 SYNOPSIS
  149.  
  150.    require Tk::Menu::Item;
  151.  
  152.    my $but = $menu->Button(...);
  153.    $but->configure(...);
  154.    my $what = $but->cget();
  155.  
  156.    package Whatever;
  157.    require Tk::Menu::Item;
  158.    @ISA = qw(Tk::Menu::Item);
  159.  
  160.    sub PreInit
  161.    {
  162.     my ($class,$menu,$info) = @_;
  163.     $info->{'-xxxxx'} = ...
  164.     my $y = delete $info->{'-yyyy'};
  165.    }
  166.  
  167. =head1 DESCRIPTION
  168.  
  169. Tk::Menu::Item is the base class from which Tk::Menu::Button,
  170. Tk::Menu::Cascade, Tk::Menu::Radiobutton and Tk::Menu::Checkbutton are derived.
  171. There is also a Tk::Menu::Separator.
  172.  
  173. Constructors are declared so that $menu-E<gt>Button(...) etc. do what you would 
  174. expect. 
  175.  
  176. The C<-label> option is pre-processed allowing ~ to be prefixed to the character
  177. to derive a C<-underline> value. Thus
  178.  
  179.     $menu->Button(-label => 'Goto ~Home',...)
  180.  
  181.     is equivalent to 
  182.  
  183.     $menu->Button(-label => 'Goto Home', -underline => 6, ...)
  184.  
  185. C<Cascade> accepts C<-menuitems> which is a list of items for the sub-menu.
  186. Within this list (which is also accepted by Menu and Menubutton) the first
  187. two elements of each item should be the "constructor" name and the label:
  188.  
  189.     -menuitems => [
  190.                    [Button      => '~Quit', -command => [destroy => $mw]],
  191.                    [Checkbutton => '~Oil',  -variable => \$oil], 
  192.                   ] 
  193.  
  194. Also C<-tearoff> is propagated to the submenu, and C<-menuvar> (if present) 
  195. is set to the created sub-menu.
  196.  
  197. The returned object is currently a blessed reference to an array of two items:
  198. the containing Menu and the 'label'. 
  199. Methods C<configure> and C<cget> are mapped onto underlying C<entryconfigure>
  200. and C<entrycget>.
  201.  
  202. The main purpose of the OO interface is to allow derived item classes to 
  203. be defined which pre-set the options used to create a more basic item.
  204.  
  205.  
  206. =head1 BUGS
  207.  
  208. This OO interface is very new. Using the label as the "key" is a problem
  209. for separaror items which don't have one. The alternative would be to 
  210. use an index into the menu but that is a problem if items are deleted
  211. (or inserted other than at the end).
  212.  
  213. There should probably be a PostInit entry point too, or a more widget like
  214. defered 'configure'.
  215.  
  216. =cut
  217.  
  218.  
  219.