Vadim Konovalov <[EMAIL PROTECTED]> writes:
> I think we should start using modified Tcl module... Will you apply
> those to CVS?
I've now applied the safe patches (introduce $Tcl::DL_PATH and updated
Mac OS X search for libtcl), but the big cleanup actually make the
Tcl::Tk testsuite fail. I've attached my combined cleanup patch for
reference.
The main problem is that the Tcl 'trace' command don't store the
callback object that is passed in. Instead it just copies the
stringified version and then drop the object. This is a problem when
we pass in a "perlsub" object wrapping an anynumous function. We will
end up garbage collecting the function before it is called by trace.
This problem show for Tcl::Tk because it tries to detect when the
mainwindow is deleted with this code:
$i->call('trace', 'add', 'command', '.', 'delete',
sub { for (keys %W) {$W{$_}->{$mwid} = undef; }});
Since this does not work, the MainLoop will not terminate when the
main window is deleted. The result is that all the tests hang. A
workaround to make the tests run is to assign this callback to some
global variable that keeps it alive even if Tcl will not.
With this workaround all tests pass, but we get a problem with the
"Tcl::Var" destructor in one of the tests during perl's global
destruction. What seems to be happening is that the interpreter is
freed before all the variables resulting in a core dump where Tcl
prints "called Tcl_FindHashEntry on deleted table" and dies with this
stack trace:
#0 0xb7d7c941 in kill () from /lib/libc.so.6
#1 0xb7e6dc6d in pthread_kill () from /lib/libpthread.so.0
#2 0xb7e6dfc1 in raise () from /lib/libpthread.so.0
#3 0xb7d7c6f4 in raise () from /lib/libc.so.6
#4 0xb7d7da66 in abort () from /lib/libc.so.6
#5 0xb7cf5731 in Tcl_PanicVA () from
/opt/ActiveTcl/8.4.9.1.139183/lib/libtcl8.4.so
#6 0xb7cf5763 in Tcl_Panic () from
/opt/ActiveTcl/8.4.9.1.139183/lib/libtcl8.4.so
#7 0xb7cdb092 in BogusFind () from
/opt/ActiveTcl/8.4.9.1.139183/lib/libtcl8.4.so
#8 0xb7cf10ce in TclGetNamespaceForQualName () from
/opt/ActiveTcl/8.4.9.1.139183/lib/libtcl8.4.so
#9 0xb7cf15be in Tcl_FindNamespaceVar () from
/opt/ActiveTcl/8.4.9.1.139183/lib/libtcl8.4.so
#10 0xb7d08929 in TclLookupSimpleVar () from
/opt/ActiveTcl/8.4.9.1.139183/lib/libtcl8.4.so
#11 0xb7d08674 in TclObjLookupVar () from
/opt/ActiveTcl/8.4.9.1.139183/lib/libtcl8.4.so
#12 0xb7d098d8 in TclObjUnsetVar2 () from
/opt/ActiveTcl/8.4.9.1.139183/lib/libtcl8.4.so
#13 0xb7d09829 in Tcl_UnsetVar2 () from
/opt/ActiveTcl/8.4.9.1.139183/lib/libtcl8.4.so
#14 0xb7f33cd2 in XS_Tcl_UnsetVar () from
/opt/perl/ap813/lib/site_perl/5.8.7/i686-linux-thread-multi/auto/Tcl/Tcl.so
#15 0x080b533c in Perl_pp_entersub ()
#16 0x080aeba1 in Perl_runops_standard ()
#17 0x08063ff1 in S_call_body ()
#18 0x08063d97 in Perl_call_sv ()
#19 0x080bc2b2 in Perl_sv_clear ()
#20 0x080bc91e in Perl_sv_free ()
#21 0x080bc630 in Perl_sv_clear ()
#22 0x080bc91e in Perl_sv_free ()
#23 0x080a4318 in Perl_mg_free ()
#24 0x080bc420 in Perl_sv_clear ()
[...]
#45 0x080bc542 in Perl_sv_clear ()
#46 0x080bc91e in Perl_sv_free ()
#47 0x080b615e in do_clean_objs ()
#48 0x080b60d2 in S_visit ()
#49 0x080b6202 in Perl_sv_clean_objs ()
#50 0x08061053 in perl_destruct ()
#51 0x0805ff3a in main ()
We might be able to avoid this problem with maintaining various flags
that make us skip variable deletion during this phase, but I don't
know any good way (besides patching Tcl) to deal with the 'trace'
problem. There might also be other places where Tcl commands taking
callback arguments only keep a copy of the stringified version.
--Gisle
> > >
> > >
> > > Fixing scalar references
> > > ------------------------
> > >
> > > When a scalar reference is passed Tcl.pm will create a shadow variable
> > > on the Tcl side and then tie the perl scalar in order to forward any
> > > Perl side fetch/store on it to the Tcl side. A reference to the
> > > scalar is kept in %anon_refs making sure the variable lives forever.
> > >
> > > Not adding the %anon_refs reference makes it possible for the variable
> > > to be garbage collected by perl when nothing else references it. By
> > > adding destructors to Tcl::Var we can then also clean up the shadow
> > > variable on the Tcl side.
> > >
> > > This is implemented by the patches:
> > >
> > > 189734-tclvar-dtor.patch
> > > 189813-var-unref.patch
> > >
> > >
> > > Fixing code references
> > > ----------------------
> > >
> > > When a code reference is passed Tcl.pm will create a shadow command on
> > > the Tcl side that calls back to the Perl sub. The code reference is
> > > recorded in %anon_hash. This is needed to make sure the code is not
> > > garbage collected before the Tcl command get a chance to call back,
> > > but as a side effect the code will live forever even after there is no
> > > more references to it from the Tcl side.
> > >
> > > My proposed fix is to introduce a new Tcl object type that keeps a
> > > reference to the the real perl CV and that stringifies into something
> > > that is callable on the Tcl side. With this arrangement there is no
> > > need to record the code reference in %anon_hash to keep it alive, and
> > > when Tcl drops the reference to the function it is garbage collected
> > > properly on both the Tcl and Perl side.
>
> Very good. now as CV are of Tcl::Cb type, we can track their destruction
> by ordinary DESTROY method.
? xxx
Index: Tcl.pm
===================================================================
RCS file: /cvsroot/tcltkce/Tcl/Tcl.pm,v
retrieving revision 1.34
diff -u -p -r1.34 Tcl.pm
--- Tcl.pm 8 Sep 2005 10:32:18 -0000 1.34
+++ Tcl.pm 8 Sep 2005 12:12:30 -0000
@@ -129,17 +129,6 @@ subroutine. Example:
}
$widget->bind('<2>', [\&textPaste, Tcl::Ev('%x', '%y'), $widget] );
-=item return_ref (NAME)
-
-returns a reference corresponding to NAME, which was associated during
-previously called C<< $int->call(...) >> preprocessing. As a typical
-example this could be variable associated with a widget.
-
-=item delete_ref (NAME)
-
-deletes and returns a reference corresponding to NAME, which was associated
-during previously called C<< $int->call(...) >> preprocessing.
-
=item icall (PROC, ARG, ...)
Looks up procedure PROC in the interpreter and invokes it using Tcl's eval
@@ -413,23 +402,12 @@ END {
Tcl::_Finalize();
}
-#TODO make better wording here
-# %anon_refs keeps track of anonymous subroutines that were created with
-# "CreateComand" method during process of transformation of arguments for
-# "call" and other stuff such as scalar refs and so on.
-# (TODO -- find out how to check for refcounting and proper releasing of
-# resources)
-
-my %anon_refs;
-
-# %widget_refs is an array to hold refs that were created when working with
-# widget the point is - it's not dangerous to delete more than needed, because
-# those # will be re-created at the very next time they needed.
-# however when widget goes away, it is good to delete anything that comes
-# into mind with that widget
-my %widget_refs;
-my $current_widget = '';
-sub _current_refs_widget {$current_widget=shift}
+# Keep track of the implicit Tcl::Var objects we have created
+my %var_refs;
+
+# legacy stubs to make older versions of Tcl::Tk run
+sub _current_refs_widget {}
+sub delete_widget_refs { }
# Subroutine "call" preprocess the arguments for special cases
# and then calls "icall" (implemented in Tcl.xs), which invokes
@@ -443,17 +421,10 @@ sub call {
my $arg = $args[$argcnt];
my $ref = ref($arg);
next unless $ref;
- 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);
- $widget_refs{$current_widget}->{$args[$argcnt]}++;
- }
- elsif ($ref =~ /^Tcl::Tk::Widget\b/) {
+ if ($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;
}
elsif ($ref eq 'SCALAR') {
# We have been passed something like \$scalar
@@ -463,12 +434,14 @@ sub call {
# This will be SCALAR(0xXXXXXX) - leave it to become part of a
# Tcl array.
my $nm = "::perl::$arg";
- #$nm =~ s/\W/_/g; # remove () from stringified name
- unless (exists $anon_refs{$nm}) {
- $widget_refs{$current_widget}->{$nm}++;
- $anon_refs{$nm} = $arg;
+ unless ($var_refs{$nm}) {
+ $var_refs{$nm}++;
my $s = $$arg;
- tie $$arg, 'Tcl::Var', $interp, $nm;
+ tie $$arg, 'Tcl::Var', $interp, $nm, 0, sub {
+ my($i,$n) = @_;
+ $i->UnsetVar($n);
+ delete $var_refs{$n};
+ };
$s = '' unless defined $s;
$$arg = $s;
}
@@ -485,11 +458,9 @@ sub call {
if ($#$arg >= 1 && ref($arg->[1]) eq 'Tcl::Ev') {
$events = splice(@$arg, 1, 1);
}
- $args[$argcnt] =
- $interp->create_tcl_sub(sub {
- splice @_, 0, 3; # remove ClientData, Interp and CmdName
+ $args[$argcnt] = Tcl::Cb(sub {
$arg->[0]->(@_, @$arg[1..$#$arg]);
- }, $events);
+ }, @$events);
}
elsif ($ref eq 'ARRAY' && ref($arg->[0]) =~ /^Tcl::Tk::Widget\b/) {
# We have been passed [$Tcl_Tk_widget, 'method name', ...]
@@ -504,11 +475,9 @@ sub call {
}
my $wid = $arg->[0];
my $method_name = $arg->[1];
- $args[$argcnt] =
- $interp->create_tcl_sub(sub {
- splice @_, 0, 3; # remove ClientData, Interp and CmdName
+ $args[$argcnt] = Tcl::Cb(sub {
$wid->$method_name(@$arg[2..$#$arg]);
- }, $events);
+ }, @$events);
}
elsif (ref($arg) eq 'REF' and ref($$arg) eq 'SCALAR') {
# this is a very special shortcut: if we see construct like \\"xy"
@@ -517,14 +486,12 @@ sub call {
if (ref($args[$argcnt+1]) eq 'ARRAY' &&
ref($args[$argcnt+1]->[0]) eq 'CODE') {
$arg = $args[$argcnt+1];
- $args[$argcnt] =
- $interp->create_tcl_sub(sub {
- splice @_, 0, 3; # remove ClientData, Interp and CmdName
+ $args[$argcnt] = Tcl::Cb(sub {
$arg->[0]->(@_, @$arg[1..$#$arg]);
- }, $events);
+ }, @$events);
}
elsif (ref($args[$argcnt+1]) eq 'CODE') {
- $args[$argcnt] = $interp->create_tcl_sub($args[$argcnt+1],$events);
+ $args[$argcnt] = Tcl::Cb($args[$argcnt+1], @$events);
}
else {
warn "not CODE/ARRAY expected after description of event fields";
@@ -559,78 +526,12 @@ sub call {
}
}
-# wcall is simple wrapper to 'call' but it tries to search $res in %anon_hash
-# This implementation is temporary
-sub wcall {
- if (wantarray) {
- return call(@_);
- } else {
- my $res = call(@_);
- if (exists $anon_refs{$res}) {
- return $anon_refs{$res};
- }
- return $res;
- }
-}
-
-sub return_ref {
- my $interp = shift;
- my $rname = shift;
- return $anon_refs{$rname};
-}
-sub delete_ref {
- my $interp = shift;
- my $rname = shift;
- my $ref = delete $anon_refs{$rname};
- if (ref($ref) eq 'CODE') {
- $interp->DeleteCommand($rname);
- }
- else {
- $interp->UnsetVar($rname); #TODO: will this delete variable in Tcl?
- untie $$ref;
- }
- return $ref;
-}
-sub return_widget_refs {
- my $interp = shift;
- my $wpath = shift;
- return keys %{$widget_refs{$wpath}};
-}
-sub delete_widget_refs {
- my $interp = shift;
- my $wpath = shift;
- for (keys %{$widget_refs{$wpath}}) {
- #print STDERR "del:$wpath($_)\n";
- delete $widget_refs{$wpath}->{$_};
- $interp->delete_ref($_);
- }
+sub Ev {
+ return bless [EMAIL PROTECTED], "Tcl::Ev";
}
-# create_tcl_sub will create TCL sub that will invoke perl anonymous sub
-# If $events variable is specified then special processing will be
-# performed to provide needed '%' variables.
-# If $tclname is specified then procedure will have namely that name,
-# otherwise it will have machine-readable name.
-# Returns tcl script suitable for using in tcl events.
-sub create_tcl_sub {
- my ($interp,$sub,$events,$tclname) = @_;
- unless ($tclname) {
- # stringify sub, becomes "CODE(0x######)" in ::perl namespace
- $tclname = "::perl::$sub";
- }
- unless (exists $anon_refs{$tclname}) {
- $anon_refs{$tclname} = $sub;
- $interp->CreateCommand($tclname, $sub);
- }
- if ($events) {
- # Add any %-substitutions to callback
- $tclname = "$tclname " . join(' ', @{$events});
- }
- return $tclname;
-}
-sub Ev {
- my @events = @_;
- return bless [EMAIL PROTECTED], "Tcl::Ev";
+sub Cb {
+ return bless [EMAIL PROTECTED], "Tcl::Cb";
}
@@ -644,16 +545,16 @@ package Tcl::Var;
sub TIESCALAR {
my $class = shift;
my @objdata = @_;
- Carp::croak 'Usage: tie $s, Tcl::Var, $interp, $varname [, $flags]'
- unless @_ == 2 || @_ == 3;
+ Carp::croak 'Usage: tie $s, Tcl::Var, $interp, $varname [, $flags [,\&dtor]]'
+ unless @_ >= 2 || @_ <= 4;
bless [EMAIL PROTECTED], $class;
}
sub TIEHASH {
my $class = shift;
my @objdata = @_;
- Carp::croak 'Usage: tie %hash, Tcl::Var, $interp, $varname [, $flags]'
- unless @_ == 2 || @_ == 3;
+ Carp::croak 'Usage: tie %hash, Tcl::Var, $interp, $varname [, $flags [,\&dtor]]'
+ unless @_ >= 2 || @_ <= 3;
bless [EMAIL PROTECTED], $class;
}
@@ -706,7 +607,9 @@ sub UNTIE {
}
sub DESTROY {
my $ref = shift;
- delete $anon_refs{$ref->[1]};
+ if (my $destructor = $ref->[3]) {
+ &$destructor(@$ref);
+ }
}
# This is the perl equiv to the C version, for reference
Index: Tcl.xs
===================================================================
RCS file: /cvsroot/tcltkce/Tcl/Tcl.xs,v
retrieving revision 1.41
diff -u -p -r1.41 Tcl.xs
--- Tcl.xs 8 Sep 2005 10:37:41 -0000 1.41
+++ Tcl.xs 8 Sep 2005 12:12:30 -0000
@@ -140,6 +140,69 @@ static Tcl_ObjType *tclListTypePtr = NUL
static Tcl_ObjType *tclStringTypePtr = NULL;
static Tcl_ObjType *tclWideIntTypePtr = NULL;
+static void UpdateStringOfPerlSub(Tcl_Obj *objPtr);
+static int SetPerlSubFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+static void FreePerlSub(Tcl_Obj *objPtr);
+static void DupPerlSub(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
+
+static Tcl_ObjType tclPerlSubType = {
+ "perlsub",
+ FreePerlSub,
+ DupPerlSub,
+ UpdateStringOfPerlSub,
+ SetPerlSubFromAny
+};
+
+static Tcl_Obj * NewPerlSubObj(CV* cv, char *ev)
+{
+ Tcl_Obj *objPtr = Tcl_NewObj();
+ objPtr->bytes = NULL;
+ SvREFCNT_inc(cv);
+ objPtr->internalRep.twoPtrValue.ptr1 = cv;
+ objPtr->internalRep.twoPtrValue.ptr2 = ev ? strdup(ev) : 0;
+ objPtr->typePtr = &tclPerlSubType;
+ return objPtr;
+}
+
+static void FreePerlSub(Tcl_Obj *objPtr)
+{
+ dTHX;
+ SvREFCNT_dec((SV*)objPtr->internalRep.twoPtrValue.ptr1);
+ Tcl_Free(objPtr->internalRep.twoPtrValue.ptr2);
+ objPtr->internalRep.twoPtrValue.ptr1 = NULL;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+}
+
+static void DupPerlSub(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr)
+{
+ dTHX;
+ dupPtr->internalRep.twoPtrValue.ptr1 = srcPtr->internalRep.twoPtrValue.ptr1;
+ SvREFCNT_inc((SV*)dupPtr->internalRep.twoPtrValue.ptr1);
+ dupPtr->internalRep.twoPtrValue.ptr2 = strdup(srcPtr->internalRep.twoPtrValue.ptr2);
+}
+
+static void UpdateStringOfPerlSub(Tcl_Obj *objPtr)
+{
+ void *p2 = objPtr->internalRep.twoPtrValue.ptr2;
+ size_t len = 40 + (p2 ? strlen(p2) : 0);
+ objPtr->bytes = Tcl_Alloc(len);
+ objPtr->length = snprintf(objPtr->bytes, len, "::perl::call %d%s%s",
+ (IV)objPtr->internalRep.twoPtrValue.ptr1,
+ (p2 ? " " : ""),
+ (p2 ? p2 : "")
+ );
+ assert(objPtr->length < len);
+}
+
+static int SetPerlSubFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr)
+{
+ if (interp != NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), "Can't convert to PerlSub", -1);
+ }
+ return TCL_ERROR;
+}
+
/*
* This tells us whether Tcl is in a "callable" state. Set to 1 in BOOT
* and 0 in Tcl__Finalize (END). Once finalized, we should not make any
@@ -632,6 +695,42 @@ TclObjFromSv(pTHX_ SV *sv)
}
}
}
+ else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
+ objPtr = NewPerlSubObj((CV*)SvRV(sv), NULL);
+ }
+ else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV && sv_isa(sv, "Tcl::Cb")) {
+ CV *code = 0;
+ SV **svp;
+ struct Tcl_Obj *evlist;
+ AV *av = (AV *) SvRV(sv);
+ I32 avlen = av_len(av);
+ int i;
+
+ svp = av_fetch(av, 0, FALSE);
+ if (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVCV) {
+ code = (CV*)SvRV(*svp);
+ }
+ else {
+ croak("No code ref");
+ }
+
+ evlist = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ for (i = 1; i <= avlen; i++) {
+ svp = av_fetch(av, i, FALSE);
+ if (svp) {
+ STRLEN len;
+ char *pv = SvPV(*svp, len);
+ Tcl_ListObjAppendElement(NULL, evlist, Tcl_NewStringObj(pv, len));
+ }
+ else {
+ break;
+ }
+ }
+
+ objPtr = NewPerlSubObj(code, Tcl_GetString(evlist));
+
+ TclFreeObj(evlist);
+ }
else if (SvPOK(sv)) {
STRLEN length;
char *str = SvPV(sv, length);
@@ -775,6 +874,70 @@ int Tcl_EvalInPerl(ClientData clientData
return rc;
}
+static int PerlSubCall(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
+{
+ dTHX;
+ dSP;
+ IV iv;
+ int count;
+ int rc;
+ SV* sv;
+
+ if (objc < 2) {
+ Tcl_SetResult(interp, "too few arguments", TCL_VOLATILE);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetIntFromObj(interp, objv[1], &iv) != TCL_OK)
+ return TCL_ERROR;
+
+ /* skip name and cv */
+ objv += 2;
+ objc -= 2;
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(sp);
+ while (objc--) {
+ PUSHs(sv_2mortal(SvFromTclObj(aTHX_ *objv++)));
+ }
+ PUTBACK;
+
+ count = perl_call_sv(sv_2mortal(newRV_inc((SV*)iv)), G_EVAL|G_SCALAR);
+ SPAGAIN;
+
+ if (SvTRUE(ERRSV)) {
+ Tcl_SetResult(interp, SvPV_nolen(ERRSV), TCL_VOLATILE);
+ POPs; /* pop the undef off the stack */
+ rc = TCL_ERROR;
+ }
+ else {
+ if (count != 1) {
+ croak("Perl sub bound to Tcl proc returned %d args, expected 1",
+ count);
+ }
+ sv = POPs; /* pop the undef off the stack */
+
+ if (SvOK(sv)) {
+ Tcl_Obj *objPtr = TclObjFromSv(aTHX_ sv);
+ /* Tcl_SetObjResult will incr refcount */
+ Tcl_SetObjResult(interp, objPtr);
+ }
+ rc = TCL_OK;
+ }
+
+ PUTBACK;
+ /*
+ * If the routine returned undef, it indicates that it has done the
+ * SetResult itself and that we should return TCL_ERROR
+ */
+
+ FREETMPS;
+ LEAVE;
+ return rc;
+}
+
int Tcl_PerlCallWrapper(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[])
{
@@ -951,6 +1114,7 @@ Tcl_new(class = "Tcl")
sizeof(Tcl), &PL_sv_undef, 0);
}
sv_setref_pv(RETVAL, class, (void*)interp);
+ Tcl_CreateObjCommand(interp, "::perl::call", PerlSubCall, NULL, NULL);
}
OUTPUT:
RETVAL
@@ -1557,7 +1721,7 @@ FETCH(av, key = NULL)
* passed in is [$interp, $varname, $flags] ($flags optional).
*/
if (!initialized) { return; }
- if (AvFILL(av) != 1 && AvFILL(av) != 2) {
+ if (AvFILL(av) < 1) {
croak("bad object passed to Tcl::Var::FETCH");
}
sv = *av_fetch(av, 0, FALSE);
@@ -1592,7 +1756,7 @@ STORE(av, sv1, sv2 = NULL)
* passed in is [$interp, $varname, $flags] ($flags optional).
*/
if (!initialized) { return; }
- if (AvFILL(av) != 1 && AvFILL(av) != 2)
+ if (AvFILL(av) < 1)
croak("bad object passed to Tcl::Var::STORE");
sv = *av_fetch(av, 0, FALSE);
if (sv_derived_from(sv, "Tcl")) {
