home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / Menubar.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  2.1 KB  |  84 lines
  1. # Copyright (c) 1995-1997 Nick Ing-Simmons. All rights reserved.
  2. # This program is free software; you can redistribute it and/or
  3. # modify it under the same terms as Perl itself.
  4. package Tk::Menubar;
  5. require Tk::Frame;
  6. require Tk::Menubutton;
  7. @ISA = qw(Tk::Frame);
  8. use strict;
  9.  
  10. Construct Tk::Frame 'Menubar';
  11.  
  12. # Just make it a Frame until we figure out what else
  13. # it should do.
  14.  
  15. sub Populate
  16. {
  17.  my ($cw,$args) = @_;
  18.  $cw->SUPER::Populate($args);
  19.  my $parent = $cw->parent;
  20.  my @pack   = (-fill => 'x', -side => 'top', -expand => 0);
  21.  my $before = ($parent->packSlaves)[0];
  22.  unshift(@pack,-before => $before) if (defined $before);
  23.  $parent->Advertise('menubar' => $cw);
  24.  $cw->{'MenuButtons'} = {};
  25.  $cw->pack(@pack);
  26. }
  27.  
  28. sub Menubutton
  29. {
  30.  my ($cw,%args) = @_;
  31.  my $name = $args{'-text'};
  32.  my $items = delete $args{'-menuitems'};
  33.  my %pack = ();
  34.  my $opt;
  35.  foreach $opt (qw(-after -before -side -padx -ipadx -pady -ipady))
  36.   {
  37.    my $val = delete $args{$opt};
  38.    $pack{$opt} = $val if (defined $val);
  39.   }
  40.  if (defined($name) && !defined($args{-underline}))
  41.   {
  42.    my $underline = ($name =~ s/^(.*)~/$1/) ? length($1): undef;
  43.    if (defined($underline) && ($underline >= 0))
  44.     {
  45.      $args{-underline} = $underline;
  46.      $args{-text} = $name;
  47.     }
  48.   }
  49.  $name = lcfirst($name);
  50.  $name =~ s/\s/_/g; 
  51.  my $mb = $cw->{'MenuButtons'}{$name};
  52.  if (defined $mb)
  53.   {
  54.    $mb->configure(%args);
  55.    $mb->pack(%pack) if (%pack);
  56.   }
  57.  else
  58.   {
  59.    $pack{'-side'} = 'left' unless (exists $pack{'-side'});
  60.    $mb = $cw->SUPER::Menubutton(Name => $name,%args); 
  61.    $cw->{'MenuButtons'}{$name} = $mb;
  62.    $mb->pack(%pack);
  63.   }
  64.  $mb->menu->AddItems(@$items) if (defined $items);
  65.  return $mb;
  66. }
  67.  
  68. sub command
  69. {
  70.  my ($cw,%args) = @_;
  71.  my $button = delete $args{-button};
  72.  $button = ['Misc', -underline => 0 ] unless (defined $button);
  73.  my @bargs = ();
  74.  ($button,@bargs) = @$button if (ref($button) && ref $button eq 'ARRAY');
  75.  unless (defined $cw->Subwidget($button))
  76.   {
  77.    $cw->Component('Menubutton' => $button, -text => $button, 
  78.                   '-pack' => [ -side => 'left', -fill => 'y' ], @bargs);
  79.   }
  80.  $cw->Subwidget($button)->command(%args);
  81. }
  82.  
  83. 1;
  84.