package Tk::MenuHash;
=head1 NAME
Tk::MenuHash - Ties a Tk::Menubutton widget to a hash object thingy
=head1 SYNOPSIS
use Tk::MenuHash;
my $MB = new Tk::MenuHash ($Menubutton);
my $MB = new Tk::MenuHash (
$MW->Menubutton (
-relief => 'raised',
-text => 'Pick something',
-underline => 0,
)->pack (
-side => 'left',
)
);
$MB->{'Some list item label'} = [ \&CommandFunction, 'args' ];
$MB->{'Some other label'} = \&CommandFunction;
$MB->{'Some lable name'} = 'default';
delete $MB->{'Some other label'};
$MB->configure ( -text => 'Pick something else' );
my $menuText = $MB->{"Anything, it doesn't matter"};
##############################################################
## Or you can do it this way, but it needs two vars so I don't
## recommend it...
tie my %MB, 'Tk::MenuHash', $Menubutton;
## Or...
tie my %MB, 'Tk::MenuHash', $MW->Menubutton (
-relief => 'raised',
-text => 'Pick something',
-underline => 0,
)->pack (
-side => 'left',
);
$MB{'Some list item label'} = [ \&CommandFunction, 'args' ];
$MB{'Some other label'} = \&CommandFunction;
$MB{'Some lable name'} = 'default';
delete $MB{'Some other label'};
$Menubutton->configure ( -text => 'Pick something else' );
my $menuText = $MB{"Anything, it doesn't matter"};
=cut
use strict;
use vars qw($VERSION @ISA $AUTOLOAD);
use Carp;
use Tk;
($VERSION) = '$Revision: 1.12 $' =~ /\$Revision:\s+([^\s]+)/;
sub new {
my $class = shift;
$class = ref ($class) || $class;
my $self = {};
tie %{ $self }, $class, @_;
return bless $self, $class;
}
sub TIEHASH {
my $class = shift;
$class = ref ($class) || $class;
my $self = {};
$self->{Menubutton} = shift
or confess "Invalid usage: no menubutton given";
## Don't use these "features", yet...
$self->{items} = shift || {};
my $default = shift || 'default';
bless $self, $class;
## Incase we already have stuff in our hash:
foreach my $label (sort { lc $a cmp lc $b } keys %{ $self->{items} }) {
$self->STORE ($label, $default);
}
return $self;
}
sub STORE {
my $self = shift;
my $label = shift;
my $subRef = shift;
## Default is just to select the current label
if (not ref $subRef) {
if ($subRef =~ /^default$/i) {
my $menu = $self->{Menubutton};
$subRef = sub { $menu->configure (-text => $label) };
} else {
confess qq(Non reference given as a command function);
}
}
## No dup items are allowed in this type of class,
## so nuke and replace. Harmless if we don't have it yet.
$self->DELETE ($label);
$self->{items}{$label} = $subRef;
return $self->{Menubutton}->command (
-label => $label,
-command => $subRef,
);
}
sub DELETE {
my $self = shift;
my $label = shift;
return unless (exists $self->{items}{$label});
delete $self->{items}{$label};
my $menu = $self->{Menubutton}->cget (-menu);
$menu->delete ($label);
}
sub FETCH {
my $self = shift;
return $self->{Menubutton}->cget (-text);
}
sub EXISTS {
my $self = shift;
my $label = shift;
return 1 if (exists $self->{items}{$label});
return;
}
sub CLEAR {
my $self = shift;
foreach my $label (keys %{ $self->{items} }) {
$self->DELETE ($label);
}
return 1;
}
sub FIRSTKEY {
my $self = shift;
my $a = scalar keys %{ $self->{items} };
return each %{ $self->{items} };
}
sub NEXTKEY {
my $self = shift;
return each %{ $self->{items} };
}
sub DESTROY {
my $self = shift;
delete $self->{Menubutton};
}
sub AUTOLOAD {
## Redirect all unknown methods to the Menubutton
my $self = shift;
return if $AUTOLOAD =~ /::DESTROY$/;
$AUTOLOAD =~ s/^.*:://g;
$self = tied %{ $self };
$self->{Menubutton}->$AUTOLOAD (@_);
}
1;
__END__
=head1 DESCRIPTION
Creates a tied B<Tk::Menubutton> widget hash reference object kinda
thingy....
It's actually much simplier then it sounds, at least to use. It walks
and talks half like an object, and half like a (tied) hash reference. This
is because it's both in one (it's a blessed reference to a tied hash of the
same class).
=over 4
=item B<WARNING>:
This is *not* a valid Tk widget as you would normally think of it. You can
B<not> (currently) call it as
my $menuHash = $MW->MenuHash(); ## Don't try this (yet)!
The B<2.x> release will be a true widget and thus walk and talk currently as
such. As much as I will try and maintain this current API for future
compatibility, this may not be entire possible. The B<2.x> release will
solidify this widget's API, but until then consider this API in a state of
flux. Thanks
=back
When you add a key (label) to the hash it added it to the menubutton. The
value assigned must be either a valid B<Tk::Menubutton> B<-command> option,
or the string B<'default'> (case is not important). The B<default> is
simply a function that configure()s the Menubuttons B<-text> to that
of the selected label. You can then retrieve the text by just reading
a key (any key, even if it doesn't exist, it doesn't matter) from the hash.
The new() method passes back a reference to a tie()d MenuHash,
but with all the properties (and methods) of the Menubutton you passed it.
With this type you can set and delete fields as hash keys references:
$MenuHash->{'Some label'} = 'default';
But also call Tk::Menubutton (or sub-classes of it, if that's what you passed
the constructor) methods:
$MenuHash->configure ( -text => 'Pick something' );
This involves B<black magic> to do, but it works. See the B<AUTOLOAD> method
code if you have a morbid interest in this, however it's more that we are
dealing with 3 objects in 2 classes.
I prefer this useage myself as it meens I only need to carry around one var
that walks and talks almost exactly like a "real" B<Tk::Menubutton> (that
is, you can call any valid Tk::Menubutton method off it directly), but
with the added (and B<much> needed IMHO) feature of being able to easily
add, delete, select, and read menu options as simple hash ref keys.
=head1 EXAMPLE
use Tk;
use Tk::MenuHash;
my $MW = new MainWindow;
my $menu = new Tk::MenuHash ($MW->Menubutton (
-relief => 'raised',
-text => 'Pick something',
-underline => 0,
)->pack (
-side => 'left',
));
$menu->{'Option one (default)'} = 'default';
$menu->{'Option two (print "two")'} = sub { print "two\n" };
$menu->{'Option three (exit)'} = sub { $MW->destroy };
$menu->{'Option four (print current text)'} = sub { print "$menu->{foobar}\n" };
MainLoop;
=head1 AUTHOR
Zenin <zenin@bawdycaste.com>
aka Byron Brummer <byron@omix.com>
=head1 COPYRIGHT
Copyright (c) 1998, 1999 OMIX, Inc.
Available for use under the same terms as perl.
=cut