may be its not reachable "perfect" refcounting, but many special cases could
be covered anyways.
"sub call" in Tcl.pm could check a special cases, when widget object invokes
a method, which has a code ref as argument, then in this case command within
tcl will be given a special name
When invoked similar thing second time, Tcl.pm will notice this, and will
delete previous instance.
Below are adjustments for Tcl.pm and Tk.pm.
--- Tcl.pm.orig Mon Sep 12 18:40:35 2005
+++ Tcl.pm Tue Sep 27 15:57:22 2005
@@ -437,6 +437,7 @@
sub call {
my $interp = shift;
my @args = @_;
+ $current_widget = '';
# Process arguments looking for special cases
for (my $argcnt=0; $argcnt<=$#args; $argcnt++) {
@@ -446,14 +447,20 @@
if ($ref eq 'CODE') {
# We have been passed something like \&subroutine
# Create a proc in Tcl that invokes this subroutine (no args)
- $args[$argcnt] = $interp->create_tcl_sub($arg);
+ if ($current_widget and $argcnt>=2 and !ref(my
$vt=$args[$argcnt-1])) {
+ $args[$argcnt] =
$interp->create_tcl_sub($arg,"","::perl::c$args[0]-$vt");
+ } else {
+ $args[$argcnt] = $interp->create_tcl_sub($arg);
+ }
$widget_refs{$current_widget}->{$args[$argcnt]}++;
}
elsif ($ref =~ /^Tcl::Tk::Widget\b/) {
# We have been passed a widget reference.
# Convert to its Tk pathname (eg, .top1.fr1.btn2)
$args[$argcnt] = $arg->path;
- $current_widget = $args[$argcnt] if $argcnt==0;
+ if ($argcnt==0) {
+ $current_widget = $args[$argcnt];
+ }
}
elsif ($ref eq 'SCALAR') {
# We have been passed something like \$scalar
@@ -614,7 +621,14 @@
# Returns tcl script suitable for using in tcl events.
sub create_tcl_sub {
my ($interp,$sub,$events,$tclname) = @_;
- unless ($tclname) {
+ if ($tclname) {
+ # they have name for us - this means we should take care
+ # to delete instances which were probably created earlier
+ if (exists $anon_refs{$tclname}) {
+ delete $anon_refs{$tclname};
+ $interp->DeleteCommand($tclname);
+ }
+ } else {
# stringify sub, becomes "CODE(0x######)" in ::perl namespace
$tclname = "::perl::$sub";
}
--- Tk.pm~ Mon Sep 12 18:40:39 2005
+++ Tk.pm Tue Sep 27 15:50:18 2005
@@ -2342,10 +2342,10 @@
_DEBUG(2, "AUTOCREATE $package$method $method (@_)\n") if DEBUG;
$sub = $fast ? sub {
my $w = shift;
- $w->interp->invoke($w->path, $method, @_);
+ $w->interp->invoke($w, $method, @_);
} : sub {
my $w = shift;
- $w->interp->call($w->path, $method, @_);
+ $w->interp->call($w, $method, @_);
};
}
_DEBUG(2, "creating ($package)$method (@_)\n") if DEBUG;
These are incomplete but rather proof of concept. Following script shows
that quite few procs are allocated:
use Tcl::Tk qw/:perlTk/;
my $mw = tkinit;
my $count;
my $but = $mw->Button(-text => "Hit me",-command=>sub{'qqq'});
print ref($but);
$but->configure(-command => sub { $count++; })
for 0..50;
print $mw->interp->infoCommands("::perl::*"), "\n";
============
Tcl::Tk::Widget::Button::perl::c.btn02--command::perl::Eval::perl::CODE(0x1d
a80dc)::perl::CODE(0x1d0ac98)::perl::w_del
Questions. comments are welcome.
If no-one objects, I will go this way.
Best regards,
Vadim.
