1package Tk::Menu::Item; 2 3require Tk::Menu; 4 5use Carp; 6use strict; 7 8use vars qw($VERSION); 9$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Menu/Item.pm#4 $ 10 11sub PreInit 12{ 13 # Dummy (virtual) method 14 my ($class,$menu,$minfo) = @_; 15} 16 17sub new 18{ 19 my ($class,$menu,%minfo) = @_; 20 my $kind = $class->kind; 21 my $name = $minfo{'-label'}; 22 if (defined $kind) 23 { 24 my $invoke = delete $minfo{'-invoke'}; 25 if (defined $name) 26 { 27 # Use ~ in name/label to set -underline 28 if (defined($minfo{-label}) && !defined($minfo{-underline})) 29 { 30 my $cleanlabel = $minfo{-label}; 31 my $underline = ($cleanlabel =~ s/^(.*)~/$1/) ? length($1): undef; 32 if (defined($underline) && ($underline >= 0)) 33 { 34 $minfo{-underline} = $underline; 35 $name = $cleanlabel if ($minfo{-label} eq $name); 36 $minfo{-label} = $cleanlabel; 37 } 38 } 39 } 40 else 41 { 42 $name = $minfo{'-bitmap'} || $minfo{'-image'}; 43 croak('No -label') unless defined($name); 44 $minfo{'-label'} = $name; 45 } 46 $class->PreInit($menu,\%minfo); 47 $menu->add($kind,%minfo); 48 $menu->invoke('last') if ($invoke); 49 } 50 else 51 { 52 $menu->add('separator'); 53 } 54 return bless [$menu,$name],$class; 55} 56 57sub configure 58{ 59 my $obj = shift; 60 my ($menu,$name) = @$obj; 61 my %args = @_; 62 $obj->[1] = $args{'-label'} if exists $args{'-label'}; 63 $menu->entryconfigure($name,@_); 64} 65 66sub cget 67{ 68 my $obj = shift; 69 my ($menu,$name) = @$obj; 70 $menu->entrycget($name,@_); 71} 72 73sub parentMenu 74{ 75 my $obj = shift; 76 return $obj->[0]; 77} 78 79# Default "kind" is a command 80sub kind { return 'command' } 81 82# Now the derived packages 83 84package Tk::Menu::Separator; 85use base qw(Tk::Menu::Item); 86Construct Tk::Menu 'Separator'; 87sub kind { return undef } 88 89package Tk::Menu::Button; 90use base qw(Tk::Menu::Item); 91Construct Tk::Menu 'Button'; 92Construct Tk::Menu 'Command'; 93 94#package Tk::Menu::Command; 95#use base qw(Tk::Menu::Button); 96#Construct Tk::Menu 'Command'; 97 98package Tk::Menu::Cascade; 99use base qw(Tk::Menu::Item); 100Construct Tk::Menu 'Cascade'; 101sub kind { return 'cascade' } 102use Carp; 103 104sub PreInit 105{ 106 my ($class,$menu,$minfo) = @_; 107 my $tearoff = delete $minfo->{-tearoff}; 108 my $items = delete $minfo->{-menuitems}; 109 my $widgetvar = delete $minfo->{-menuvar}; 110 my $command = delete $minfo->{-postcommand}; 111 my $name = delete $minfo->{'Name'}; 112 $name = $minfo->{'-label'} unless defined $name; 113 my @args = (); 114 push(@args, '-tearoff' => $tearoff) if (defined $tearoff); 115 push(@args, '-menuitems' => $items) if (defined $items); 116 push(@args, '-postcommand' => $command) if (defined $command); 117 my $submenu = $minfo->{'-menu'}; 118 unless (defined $submenu) 119 { 120 $minfo->{'-menu'} = $submenu = $menu->Menu(Name => $name, @args); 121 } 122 $$widgetvar = $submenu if (defined($widgetvar) && ref($widgetvar)); 123} 124 125sub menu 126{ 127 my ($self,%args) = @_; 128 my $w = $self->parentMenu; 129 my $menu = $self->cget('-menu'); 130 if (!defined $menu) 131 { 132 require Tk::Menu; 133 $w->ColorOptions(\%args); 134 my $name = $self->cget('-label'); 135 warn "Had to (re-)create menu for $name"; 136 $menu = $w->Menu(Name => $name, %args); 137 $self->configure('-menu'=>$menu); 138 } 139 else 140 { 141 $menu->configure(%args) if %args; 142 } 143 return $menu; 144} 145 146# Some convenience methods 147 148sub separator { shift->menu->Separator(@_); } 149sub command { shift->menu->Command(@_); } 150sub cascade { shift->menu->Cascade(@_); } 151sub checkbutton { shift->menu->Checkbutton(@_); } 152sub radiobutton { shift->menu->Radiobutton(@_); } 153 154sub pack 155{ 156 my $w = shift; 157 if ($^W) 158 { 159 require Carp; 160 Carp::carp("Cannot 'pack' $w - done automatically") 161 } 162} 163 164package Tk::Menu::Checkbutton; 165use base qw(Tk::Menu::Item); 166Construct Tk::Menu 'Checkbutton'; 167sub kind { return 'checkbutton' } 168 169package Tk::Menu::Radiobutton; 170use base qw(Tk::Menu::Item); 171Construct Tk::Menu 'Radiobutton'; 172sub kind { return 'radiobutton' } 173 174package Tk::Menu::Item; 175 1761; 177__END__ 178 179