view release on metacpan or  search on metacpan

lib/Tcl/pTk/Menu.pm  view on Meta::CPAN

package Tcl::pTk::Menu;

our ($VERSION) = ('1.11');

# Simple Menu package.
#  This file is needed to provide the proper inheritance of Menu to 
#   the Wm, Derived and widget packages
#

use base qw(Tcl::pTk::Wm Tcl::pTk::Derived Tcl::pTk::Widget);

use Tcl::pTk::Widget();
use Tcl::pTk::Wm();
use Tcl::pTk::Derived();
use Tcl::pTk::Menubutton;
use Tcl::pTk::Menu::Item;


Tcl::pTk::Widget->Construct('Menu');

sub CreateArgs{
        my $package = shift;
        my $parent  = shift;
        my $args    = shift;
        
        # Turn -tearoff => '' to -tearoff => 0. (Tcl needs a boolean value for this,
        #   not a empty string
        
        if( exists($args->{-tearoff}) && !($args->{-tearoff}) ){
                $args->{-tearoff} = 0;
        }
        return $package->SUPER::CreateArgs($parent, $args);
}


sub InitObject
{
 my ($menu,$args) = @_;
 my $menuitems = delete $args->{-menuitems};
 $menu->SUPER::InitObject($args);
 if (defined $menuitems)
  {
   # If any other args do configure now
   if (%$args)
    {
     $menu->configure(%$args);
     %$args = ();
    }
    # Process menu items using the internal widget method
    my $int = $menu->interp;
    $menu->_process_menuitems($int,$menu,$menuitems);

  }
}

# Create widget packages and methods for Menu
Tcl::pTk::Widget::create_widget_package('Menu');
Tcl::pTk::Widget::create_method_in_widget_package('Menu',
        command => sub {
            my $wid = shift;
            my %args = @_;
            
            # Convert -bg and -fg abbreviations to -background and -foreground
            #   These abbreviations are valid in perl/tk, but not in Tcl/tk, so we have to
            #  translate
            $args{-foreground} = delete($args{-fg}) if( defined($args{-fg}));
            $args{-background} = delete($args{-bg}) if( defined($args{-bg}));
            
            $wid->_process_underline(\%args);
            $wid->menu->Command(%args);
        },
        checkbutton => sub {
            shift->Checkbutton(@_);
        },