Tcl-pTk
view release on metacpan or search on metacpan
lib/Tcl/pTk/Widget.pm view on Meta::CPAN
## ------------------------------------------------------------------------
## Widget package, responsible for all Tcl/Tk widgets and any other widgets
## Widgets are blessed to this package or to its sub-packages
## such as Tcl:Tk::Widget::Button, which ISA-Tcl::pTk::Widget
##
package Tcl::pTk::Widget;
our ($VERSION) = ('1.11');
use Config;
use IO::Handle;
use Class::ISA; # Used for finding the base class of a derived widget
use Tcl::pTk::Callback;
use Tcl::pTk::MegaWidget;
use Tcl::pTk::Derived;
use Tcl::pTk::Trace;
use Tcl::pTk::Frame;
use Tcl::pTk::HList;
use Tcl::pTk::Text;
use Tcl::pTk::Entry;
use Tcl::pTk::Photo;
use Tcl::pTk::Bitmap;
use Tcl::pTk::XEvent; # Limited XEvent support
use Tcl::pTk::Font;
use Scalar::Util (qw /blessed/); # Used only for its blessed function
# Setup camel-case commands for pack, and the font commands
use Tcl::pTk::Submethods(
'pack' => [qw(configure forget info propagate slaves)],
'place' => [qw(configure forget info slaves)],
'font' => [qw(actual configure create delete families measure metrics names )],
'form' => [qw(check configure forget grid info slaves)],
);
use strict;
# Generate tk methods (like $widget->appname, which mapps to 'tk appname' in tcl/tk
Direct2 Tcl::pTk::Submethods (
'tk' => [qw(appname caret scaling useinputmethods windowingsystem)],
);
# command for optionAdd, optionClear, etc.
Direct3 Tcl::pTk::Submethods (
'option' => [qw(add clear readfile)]
);
our ($bindActive); # flag = 1 if we are in a binding (used in servicing Tcl::pTk::break's in bindings)
############################## Widget Mapping Structures ############################
# global widget counter, only for autogenerated widget names.
my $gwcnt = '01';
# perlTk<->Tcl::pTk mapping in form [widget, wprefix, ?package?]
# These will be looked up 1st in AUTOLOAD
my %ptk2tcltk =
(
Button => ['button', 'btn',],
Checkbutton => ['checkbutton', 'cb',],
Canvas => ['canvas', 'can',],
Entry => ['entry', 'ent',],
Frame => ['frame', 'f',],
LabelFrame => ['labelframe', 'lf',],
Labelframe => ['labelframe', 'lf',],
#LabFrame => ['labelframe', 'lf',],
Label => ['label', 'lbl',],
Listbox => ['listbox', 'lb',],
Message => ['message', 'msg',],
Menu => ['menu', 'mnu',],
Menubutton => ['menubutton', 'mbtn',],
Panedwindow => ['panedwindow', 'pw',],
Bitmap => ['image', 'bmp',],
Photo => ['image', 'pht',],
lib/Tcl/pTk/Widget.pm view on Meta::CPAN
my $path = $int->icall('winfo', 'containing', @_);
#print "path = $path\n";
my $widget;
# winfo children returns widget paths, so map them to objects
# If a path returned, turn it into a widget
if( $path ){
my $widgets = $int->widgets();
$widgets = $widgets->{RPATH};
$widget = $widgets->{$path};
}
#print "Containing returning $widget\n";
return $widget;
}
sub path {
my $self = shift;
return $Tcl::pTk::Wpath->{ $self->{winID} };
}
# returns interpreter that is associated with widget
sub interp {
my $self = shift;
unless (exists $Tcl::pTk::Wint->{ $self->{winID} }) {
print caller;
die "do not exist: ",$self->{winID};
}
return $Tcl::pTk::Wint->{ $self->{winID} };
}
# Call an interpreter command on a widget
sub call{
my $self = shift;
my @args = @_;
my $interp = $self->interp;
# Go thru each arg and look for callback (i.e -command ) args
my $lastArg;
my $callMethod = 'invoke'; # For speed, use invoke for calling the interp, unless we need to use call (i.e. callback supplied, -variable, etc)
$callMethod = 'call' if( $Tcl::pTk::DEBUG ); # fallback to call for debugging, so we get good stack traces
foreach my $arg(@args){
if( defined($lastArg) && !ref($lastArg) && ( $lastArg =~ /^-\w+/ ) ){
if( $lastArg =~ /command|cmd$/ && defined($arg) ) { # Check for last arg something like -command
#print "Found command arg $lastArg => $arg\n";
# Create Callback object from arg, unless it already is a callback
my $cb;
if( blessed($arg) && $arg->isa('Tcl::pTk::Callback')){
$cb = $arg;
}
else{
$cb = Tcl::pTk::Callback->new($arg);
}
# Store callback in the Configuration store of the widget
# This is to be compatible with perltk's method of storing subrefs as callback objects
# (as opposed to raw subrefs).
$self->Tcl::pTk::Derived::_configure($lastArg, $cb);
# Make a subref that will execute the callback
my $cbSub = sub{
my @callbackArgs = @_;
# Get rid of extra stuff from the args to be supplied for old Tcl.pm's
splice(@callbackArgs, 0, 3) if( $Tcl::VERSION < 0.98); # remove ClientData, Interp and CmdName
#print "Callback Args = '".join("', '", @callbackArgs)."'\n";
$cb->Call(@callbackArgs)
};
$arg = $cbSub; # cbSub will actually be sent to Tcl::call
$callMethod = 'call'; # need to use call, rather than invoke
}
elsif( $lastArg =~ /variable$/ ){ # Check for last arg something like -textvariable
# Store -variable options in the Configuration store of the widget
# This is to be compatible with perltk's way of being able to retieve the actual
# scalar reference
# For example, $entry->configure(-textvariable => \$text),
# $entry->cget(-textvariable) <= should return \$text
#
$self->Tcl::pTk::Derived::_configure($lastArg, $arg); # Store in config store for retrieval later
$callMethod = 'call'; # need to use call, rather than invoke
}
}
if( ref($arg) eq 'SCALAR'){ # scalar refs or code need to be turned to tcl variables, so we use call, not invoke
$callMethod = 'call';
}
$lastArg = $arg;
}
local $^W = 0; # Turn warnings off temporarily so we don't get 'use of undef value' messages
# Translate any empty strings to undefs, for compatibility with perltk
if( wantarray ){
my @retvals = $interp->$callMethod(@args);
return map defined($_) && !ref($_) && ($_ eq '') ? undef : $_, @retvals;
}
else{
my $retval = $interp->$callMethod(@args);
return defined($retval) && !ref($retval) && ($retval eq '') ? undef : $retval;
}
}
# provide cget method (rather than autoload, so megawidget code can
# reference it.)
sub cget {
my $self = shift;
my @args = @_;
my $option = $args[0];
# replace options, if _replace_options hash is defined
if( defined($self->{_replace_options}) ){
my $replace_options = $self->{_replace_options};
if( defined($replace_options->{$option}) ){
my $newOption = $replace_options->{$option};
$option = $newOption unless(ref($newOption) eq 'CODE'); # do all replacements, except for code references
$args[0] = $option;
}
}
# Return the Callback object if a -command type option is requested,
# for compatibility with perlTk
if( defined($option) && !ref($option) && ( $option =~ /^-\w+/ )){
if( $option =~ /command|cmd$/ ){ # Check the option for something like -command
# Retrieve callback from the configuration store of the widget
# This is to be compatible with perltk's method of storing subrefs as callback objects
# (as opposed to raw subrefs)
return $self->Tcl::pTk::Derived::_cget(@args);
}
if( $option =~ /variable$/) { # Check the option for something like -textvariable
# Retrieve scalar ref from the configuration store of the widget
# This is to be compatible with perltk way of being able to retrieve the scalar
# -textvariable using a cget call.
return $self->Tcl::pTk::Derived::_cget(@args);
}
}
# Return an image object, if one requested
# for compatibility with perlTk
if( defined($option) and $option eq '-image' ){
my $name = $self->call($self->path, 'cget', '-image');
if( $name){
# Turn image into an object;
my $type = $self->call('image', 'type', $name);
$type = ucfirst($type);
my $package = "Tcl::pTk::$type";
my $obj = $self->interp->declare_widget($name, $package);
return $obj;
}
return $name;
}
# Return an font object, if one requested
# for compatibility with perlTk
if( defined($option) and $option eq '-font' ){
my $name = $self->call($self->path, 'cget', '-font');
$name = 'TkDefaultFont' unless defined($name); # Set default Tk font name, if none returned
# Turn font name into an object
# (We don't create a font object here, because the font already exists)
my $obj = bless {name => $name, interp => $self->interp}, 'Tcl::pTk::Font';
return $obj;
}
return $self->call($self->path, 'cget', @args);
}
# provide eventGenerate method (can't be autoloaded properly using the current autoload lookup tables
sub eventGenerate {
my $self = shift;
my @args = @_;
return $self->call('event', 'generate', $self->path, @args);
}
# provide eventInfo method (can't be autoloaded properly using the current autoload lookup tables
sub eventInfo {
my $self = shift;
my @args = @_;
return $self->call('event', 'info', @args);
}
# provide eventDelete method (can't be autoloaded properly using the current autoload lookup tables
sub eventDelete {
my $self = shift;
my @args = @_;
return $self->call('event', 'delete', @args);
}
# provide eventDelete method (can't be autoloaded properly using the current autoload lookup tables
sub eventAdd {
my $self = shift;
my @args = @_;
return $self->call('event', 'add', @args);
}
# provide configure method (rather than autoload, so megawidget code can
# reference it.)
sub configure {
my $self = shift;
my @args = @_;
if( @args){ # Normal usage: configure called with args
if( defined( $self->{_replace_options} )){ # apply any replace_options, if needed
my %args = @_;
my $replace_options_wid = $self->{_replace_options};
my @code_todo = process_replace_options($replace_options_wid, \%args);
$_->[0]->($self,$_->[1]) for @code_todo;
if( %args){
return $self->call($self->path, 'configure', %args)
}
else{
return;
}
}
else{ # No replace_options, call like normal
return $self->call($self->path, 'configure', @args); # Normal usage
}
}
# configure called with no args: Fixup the return arrays to be 1D
my @return = $self->call($self->path, 'configure', @args); # Normal usage
# Make sure the output is a 2D array (consistent with perltk)
if( @return && !ref($return[0]) ){ # Parse each element into an array
foreach my $returnElement(@return){
my @pieces = split(/\s+/, $returnElement);
$returnElement = [@pieces];
}
}
# Check for -command args. If set, these should be callbacks
if( @return ){
foreach my $configElem (@return){
next unless ref($configElem);
next unless $configElem->[0] =~ /command|cmd$/; # Check the option for something like -command
# Replace the returned tcl command name with the stored callback
my $callback = $self->Tcl::pTk::Derived::_cget( $configElem->[0] );
$configElem->[4] = $callback;
}
}
return @return;
}
# returns (and optionally creates) data hash associated with widget
sub widget_data {
my $self = shift;
return ($Tcl::pTk::Wdata->{$self->path} || ($Tcl::pTk::Wdata->{$self->path}={}));
}
# few convenience methods
sub tooltip {
my $self = shift;
my $ttext = shift;
$self->interp->pkg_require('tooltip');
$self->call("tooltip::tooltip",$self,$ttext);
$self;
}
### font can't be autoloaded, because it creates a problem with widget delegation if it is autoloaded. ###
# e.g. calling $t->fontCreate, where $t is a megawidget (or scrolled widget) can cause deep recursion errors
# without this sub
sub font
{
my $w = shift;
# For font create, we need to create a font object
if( $_[0] eq 'create' ){
my $option = shift;
return $w->Font(@_);
}
if( $_[0] eq 'actual' && scalar(@_) > 1){ # Call the wrapper for $font->actual in Tcl::pTk::Font.pm that works around the Tcl font bug
my $option = shift;
my $font = shift;
if( !ref($font) ){ # font is not an object, turn it into one
# Turn font name into an object
# (We don't create a font object here, because the font already exists)
$font = bless {name => $font, interp => $w->interp}, 'Tcl::pTk::Font';
}
return $font->actual(@_);
}
$w->call('font', @_);
}
#
# few geometry methods here
sub pack
{
local $SIG{'__DIE__'} = \&Carp::croak;
my $w = shift;
if (@_ && $_[0] =~ /^(?:configure|forget|info|propagate|slaves)$/x)
( run in 0.428 second using v1.01-cache-2.11-cpan-13bb782fe5a )