#!perl -w
=head1 NAME
=for :Dox @package - Simple menu builder for Perl Tk
=cut
package Menu::Builder;
$VERSION = '0.007';
=head1 SYNOPSIS
use Tk;
use Tk::Menu;
use Menu::Builder;
my $checkbox;
my $menuCfg = [
File => [
New => \&FileNew,
Save => \&FileSave,
Exit => \&FileExit,
],
Options => [
Fancy => { -type => 'checkbutton', -variable => \$checkbox },
],
Help => [
Help => \&HelpHelp,
About => \&HelpAbout,
],
];
my $mw = MainWindow->new(-title => 'Menu Builder Test');
my $menuBar = $mw->Menu(-tearoff => 0);
$mw->configure(-menu => $menuBar);
Menu::Builder::BuildMenu($menuBar, $menuCfg);
=head1 DESCRIPTION
This is a tool for quickly and easily building multi-level Menu Systems,
such as, but not limited to, a menubar. The main focus is commands and
cascades. Other menu entry types are also supported.
(Although -menuitems, in Tk::Menu:Item, provides similar functionality,
building cascade menus can get very complicated. This tool simplifies
that, as well as simple commands, while providing means to describe other
menu item types and full options for commands.)
=head2 Defining Menu Systems
A Menu System is defined, to this tool, by an array ref. The referenced
array is a an ordered set of name/value pairs. (Since hashes are unordered,
they do not work for this.) Each pair is taken as an entry name and content.
If the content specifier is a code ref, a commend entry is created with
the specified name and code ref.
If the content specifier is an array ref, a cascade is created with the
specified name and the array is processed into the associated submenu.
Cascades may be nested to an arbitrary width and depth, limited only by
the resources available.
If the content specifier is a hash ref whose hash contains at least a
-type key/value pair, a menu item of the specified name and type is
created, via the add method of Tk::Menu, using the remaining pairs in the
hash as options.
=cut
use warnings;
use strict;
use Tk;
use Tk::Menu;
use Carp;
our @stack = ();
our $parent;
=head2 Functions
=for :Dox Create the widget tree for the menu.
=cut
sub BuildMenu
{
## @params
my ($menu, #< Reference of Tk::Menu widget in which to build the menu.
$desc #< Reference of array containing menu description.
) = @_;
## @endparams
$parent = $_[0];
_build($_[1]);
}
sub _build
{
my $r = $_[0];
return unless (ref($r) eq 'ARRAY');
my $name = undef;
for (@$r)
{
if (defined $name)
{
if (ref eq 'ARRAY')
{
my $c = $parent->cascade(-label => $name);
my $m = $parent->Menu(-tearoff=>0);
$c->configure(-menu=>$m);
push @stack, $parent;
$parent = $m;
_build($_);
$parent = pop @stack;
}
elsif (ref eq 'CODE')
{
$parent->command(-label => $name, -command => $_);
}
elsif (ref eq 'HASH')
{
my $t = delete($_->{-type});
unless (defined $t)
{
carp "Menu parse error: Missing -type for $name\n";
return;
}
$parent->add($t, -label => $name, %$_);
}
else
{
carp "Menu parse error: Missing ARRAY, CODE or HASH ref. for $name\n";
return;
}
$name = undef;
}
else
{
if (ref ne '')
{
carp "Menu parse error: Ref where name expected.\n";
return;
}
unless (/\w+/)
{
carp "Menu parse error: empty item name.\n";
return;
}
$name = $_;
}
}
}
1;
=head1 CAVEATS
This module is a tool, not a new widget. You supply it with a reference to
the menu widget to be populated. Additional menu widgets are created as
needed.
=head1 SEE ALSO
C<Tk::Menu>, C<Tk::Menu:Item>
=head1 AUTHOR
RonW of perlmonks.org
=head1 COPYRIGHT
Copyright 2013, RonW of perlmonks.org. All rights reserved.
=head1 LICENSE
This tool is open source software. You may redistribute it and/or modify
it under the same terms as Perl itself.
=cut
__END__
package main;
use Tk;
use Tk::Menu;
use Menu::Builder;
my $checkbox;
my $menuCfg = [
File => [
New => \&FileNew,
Save => \&FileSave,
Exit => \&FileExit,
],
Options => [
Fancy => { -type => 'checkbutton', -variable => \$checkbox },
],
Help => [
Help => \&HelpHelp,
About => \&HelpAbout,
],
];
my $mw = MainWindow->new(-title => 'Menu Builder Test');
my $menuBar = $mw->Menu(-tearoff => 0);
$mw->configure(-menu => $menuBar);
Menu::Builder::BuildMenu($menuBar, $menuCfg);
MainLoop;
sub FileNew {}
sub FileSave {}
sub FileExit { Tk::exit; }
sub HelpHelp {}
sub HelpAbout {}