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