diff options
| -rw-r--r-- | ChangeLog | 12 | ||||
| -rw-r--r-- | generic/tclInt.h | 8 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 23 | ||||
| -rw-r--r-- | generic/tclOO.c | 42 | ||||
| -rw-r--r-- | tests/oo.test | 60 |
5 files changed, 133 insertions, 12 deletions
@@ -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 { |