view release on metacpan or  search on metacpan

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

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(@_);
        },
        radiobutton => sub {
            shift->Radiobutton(@_);
        },
        cascade => sub {
            my $wid = shift;
            $wid->_addcascade(@_);
        },
        separator => sub {
            shift->Separator(@_);
        },
        menu => sub {
            my $wid = shift;
            return $wid->interp->widget("$wid");
        },
        
        entryconfigure => sub {
            my $wid = shift;
            my $label = shift;
            $label =~ s/~//;
            $wid->call("$wid", 'entryconfigure', $label, @_);
        },
);


sub Populate
{
 my ($cw,$arg) = @_;
 $cw->SUPER::Populate($arg);
}

# Method to return the containerName of the widget
#   Any subclasses of this widget can call containerName to get the correct
#   container widget for the subwidget
sub containerName{
        return 'Menu';
}

# Overloaded cget that takes care of -menu option, for compatibility with perl/tk
sub cget {
    my $self = shift;
    my $opt = shift;
    if ($opt eq '-menu') {
        return $self->interp->widget($self);
    }
    return $self->SUPER::cget($opt);
}

# Wrapper for the Menu Widget's entrycget method. 
#  For most cases, this just calls the tcl with the args supplied, but when called with
#  the -menu option, it takes the pathname returned by tcl and turns it into a widget.
#  This is for compatibility with perl/tk
#
sub Tcl::pTk::Menu::entrycget{
        
        my $self = shift;
        
        my $index = shift;
        
        my $option = shift;
        
        my $result = $self->call($self->path, 'entrycget', $index, $option);
        
        # If option -menu, a widget path will be returned,
        #   we need to translate to a actual widget
        if( $option eq '-menu' && $result){
            my $widgets = Tcl::pTk::widgets();