summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm180
1 files changed, 0 insertions, 180 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm b/Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm
deleted file mode 100644
index 403052ef5bd..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/Menu/Item.pm
+++ /dev/null
@@ -1,180 +0,0 @@
-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
-