| Subject: | Tcl::Tk fixes |
Hello Vadim,
attached is a patch against the latest Tcl::Tk version. It addresses the following points:
* defining a couple of methods for the :perlTk bindings (CanvasBind, bindtags, some wm-related methods, raise, lower, server)
* packAdjust should return the widget, just like the pack method
* Scrollbar was missing
* Exists should not croak on a undefined value
* %wdata and overload support for %{...}. This probably does not work yet,
so you may leave this bit out. The idea is to be able to attach
private data to a widget object. This is possible and even
encouraged in Perl/Tk, because all widget objects are hashes.
* Added the missing "radiobutton" command for -menuitem
-menuitem does not work if one have cascades of cascades. I was not able
to track the real cause of the problem, but did a workaround with the
UNIVERSAL::isa calls.
Do you have plans to make some Tk methods visible, which are only
available in the C API and in Perl/Tk, but not in tcl and Tcl::Tk?
There's for instance DefineBitmap, but I think there are more of them.
(Just trying to make a fairly large and complex Tk script runnable under
Tcl/Tk, and in the end I'm hoping to get the thing working on a PocketPC
system).
Regards,
Slaven
#
#
# To apply this patch:
# STEP 1: Chdir to the source directory.
# STEP 2: Run the 'applypatch' program with this patch file as input.
#
# If you do not have 'applypatch', it is part of the 'makepatch' package
# that you can fetch from the Comprehensive Perl Archive Network:
# http://www.perl.com/CPAN/authors/Johan_Vromans/makepatch-x.y.tar.gz
# In the above URL, 'x' should be 2 or higher.
#
# To apply this patch without the use of 'applypatch':
# STEP 1: Chdir to the source directory.
# STEP 2: Run the 'patch' program with this file as input.
#
#### End of Preamble ####
#### Patch data follows ####
diff -up '../../build/Tcl-Tk-0.76/lib/Tcl/Tk.pm' 'lib/Tcl/Tk.pm'
Index: ./lib/Tcl/Tk.pm
--- ./lib/Tcl/Tk.pm Sun Apr 4 23:47:29 2004
+++ ./lib/Tcl/Tk.pm Tue Apr 20 23:56:34 2004
@@ -523,6 +523,7 @@ sub widget($@) {
sub Exists($) {
return 0 if $#_<0;
my $wid = shift;
+ return 0 if !defined $wid;
if (ref($wid)=~/^Tcl::Tk::Widget\b/) {
my $wp = $wid->path;
return $wint{$wp}->call('winfo','exists',$wp);
@@ -696,6 +697,15 @@ EOS
package Tcl::Tk::Widget;
+my %wdata;
+
+use overload
+ '%{}' => sub {
+ my $self = shift;
+ $wdata{$self->path} ||= {};
+ },
+ fallback => 1;
+
sub DEBUG { Tcl::Tk::DEBUG(); } # do not let AUTOLOAD catch this method
sub iconimage {
@@ -741,6 +751,15 @@ sub bind {
$wint{$$self}->call("bind",$self->path,@_);
}
}
+sub CanvasBind {
+ my $self = shift;
+ die "$self is not a canvas" if (!UNIVERSAL::isa($self, 'Tcl::Tk::Widget::Canvas'));
+ $wint{$$self}->call($$self,'bind',@_);
+}
+sub bindtags {
+ my $self = shift;
+ $wint{$$self}->call("bindtags",$self->path,@_);
+}
sub form {
my $self = shift;
my $int = $wint{$self->path};
@@ -808,6 +827,32 @@ sub title {
my $wp = $self->path;
$wint{$$self}->call('wm','title',$wp,@_);
}
+sub withdraw {
+ my $self = shift;
+ my $wp = $self->path;
+ $wint{$$self}->call('wm','withdraw',$wp,@_);
+}
+sub deiconify {
+ my $self = shift;
+ my $wp = $self->path;
+ $wint{$$self}->call('wm','deiconify',$wp,@_);
+}
+sub iconify {
+ my $self = shift;
+ my $wp = $self->path;
+ $wint{$$self}->call('wm','iconify',$wp,@_);
+}
+sub raise {
+ my $self = shift;
+ my $wp = $self->path;
+ $wint{$$self}->call('raise',$wp,@_);
+}
+sub lower {
+ my $self = shift;
+ my $wp = $self->path;
+ $wint{$$self}->call('lower',$wp,@_);
+}
+
sub reqwidth {
my $self = shift;
my $wp = $self->path;
@@ -848,6 +893,11 @@ sub children {
my $wp = $self->path;
return $wint{$$self}->call('winfo','children',$wp,@_);
}
+sub server {
+ my $self = shift;
+ my $wp = $self->path;
+ return $wint{$$self}->call('winfo','server',$wp,@_);
+}
sub packPropagate {
my $self = shift;
my $wp = $self->path;
@@ -857,6 +907,7 @@ sub packAdjust {
my $self = shift;
my $wp = $self->path;
$wint{$$self}->call('pack','configure',$wp,@_);
+ $self;
}
sub optionGet {
my $self = shift;
@@ -905,6 +956,9 @@ sub getSaveFile {
$args{'-parent'} = $self->path unless defined $args{'-parent'};
$wint{$$self}->call('tk_getSaveFile', %args);
}
+sub MainWindow {
+ $mainwindow;
+}
# TODO all Busy subs
sub Busy {
@@ -1041,6 +1095,7 @@ my %ptk2tcltk = (
Message => 'message',
Frame => 'frame',
Toplevel => 'toplevel',
+ Scrollbar => 'scrollbar',
NoteBook => 'tixNoteBook',
HList => 'tixHList',
);
@@ -1066,6 +1121,7 @@ my %ptk2tcltk_pref =
Panedwindow pw
Radiobutton rb
ROText rt
+ Scrollbar sb
Table tbl
Text txt
TextUndo utxt
@@ -1220,12 +1276,15 @@ sub _process_menuitems {
if ($cmd eq 'Separator') {$int->call($mnu,'add','separator');}
elsif ($cmd eq 'Cascade') {
# XXX do we need to check for ~ here?
+ $mnu = $w{$mnu} if !UNIVERSAL::isa($mnu, 'Tcl::Tk::Widget');
_addcascade($mnu,-label=>$label, %a);
}
else {
$cmd=~s/^Button$/command/;
$cmd=~s/^Checkbutton$/checkbutton/;
+ $cmd=~s/^Radiobutton$/radiobutton/;
# XXX do we need to check for ~ here?
+ $mnu = $mnu->path if UNIVERSAL::isa($mnu, 'Tcl::Tk::Widget');
$int->call($mnu,'add',$cmd,'-label',"$label", %a);
}
}
#### End of Patch data ####
#### ApplyPatch data follows ####
# Data version : 1.0
# Date generated : Wed Apr 21 00:19:32 2004
# Generated by : makepatch 2.00_05
# Recurse directories : Yes
# p 'lib/Tcl/Tk.pm' 53884 1082498194 0100664
#### End of ApplyPatch data ####
#### End of Patch kit [created: Wed Apr 21 00:19:32 2004] ####
#### Patch checksum: 151 4044 33209 ####
#### Checksum: 169 4669 19241 ####