view release on metacpan or  search on metacpan

lib/Games/Pandemic/Tk/Main.pm  view on Meta::CPAN

    # prettyfying tk app.
    # see http://www.perltk.org/index.php?option=com_content&task=view&id=43&Itemid=37
    $mw->optionAdd('*BorderWidth' => 1);

    # set windowtitle
    $mw->title(T('Pandemic'));
    $mw->iconimage( pandemic_icon() );

    # make sure window is big enough
    my $config = Games::Pandemic::Config->instance;
    my $width  = $config->get( 'win_width' );
    my $height = $config->get( 'win_height' );
    $mw->geometry($width . 'x' . $height);

    # create the actions
    my @enabled  = qw{ new load quit };
    my @disabled = (
        qw{ close continue show_cards },
        map { "action_$_" } qw{ build discover drop pass share treat },
    );
    foreach my $what ( @enabled, @disabled ) {
        my $action = Tk::Action->new(
            window   => $mw,
            callback => $s->postback("_$what"),
        );
        $self->_set_action($what, $action);
    }
    # allow some actions
    $self->_action($_)->enable  for @enabled;
    $self->_action($_)->disable for @disabled;

    # the tooltip
    $self->_set_w('tooltip', $mw->Balloon);

    # WARNING: we need to create the toolbar object before anything
    # else. indeed, tk::toolbar loads the embedded icons in classinit,
    # that is when the first object of the class is created - and not
    # during compile time.
    $self->_build_toolbar;
    $self->_build_menubar;
    $self->_build_canvas;

    # center & show the window
    # FIXME: restore last position saved?
    $mw->Popup;
}


#
# $self->_build_menu( $mnuname, $mnulabel, @submenus );
#
# Create the menu $label, with all the @submenus.
# @submenus is a list of [$name, $icon, $accel, $label] items.
# Store the menu items under the name menu_$mnuname_$name.
#
sub _build_menu {
    my ($self, $mnuname, $mnulabel, @submenus) = @_;
    my $menubar = $self->_w('menubar');
    my $s = $self->_session;

    my $menu = $menubar->cascade(-label => $mnulabel);
    foreach my $item ( @submenus ) {
        my ($name, $icon, $accel, $label) = @$item;

        # separators are easier
        if ( $name eq '---' ) {
            $menu->separator;
            next;
        }

        # regular buttons
        my $action = $self->_action($name);
        my $widget = $menu->command(
            -label       => $label,
            -image       => $icon,
            -compound    => 'left',
            -accelerator => $accel,
            -command     => $action->callback,
        );
        $self->_set_w("menu_${mnuname}_${name}", $widget);

        # create the bindings. note: we also need to bind the lowercase
        # letter too!
        $action->add_widget($widget);
        $accel =~ s/Ctrl\+/Control-/;
        $action->add_binding("<$accel>");
        $accel =~ s/Control-(\w)/"Control-" . lc($1)/e;
        $action->add_binding("<$accel>");
    }
}


#
# $main->_build_menubar;
#
# create the window's menu.
#
sub _build_menubar {
    my $self = shift;
    my $s = $self->_session;

    # no tear-off menus
    $mw->optionAdd('*tearOff', 'false');

    #$h->{w}{mnu_run} = $menubar->entrycget(1, '-menu');

    my $menubar = $mw->Menu;
    $mw->configure(-menu => $menubar );
    $self->_set_w('menubar', $menubar);

    # menu game
    my @mnu_game = (
    [ 'new',   'filenew16',   'Ctrl+N', T('~New game')   ],
    [ 'load',  'fileopen16',  'Ctrl+O', T('~Load game')  ],
    [ 'close', 'fileclose16', 'Ctrl+W', T('~Close game') ],
    [ '---'                                              ],
    [ 'quit',  'actexit16',   'Ctrl+Q', T('~Quit')       ],
    );
    $self->_build_menu('game', T('~Game'), @mnu_game);

    # menu view