diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/Menu')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm | 178 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/Menu/Item.pod | 96 |
2 files changed, 274 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm b/Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm new file mode 100644 index 00000000000..167715f9382 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm @@ -0,0 +1,178 @@ +package Tk::Menu::Item; + +require Tk::Menu; + +use Carp; +use strict; + +use vars qw($VERSION); +$VERSION = '4.005'; # $Id: //depot/Tkutf8/Tk/Menu/Item.pm#4 $ + +sub PreInit +{ + # Dummy (virtual) method + my ($class,$menu,$minfo) = @_; +} + +sub new +{ + my ($class,$menu,%minfo) = @_; + my $kind = $class->kind; + my $name = $minfo{'-label'}; + if (defined $kind) + { + my $invoke = delete $minfo{'-invoke'}; + if (defined $name) + { + # Use ~ in name/label to set -underline + if (defined($minfo{-label}) && !defined($minfo{-underline})) + { + my $cleanlabel = $minfo{-label}; + my $underline = ($cleanlabel =~ s/^(.*)~/$1/) ? length($1): undef; + if (defined($underline) && ($underline >= 0)) + { + $minfo{-underline} = $underline; + $name = $cleanlabel if ($minfo{-label} eq $name); + $minfo{-label} = $cleanlabel; + } + } + } + else + { + $name = $minfo{'-bitmap'} || $minfo{'-image'}; + croak('No -label') unless defined($name); + $minfo{'-label'} = $name; + } + $class->PreInit($menu,\%minfo); + $menu->add($kind,%minfo); + $menu->invoke('last') if ($invoke); + } + else + { + $menu->add('separator'); + } + return bless [$menu,$name],$class; +} + +sub configure +{ + my $obj = shift; + my ($menu,$name) = @$obj; + my %args = @_; + $obj->[1] = $args{'-label'} if exists $args{'-label'}; + $menu->entryconfigure($name,@_); +} + +sub cget +{ + my $obj = shift; + my ($menu,$name) = @$obj; + $menu->entrycget($name,@_); +} + +sub parentMenu +{ + my $obj = shift; + return $obj->[0]; +} + +# Default "kind" is a command +sub kind { return 'command' } + +# Now the derived packages + +package Tk::Menu::Separator; +use base qw(Tk::Menu::Item); +Construct Tk::Menu 'Separator'; +sub kind { return undef } + +package Tk::Menu::Button; +use base qw(Tk::Menu::Item); +Construct Tk::Menu 'Button'; +Construct Tk::Menu 'Command'; + +#package Tk::Menu::Command; +#use base qw(Tk::Menu::Button); +#Construct Tk::Menu 'Command'; + +package Tk::Menu::Cascade; +use base qw(Tk::Menu::Item); +Construct Tk::Menu 'Cascade'; +sub kind { return 'cascade' } +use Carp; + +sub PreInit +{ + my ($class,$menu,$minfo) = @_; + my $tearoff = delete $minfo->{-tearoff}; + my $items = delete $minfo->{-menuitems}; + my $widgetvar = delete $minfo->{-menuvar}; + my $command = delete $minfo->{-postcommand}; + my $name = delete $minfo->{'Name'}; + $name = $minfo->{'-label'} unless defined $name; + my @args = (); + push(@args, '-tearoff' => $tearoff) if (defined $tearoff); + push(@args, '-menuitems' => $items) if (defined $items); + push(@args, '-postcommand' => $command) if (defined $command); + my $submenu = $minfo->{'-menu'}; + unless (defined $submenu) + { + $minfo->{'-menu'} = $submenu = $menu->Menu(Name => $name, @args); + } + $$widgetvar = $submenu if (defined($widgetvar) && ref($widgetvar)); +} + +sub menu +{ + my ($self,%args) = @_; + my $w = $self->parentMenu; + my $menu = $self->cget('-menu'); + if (!defined $menu) + { + require Tk::Menu; + $w->ColorOptions(\%args); + my $name = $self->cget('-label'); + warn "Had to (re-)reate menu for $name"; + $menu = $w->Menu(Name => $name, %args); + $self->configure('-menu'=>$menu); + } + else + { + $menu->configure(%args) if %args; + } + return $menu; +} + +# Some convenience methods + +sub separator { shift->menu->Separator(@_); } +sub command { shift->menu->Command(@_); } +sub cascade { shift->menu->Cascade(@_); } +sub checkbutton { shift->menu->Checkbutton(@_); } +sub radiobutton { shift->menu->Radiobutton(@_); } + +sub pack +{ + my $w = shift; + if ($^W) + { + require Carp; + Carp::carp("Cannot 'pack' $w - done automatically") + } +} + +package Tk::Menu::Checkbutton; +use base qw(Tk::Menu::Item); +Construct Tk::Menu 'Checkbutton'; +sub kind { return 'checkbutton' } + +package Tk::Menu::Radiobutton; +use base qw(Tk::Menu::Item); +Construct Tk::Menu 'Radiobutton'; +sub kind { return 'radiobutton' } + +package Tk::Menu::Item; + +1; +__END__ + diff --git a/Master/tlpkg/tlperl/lib/Tk/Menu/Item.pod b/Master/tlpkg/tlperl/lib/Tk/Menu/Item.pod new file mode 100644 index 00000000000..dabaadb8a58 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Menu/Item.pod @@ -0,0 +1,96 @@ + +=head1 NAME + +Tk::Menu::Item - Base class for Menu items + +=for pm Tk/Menu/Item.pm + +=for category Implementation + +=head1 SYNOPSIS + + require Tk::Menu::Item; + + my $but = $menu->Button(...); + $but->configure(...); + my $what = $but->cget(); + + package Whatever; + require Tk::Menu::Item; + @ISA = qw(Tk::Menu::Item); + + sub PreInit + { + my ($class,$menu,$info) = @_; + $info->{'-xxxxx'} = ... + my $y = delete $info->{'-yyyy'}; + } + +=head1 DESCRIPTION + +Tk::Menu::Item is the base class from which Tk::Menu::Button, +Tk::Menu::Cascade, Tk::Menu::Radiobutton and Tk::Menu::Checkbutton are derived. +There is also a Tk::Menu::Separator. + +Constructors are declared so that $menu-E<gt>Button(...) etc. do what you would +expect. + +The C<-label> option is pre-processed allowing ~ to be prefixed to the character +to derive a C<-underline> value. Thus + + $menu->Button(-label => 'Goto ~Home',...) + + is equivalent to + + $menu->Button(-label => 'Goto Home', -underline => 6, ...) + +The C<Cascade> menu item creates a sub-menu and accepts +these options: + +=over 4 + +=item B<-menuitems> + +A list of items for the sub-menu. +Within this list (which is also accepted by Menu and Menubutton) the first +two elements of each item should be the "constructor" name and the label: + + -menuitems => [ + [Button => '~Quit', -command => [destroy => $mw]], + [Checkbutton => '~Oil', -variable => \$oil], + ] + +=item B<-postcommand> + +A callback to be invoked before posting the menu. + +=item B<-tearoff> + +Specifies whether sub-menu can be torn-off or not. + +=item B<-menuvar> + +Scalar reference that will be set to the newly-created sub-menu. + +=back + +The returned object is currently a blessed reference to an array of two items: +the containing Menu and the 'label'. +Methods C<configure> and C<cget> are mapped onto underlying C<entryconfigure> +and C<entrycget>. + +The main purpose of the OO interface is to allow derived item classes to +be defined which pre-set the options used to create a more basic item. + +=head1 BUGS + +This OO interface is very new. Using the label as the "key" is a problem +for separaror items which don't have one. The alternative would be to +use an index into the menu but that is a problem if items are deleted +(or inserted other than at the end). + +There should probably be a PostInit entry point too, or a more widget like +defered 'configure'. + +=cut + |