summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/Menu
diff options
context:
space:
mode:
authorNorbert Preining <preining@logic.at>2010-05-12 16:54:37 +0000
committerNorbert Preining <preining@logic.at>2010-05-12 16:54:37 +0000
commit661c41a09e39a182865e0b51e34cc995a0dc96e8 (patch)
tree2f79bb1406e22fdcb2587be8ffda6c0c609d7932 /Master/tlpkg/tlperl/lib/Tk/Menu
parentb645030efc22e13c2498a1522083634ab91b2de1 (diff)
move tlperl.straw to tlperl
git-svn-id: svn://tug.org/texlive/trunk@18210 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/Menu')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Tk/Menu/Item.pm178
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Tk/Menu/Item.pod96
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 100755
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 100755
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
+