summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog12
-rw-r--r--generic/tclInt.h8
-rw-r--r--generic/tclNamesp.c23
-rw-r--r--generic/tclOO.c42
-rw-r--r--tests/oo.test60
5 files changed, 133 insertions, 12 deletions
diff --git a/ChangeLog b/ChangeLog
index 6585b03..bb536c7 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,15 @@
+2010-02-15 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclOO.c (AllocObject, SquelchedNsFirst, ObjectRenamedTrace):
+ * generic/tclNamesp.c (Tcl_DeleteNamespace): [Bug 2950259]: Revised
+ the namespace deletion code to provide an additional internal callback
+ that gets triggered early enough in namespace deletion to allow TclOO
+ destructors to run sanely. Adjusted TclOO to take advantage of this,
+ so making tearing down an object by killing its namespace appear to
+ work seamlessly, which is needed for Itcl. (Note that this is not a
+ feature that will ever be backported to 8.5, and it remains not a
+ recommended way of deleting an object.)
+
2010-02-13 Donal K. Fellows <dkf@users.sf.net>
* generic/tclCompCmds.c (TclCompileSwitchCmd): Divided the [switch]
diff --git a/generic/tclInt.h b/generic/tclInt.h
index f66fa33..55782ee 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -15,7 +15,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.461 2010/02/13 18:11:06 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.462 2010/02/15 11:53:44 dkf Exp $
*/
#ifndef _TCLINT
@@ -339,6 +339,12 @@ typedef struct Namespace {
NamespacePathEntry *commandPathSourceList;
/* Linked list of path entries that point to
* this namespace. */
+ Tcl_NamespaceDeleteProc *earlyDeleteProc;
+ /* Just like the deleteProc field (and called
+ * with the same clientData) but called at the
+ * start of the deletion process, so there is
+ * a chance for code to do stuff inside the
+ * namespace before deletion completes. */
} Namespace;
/*
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 140c17e..2e8b814 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -22,7 +22,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNamesp.c,v 1.201 2010/02/14 13:23:03 dkf Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.202 2010/02/15 11:53:44 dkf Exp $
*/
#include "tclInt.h"
@@ -733,6 +733,7 @@ Tcl_CreateNamespace(
nsPtr->commandPathLength = 0;
nsPtr->commandPathArray = NULL;
nsPtr->commandPathSourceList = NULL;
+ nsPtr->earlyDeleteProc = NULL;
if (parentPtr != NULL) {
entryPtr = Tcl_CreateHashEntry(
@@ -844,6 +845,26 @@ Tcl_DeleteNamespace(
Command *cmdPtr;
/*
+ * Give anyone interested - notably TclOO - a chance to use this namespace
+ * normally despite the fact that the namespace is going to go. Allows the
+ * calling of destructors. Will only be called once (unless re-established
+ * by the called function). [Bug 2950259]
+ *
+ * Note that setting this field requires access to the internal definition
+ * of namespaces, so it should only be accessed by code that knows about
+ * being careful with reentrancy.
+ */
+
+ if (nsPtr->earlyDeleteProc != NULL) {
+ Tcl_NamespaceDeleteProc *earlyDeleteProc = nsPtr->earlyDeleteProc;
+
+ nsPtr->earlyDeleteProc = NULL;
+ nsPtr->activationCount++;
+ earlyDeleteProc(nsPtr->clientData);
+ nsPtr->activationCount--;
+ }
+
+ /*
* Delete all coroutine commands now: break the circular ref cycle between
* the namespace and the coroutine command [Bug 2724403]. This code is
* essentially duplicated in TclTeardownNamespace() for all other
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 507f8b5..c51a69c 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOO.c,v 1.31 2010/02/11 09:00:55 dkf Exp $
+ * RCS: @(#) $Id: tclOO.c,v 1.32 2010/02/15 11:53:45 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -90,6 +90,7 @@ static void ObjectRenamedTrace(ClientData clientData,
Tcl_Interp *interp, const char *oldName,
const char *newName, int flags);
static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr);
+static void SquelchedNsFirst(ClientData clientData);
static int PublicObjectCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
@@ -518,6 +519,14 @@ AllocObject(
((Namespace *) oPtr->namespacePtr)->flags |= NS_SUPPRESS_COMPILATION;
/*
+ * Set up a callback to get notification of the deletion of a namespace
+ * when enough of the namespace still remains to execute commands and
+ * access variables in it. [Bug 2950259]
+ */
+
+ ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = SquelchedNsFirst;
+
+ /*
* Fill in the rest of the non-zero/NULL parts of the structure.
*/
@@ -616,6 +625,30 @@ MyDeleted(
/*
* ----------------------------------------------------------------------
*
+ * SquelchedNsFirst --
+ *
+ * This callback is triggered when the object's namespace is deleted by
+ * any mechanism. It deletes the object's public command if it has not
+ * already been deleted, so ensuring that destructors get run at an
+ * appropriate time. [Bug 2950259]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+SquelchedNsFirst(
+ ClientData clientData)
+{
+ Object *oPtr = clientData;
+
+ if (oPtr->command) {
+ Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* ObjectRenamedTrace --
*
* This callback is triggered when the object is deleted by any
@@ -697,6 +730,9 @@ ObjectRenamedTrace(
* OK, the destructor's been run. Time to splat the class data (if any)
* and nuke the namespace (which triggers the final crushing of the object
* structure itself).
+ *
+ * The namespace is only deleted if it hasn't already been deleted. [Bug
+ * 2950259]
*/
clsPtr = oPtr->classPtr;
@@ -704,7 +740,9 @@ ObjectRenamedTrace(
AddRef(clsPtr);
ReleaseClassContents(interp, oPtr);
}
- Tcl_DeleteNamespace(oPtr->namespacePtr);
+ if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) {
+ Tcl_DeleteNamespace(oPtr->namespacePtr);
+ }
if (clsPtr) {
DelRef(clsPtr);
}
diff --git a/tests/oo.test b/tests/oo.test
index d831b3d..fbb8971 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -7,7 +7,7 @@
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: oo.test,v 1.36 2010/02/02 09:13:45 dkf Exp $
+# RCS: @(#) $Id: oo.test,v 1.37 2010/02/15 11:53:45 dkf Exp $
package require -exact TclOO 0.6.2 ;# Must match value in generic/tclOO.h
if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -379,17 +379,36 @@ test oo-3.4 {basic test of OO functionality: my exists in destructor} -setup {
obj destroy
lappend result [info commands ::objmy]
} -match glob -result {0 ok *::state localcmdexists {}}
-# Compare with previous test; the differences are because here the destructor
-# is run with the namespace partially squelched.
-test oo-3.5 {basic test of OO functionality: my exists in destructor} -setup {
+test oo-3.4a {basic test of OO functionality: my exists in destructor} -setup {
+ oo::class create cls
+ set result {}
+} -cleanup {
+ cls destroy
+} -body {
+ oo::define cls {
+ variable state
+ constructor {} {
+ proc localcmdexists {} {}
+ set state ok
+ }
+ forward Report lappend ::result
+ destructor {
+ objmy Report [catch {set state} msg] $msg
+ objmy Report [namespace which -var state]
+ objmy Report [info commands localcmdexists]
+ }
+ }
+ cls create obj
+ rename [info object namespace obj]::my ::objmy
+ rename obj {}
+ lappend result [info commands ::objmy]
+} -match glob -result {0 ok *::state localcmdexists {}}
+test oo-3.5 {basic test of OO functionality: destructor: evil case for Itcl} -setup {
oo::class create cls
set result {}
} -cleanup {
cls destroy
} -body {
- # Order of destruction of commands relative to namespace is complex, but
- # we want to make sure that the order from the perspective of TclOO is
- # solid.
oo::define cls {
variable state
constructor {} {
@@ -407,7 +426,32 @@ test oo-3.5 {basic test of OO functionality: my exists in destructor} -setup {
rename [info object namespace obj]::my ::objmy
namespace delete [info object namespace obj]
lappend result [info commands ::objmy]
-} -match glob -result {1 {can't read "state": no such variable} *::state {} {}}
+} -match glob -result {0 ok *::state localcmdexists {}}
+test oo-3.5a {basic test of OO functionality: destructor: evil case for Itcl} -setup {
+ oo::class create cls
+ set result {}
+} -cleanup {
+ cls destroy
+} -body {
+ oo::define cls {
+ variable state result
+ constructor {} {
+ proc localcmdexists {} {}
+ set state ok
+ my eval {upvar 0 ::result result}
+ }
+ method nuke {} {
+ namespace delete [namespace current]
+ return $result
+ }
+ destructor {
+ lappend result [self] $state [info commands localcmdexists]
+ }
+ }
+ cls create obj
+ namespace delete [info object namespace obj]
+ [cls create obj2] nuke
+} -match glob -result {::obj ok localcmdexists ::obj2 ok localcmdexists}
test oo-3.6 {basic test of OO functionality: errors in destructor} -setup {
oo::class create cls
} -cleanup {