view release on metacpan or  search on metacpan

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

		$sub = $self->_bind_widget_helper($sub, $tag, $seq);
 
                # Make a subref that will execute the callback, supplying $self as the event source
                my $cbRef = $sub->createTclBindRef($self);

		$self->interp->call($self->bind_path,'bind',$tag,$seq,$cbRef);
	    }
	    else {
		$self->interp->call($self->bind_path,'bind',@_);
	    }
	},
	CanvasBind => sub {
	    my $self = shift;
	    my $item = shift;
	    #$self->SUPER::bind($item,@_); # Not sure why this doesn't work
	    $self->Tcl::pTk::Widget::bind($item,@_); # have to call package explicitly
	},
	CanvasFocus => sub {
	    my $self = shift;
	    $self->Tcl::pTk::Widget::focus(@_); # have to call package explicitly
	},
	focus => sub {
	    my $self = shift;
	    $self->call($self->path,'focus',@_);
	},
        BalloonInfo => sub {  # Sub that enables attaching balloon to items in a canvas
                              #  See balloon.pl demo for example
         my ($canvas,$balloon,$X,$Y,@opt) = @_;
         my @tags = ($canvas->find('withtag', 'current'),$canvas->gettags('current'));
         foreach my $opt (@opt)
          {
           my $info = $balloon->GetOption($opt,$canvas);
           if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'HASH'))
            {
             $balloon->Subclient($tags[0]);
             foreach my $tag (@tags)
              {
               next unless defined($tag);
               return $info->{$tag} if exists $info->{$tag};
              }
             return '';
            }
           return $info;
          }
        }
    );
}

# menu compatibility
sub _process_underline {
    my $self = shift;
    # Suck out "~" which represents the char to underline
    my $args = shift;
    if (defined($args->{'-label'}) && $args->{'-label'} =~ /~/) {
	my $und = index($args->{'-label'}, '~');
	$args->{'-underline'} = $und;
	$args->{'-label'} =~ s/~//;
    }
};
# internal sub helper for menu
sub _addcascade {
    my $mnu = shift;
    my $mnup = $mnu->path;
    my $int = $mnu->interp;

    #print "In Add Cascade mnup = $mnup ";
    
    # Create submenu with predefined naming convention ($mnu.m+1), so we can return it
    #  if the menu method is called on the menu button
    my $entries = $mnu->index('end');
    $entries = -1 if (!defined($entries) or $entries eq 'none');
    $entries++;
    my $smnu = $int->widget($mnu->call('menu',"$mnu.m$entries"), "Tcl::pTk::Menu");
    #my $smnu = $mnu->Menu; # return unique widget id
    
    #print  " smenu = $smnu\n";
    
    my %args = @_;
    #print "Add Cascade args = ".join(", ", %args)."\n";
    my $tearoff = delete $args{'-tearoff'};
    if (defined($tearoff)) {
        $smnu->configure(-tearoff => $tearoff);
    }
    $args{'-menu'} = $smnu;
    my $mis = delete $args{'-menuitems'};
    $mnu->_process_menuitems($int,$smnu,$mis);
    $mnu->_process_underline(\%args);
    #$int->call("$mnu",'add','cascade', %args);
    $mnu->Cascade(%args);
}
# internal helper sub to process perlTk's -menuitems option
sub _process_menuitems {
    my $self = shift;
    my ($int,$mnu,$mis) = @_;
    for (@$mis) {
	if (ref) {
	    my $label = $_->[1];
	    my %a = @$_[2..$#$_];
	    $a{'-state'} = delete $a{state} if exists $a{state};
	    $a{'-label'} = $label;
	    my $cmd = lc($_->[0]);
	    if ($cmd eq 'separator') {$int->invoke($mnu->path,'add','separator');}
	    elsif ($cmd eq 'cascade') {
		$mnu->_process_underline(\%a);
	        $mnu->_addcascade(%a);
	    }
	    else {
		$cmd=~s/^button$/command/;
		$mnu->_process_underline(\%a);
                 #print "calling Call ".$mnu->path." add command ".join(", ", %a)."\n";

	        $mnu->call($mnu->path,'add',$cmd, %a);
	    }
	}
	else {
	    if ($_ eq '-' or $_ eq '') {
		$int->invoke($mnu->path,'add','separator');
	    }
	    else {
		die "in menubutton: '$_' not implemented";
	    }
	}
    }
}


sub NoteBook {
    my $self = shift; # this will be a parent widget for newer notebook
    my $int = $self->interp;
    my $w    = w_uniq($self, "nb"); # return unique widget id
    $int->pkg_require('Tix');
    my %args = @_;
    delete $args{'-tabpady'};
    delete $args{'-inactivebackground'};
    create_widget_package('NoteBook');
    my $bw = $int->declare_widget($self->call('tixNoteBook', $w, %args), "Tcl::pTk::NoteBook");
    create_method_in_widget_package('NoteBook',
	add=>sub {
	    my $bw = shift;
	    my $int = $bw->interp;
	    my $wp = $bw->call($bw,'add',@_);
	    my $ww = $int->declare_widget($wp);
	    return $ww;
	},
	raise=>sub {
	    my $bw = shift;
	    my $int = $bw->interp;
	    return $bw->call($bw,'raise',@_);
	},
    );
    return $bw;
}



# ----------------------------------------------------------------------------
#   Scrolled implementation.
#      This is copied from Tk::Widget.pm
sub Scrolled
{
 my ($parent,$kind,%args) = @_;
 $kind = 'Pane' if $kind eq 'Frame';
 # Find args that are Frame create time args
 my @args = $parent->CreateArgs($parent,\%args);
 my $name = delete $args{'Name'};