view release on metacpan or  search on metacpan

MDI/Menu.pm  view on Meta::CPAN

package Tk::MDI::Menu;

use strict;

my %_fixedMenuEntries = (
			 'Tile Horizontally' => [\&_tile, 'h'],
			 'Tile Vertically'   => [\&_tile, 'v'],
			 'Cascade',	  => [\&_cascade],
			 'Minimize All',	 => [\&_minimizeAll],
			 'Restore All',	  => [\&_restoreAll],
			);

sub new {
	my $self  = shift;
	my $class = ref($self) || $self;

	my $obj = bless {} => $class;

	my %args = @_;
	$obj->{PARENT}	= $args{-parent};
	$obj->{PARENTOBJ} = $args{-parentobj};
	$obj->{MW}	= $args{-mw};
	$obj->{MENUTYPE}  = $args{-type};

	$obj->_createMenuBar;

	return $obj;
}

# possible values for -type are:
# none	- no menus
# popup   - menu accessible only through right mouse button.
# menubar - menu accessible only through menu bar.
# both	- menu accessible through both menu bar and right mouse button.
# menu obj ref - use this menu object as the menu.
#
# PS. I don't like the way I coded this! But it works!

sub _createMenuBar {
	my $obj = shift;

	return if $obj->{MENUTYPE} eq 'none';

	my $popup = my $menubar = 0;

	if (ref $obj->{MENUTYPE}) {
		$obj->{MENU} = $obj->{MENUTYPE};
	} elsif ($obj->{MENUTYPE} eq 'popup') {
		$popup = 1;
	} elsif ($obj->{MENUTYPE} eq 'menubar') {
		$menubar = 1;
	} else {
		$popup = $menubar = 1;
	}

	if ($menubar) {
		if (defined (my $menu = $obj->{MW}->cget('-menu'))) {
			$obj->{MENU} = $menu;
		} else {
			$obj->{MENU} = $obj->{MW}->Menu(qw/-type menubar/);
			$obj->{MW}->configure(-menu => $obj->{MENU});
		}
	}

	if ($popup && !$menubar) {
		$obj->{MENU} = $obj->{MW}->Menu;
	}

	$obj->_populateMenuBar;

	if ($popup) {
		$obj->{PARENTOBJ}->_bindToMenu($obj->{CASCADEMENU});
	}
}

sub _populateMenuBar {
	my $obj = shift;