$VERSION = '3.027'; # $Id: //depot/Tk8/Tk/Menu/Item.pm#27 $
my ($class,$menu,$minfo) = @_;
my ($class,$menu,%minfo) = @_;
my $name = $minfo{'-label'};
my $invoke = delete $minfo{'-invoke'};
# 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;
$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);
return bless [$menu,$name],$class;
my ($menu,$name) = @$obj;
$obj->[1] = $args{'-label'} if exists $args{'-label'};
$menu->entryconfigure($name,@_);
my ($menu,$name) = @$obj;
$menu->entrycget($name,@_);
# 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' }
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;
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));
my $w = $self->parentMenu;
my $menu = $self->cget('-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);
$menu->configure(%args) if %args;
# 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(@_); }
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' }