I'm not sure I understand your code, but it looks like you are directly modifying the Optionmenu widget code. This approach is best avoided. What you should be doing is subclassing the Optionmenu. I've attached my complete SepOptionmenu class file for you to see how I did it. The advantages of subclassing are many, but the biggest is that you won't have scripts mysteriously breaking when Optionmenu gets upgraded.
As far as adding options to an existing widget, I would modify addOptions to handle some sort of nested data structure. Perhaps where each element in the list is a menu item, vanilla items (that just set a value) could be plain text strings, while other times would be an array ref of (type, label, data). Type could be 'command' or 'cascade'. If type is command, the data item would be a callback. If cascade data would be another item list like the one being parsed.
$menuItems = [
'foo',
'bar',
[ 'command', 'baz', [ \&BazRoutine, $bazarg0, $bazarg1 ] ],
[ 'cascade', 'qux', [
'huzzah',
'fizzle',
[ 'command', 'bagel', \&BagelRoutine ],
],
'frank',
];
As for accessing information about the menu itself, you can use the $om->menu method to get access to the Tk::Menu widget. Once you have the menu widget, you can use the index method to find out about what items are in the menu.
You may want to add additional methods to your subclass that support particular tasks, like adding or removing cascaded items to a particular index.
Finally, here's the subclassing example. If you aren't familiar with subclassing and inheritance, check out perlboot and perltoot. This code is licensed under the same terms as perl.
package Tk::SepOptionmenu;
use base ('Tk::Optionmenu', 'Tk::Derived');
use strict;
use warnings;
use Carp;
our $VERSION = '1.0';
Construct Tk::Widget 'SepOptionmenu';
sub ClassInit {
my ($class, $mw) = @_;
$class->SUPER::ClassInit($mw);
}
sub addOptions
{
my $w = shift;
my $menu = $w->menu;
my $tvar = $w->cget(-textvariable);
my $vvar = $w->cget(-variable);
my $oldt = $$tvar;
my $width = $w->cget('-width');
my %hash;
my $first;
while (@_)
{
my $val = shift;
my $label = $val;
if (ref $val)
{
if ($vvar == $tvar)
{
my $new = $label;
$w->configure(-textvariable => ($tvar = \$new));
}
($label, $val) = @$val;
}
my $len = length($label);
$width = $len if (!defined($width) || $len > $width);
if ( $label eq '-') {
$menu->separator();
} else {
$menu->command(-label => $label, -command => [ $w , 'setOption'
+, $label, $val ]);
}
$hash{$label} = $val;
$first = $label unless defined $first;
}
if (!defined($oldt) || !exists($hash{$oldt}))
{
$w->setOption($first, $hash{$first}) if defined $first;
}
$w->configure('-width' => $width);
}
1;
__END__
=pod
=head1 NAME
Tk::SepOptionmenu - A perl/tk Optionmenu widget that can include separ
+ators.
=head1 SYNOPSIS
use Optionmenu;
$sopt = $w->Optionmenu(
-options => REFERENCE_to_OPTIONLIST,
-command => CALLBACK,
-variable => SCALAR_REF,
);
$sopt->addOptions( OPTIONLIST );
# OPTION LIST is
# a) $val1, $val2, $val3,...
# b) [ $lab1=>$val1], [$lab2=>val2], ... ]
# c) combination of a) and b), e.g.,
# val1, [$lab2=>val2], val3, val4, [...], ...
#
# In a), any value may be '-' to indicate a separator.
# If using b) style option list, you must still specify
# separators as follows: [ [$lab1=>$val1], '-', [$lab2=>$val2],
+... ];
=head1 DESCRIPTION
This "I<IS A>" Optionmenu widget that can include separator menu items
+ in its menu.
=head1 METHODS
=over 4
=item addOptions
Adds OPTION_LIST to the already available options. OPTION_LIST may inc
+lude an item C<'-'> to indicate a separator.
=back
=head1 EXAMPLE
use Tk;
my $mw = MainWindow->new();
my ($var, $tvar);
my $opt = $mw->SepOptionmenu(
-options => [[jan=>1], [feb=>2], '-', [mar=>3], [apr=>4]],
-command => sub { print "got: ", shift, "\n" },
-variable => \$var,
-textvariable => \$tvar
)->pack;
$opt->addOptions('-',[may=>5],[jun=>6],'-',[jul=>7],[aug=>8]);
my $f = $mw->Frame(-relief=>'groove', -borderwidth => 2)->pack;
$f->Label(-textvariable=>\$tvar)->pack(-side => 'left');
$f->Label(-text => " -> ")->pack(-side => 'left');
$f->Label(-textvariable=>\$var)->pack(-side => 'left');
$mw->Button(-text=>'Exit', -command=>sub{$mw->destroy})->pack;
MainLoop;
=head1 SEE ALSO
L<Tk::Optionmenu>
=cut
|