view release on metacpan or  search on metacpan

MDI/Menu.pm.prePOD  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;