From 61700e8be90ff6f495c0b1a9835fe07e9848de8d Mon Sep 17 00:00:00 2001 From: Reinhard Kotucha Date: Sat, 5 Jan 2008 21:23:03 +0000 Subject: tlperl: Perl for scripts provided by TeX Live. git-svn-id: svn://tug.org/texlive/trunk@6046 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm | 180 ++++++++++++++++++++++++++++++++ 1 file changed, 180 insertions(+) create mode 100644 Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm (limited to 'Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm') 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..403052ef5bd --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm @@ -0,0 +1,180 @@ +package Tk::Menu::Item; + +require Tk::Menu; + +use Carp; +use strict; + +use vars qw($VERSION); +$VERSION = '4.004'; # $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__ + +=cut + -- cgit v1.2.3