Index: Makefile.in =================================================================== diff -u -r21a0283e3b67fb56e9dc782b628db602e21c9ac7 -rd72a757e0aa13c9e34e5e8d284a6a3a833b9f6e6 --- Makefile.in (.../Makefile.in) (revision 21a0283e3b67fb56e9dc782b628db602e21c9ac7) +++ Makefile.in (.../Makefile.in) (revision d72a757e0aa13c9e34e5e8d284a6a3a833b9f6e6) @@ -436,6 +436,7 @@ $(TCLSH) $(src_test_dir_native)/tcl86.test -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_test_dir_native)/contains.test -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_test_dir_native)/tcloo.test -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/interp.test -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_doc_dir_native)/example-scripts/bagel.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_doc_dir_native)/example-scripts/rosetta-abstract-type.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_doc_dir_native)/example-scripts/rosetta-classes.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) Index: generic/nsf.c =================================================================== diff -u -r29ed0c8902296dbea451c12d031cc06b6126dd5b -rd72a757e0aa13c9e34e5e8d284a6a3a833b9f6e6 --- generic/nsf.c (.../nsf.c) (revision 29ed0c8902296dbea451c12d031cc06b6126dd5b) +++ generic/nsf.c (.../nsf.c) (revision d72a757e0aa13c9e34e5e8d284a6a3a833b9f6e6) @@ -223,6 +223,8 @@ static NsfObject *GetObjectFromString(Tcl_Interp *interp, CONST char *name); static NsfClass *GetClassFromString(Tcl_Interp *interp, CONST char *name); static int GetClassFromObj(Tcl_Interp *interp, register Tcl_Obj *objPtr, NsfClass **clPtr, int withUnknown); +static NsfObject *GetObjectScreenedByCmdName(Tcl_Interp *interp, Tcl_Command cmdPtr); +static NsfObject *GetObjectFromCmdTable(Tcl_Interp *interp, Tcl_Command searchCmdPtr, Tcl_HashTable *hTablePtr, CONST char **key); static void GetAllInstances(Tcl_Interp *interp, Tcl_HashTable *destTablePtr, NsfClass *startClass); NSF_INLINE static Tcl_Command FindMethod(Tcl_Namespace *nsPtr, CONST char *methodName); @@ -2571,15 +2573,29 @@ /***** SOFT DESTROY *****/ RUNTIME_STATE(interp)->exitHandlerDestroyRound = NSF_EXITHANDLER_ON_SOFT_DESTROY; - /*fprintf(stderr, "===CALL destroy on OBJECTS\n");*/ + /* fprintf(stderr, "===CALL destroy on OBJECTS\n");*/ for (hPtr = Tcl_FirstHashEntry(commandNameTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { char *key = Tcl_GetHashKey(commandNameTable, hPtr); NsfObject *object = GetObjectFromString(interp, key); + /* + * HIDDEN OBJECTS: Provide a fallback to a pointer-based lookup. This is + * needed because objects can be hidden and re-exposed under a different + * command name which is not reported back to the object system by the + * [interp hide|expose] mechanism. Yet, we want to attempt a destroy dispatch on + * hidden and re-exposed objects (e.g., to trigger application-level + * destructors, to have the objects marked with NSF_DESTROY_CALLED). + */ + if (object == NULL) { + Tcl_Command objectCmdPtr; - /* fprintf(stderr, "key = %s %p %d\n", - key, obj, obj && !NsfObjectIsClass(object)); */ + objectCmdPtr = (Tcl_Command)Tcl_GetHashValue(hPtr); + object = GetObjectScreenedByCmdName(interp, objectCmdPtr); + } + + /*fprintf(stderr, "key = %s %p %d\n", + key, object, object && !NsfObjectIsClass(object));*/ if (object && !NsfObjectIsClass(object) && !(object->flags & NSF_DESTROY_CALLED)) { DispatchDestroyMethod(interp, object, 0); @@ -2592,7 +2608,24 @@ hPtr = Tcl_NextHashEntry(&hSrch)) { char *key = Tcl_GetHashKey(commandNameTable, hPtr); NsfClass *cl = GetClassFromString(interp, key); + + /* + * HIDDEN OBJECTS: Provide a fallback to a pointer-based lookup. This is + * needed because objects can be hidden and re-exposed under a different + * command name which is not reported back to the object system by the + * [interp hide|expose] mechanism. Yet, we want to attempt a destroy dispatch on + * hidden objects (e.g., to trigger application-level destructors, to have + * the objects marked with NSF_DESTROY_CALLED). + */ + if (cl == NULL) { + Tcl_Command objectCmdPtr; + NsfObject *hiddenObject; + objectCmdPtr = (Tcl_Command)Tcl_GetHashValue(hPtr); + hiddenObject = GetObjectScreenedByCmdName(interp, objectCmdPtr); + cl = hiddenObject && NsfObjectIsClass(hiddenObject) ? (NsfClass *)hiddenObject : NULL; + } + if (cl && !(cl->object.flags & NSF_DESTROY_CALLED)) { DispatchDestroyMethod(interp, (NsfObject *)cl, 0); } @@ -4264,6 +4297,99 @@ /* *---------------------------------------------------------------------- + * GetObjectFromCmdTable -- + * + * Allows for looking up objects in command tables (e.g., namespace cmd + * tables, the interp's hidden cmd table) based on their command pointer + * (rather than their command name key). + * + * Results: + * NsfObject* or NULL + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static NsfObject * +GetObjectFromCmdTable(Tcl_Interp *interp /* needed? */, Tcl_Command searchCmdPtr, + Tcl_HashTable *hTablePtr, CONST char **key) { + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + Tcl_Command needleCmdPtr; + + if (searchCmdPtr == NULL || hTablePtr == NULL) return NULL; + for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + needleCmdPtr = (Tcl_Command)Tcl_GetHashValue(hPtr); + if (needleCmdPtr == searchCmdPtr) { + if (key != NULL) { + *key = (char *)Tcl_GetHashKey(hTablePtr, hPtr); + } + return needleCmdPtr && Tcl_Command_objProc(needleCmdPtr) == NsfObjDispatch ? + (NsfObject *)Tcl_Command_objClientData(needleCmdPtr) : NULL; + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * GetObjectScreenedByCmdName -- + * + * Provides for a reverse lookup of *hidden* object structures based on + * their commands. This helper is needed for handling hidden and + * re-exposed objects during the shutdown and the cleanup of object + * systems. See GetAllInstances(), ObjectSystemsCleanup(), and + * FreeAllNsfObjectsAndClasses() + * + * Results: + * NsfObject* or NULL + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static NsfObject * +GetObjectScreenedByCmdName(Tcl_Interp *interp, Tcl_Command cmdPtr) { + Interp *iPtr = (Interp *) interp; + NsfObject *screenedObject; + CONST char *cmdName; + + /* + * We can provide a shortcut, knowing that a) exposed cmds have an epoch + * counter > 0, and b) the commands originating namespace must be the global + * one. See also Tcl_HideCommand() and Tcl_ExposeCommand(). + */ + if (cmdPtr == NULL || Tcl_Command_cmdEpoch(cmdPtr) == 0 || + ((Command *)cmdPtr)->nsPtr != iPtr->globalNsPtr) return NULL; + + /* + * 1) Reverse lookup object in the interp's hidden command table. We start + * off with the hidden cmds as we suspect their number being smaller than + * the re-exposed ones, living in the global namespace + */ + screenedObject = GetObjectFromCmdTable(interp, cmdPtr, iPtr->hiddenCmdTablePtr, &cmdName); + if (screenedObject == NULL) { + /* 2) Reverse lookup object in the interp's global command table */ + screenedObject = GetObjectFromCmdTable(interp, cmdPtr, &iPtr->globalNsPtr->cmdTable, &cmdName); + } + +#if !defined(NDEBUG) + if (screenedObject) { + fprintf(stderr, "SCREENED OBJECT %s found: object %p (%s) cmd %p\n", cmdName, screenedObject, + ObjectName(screenedObject), cmdPtr); + } +#endif + return screenedObject; +} + +/* + *---------------------------------------------------------------------- * GetObjectFromString -- * * Lookup an object from a given string. The function performs a @@ -5662,7 +5788,7 @@ GetAllInstances(Tcl_Interp *interp, Tcl_HashTable *destTablePtr, NsfClass *startCl) { NsfClasses *sc; Tcl_HashSearch search; - Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr, *hPtr2; Tcl_HashTable *tablePtr = &startCl->instances; for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr; @@ -5687,6 +5813,16 @@ #if !defined(NDEBUG) { NsfObject *object = GetObjectFromString(interp, ObjectName(inst)); + /* + * HIDDEN OBJECTS: Provide a fallback to a pointer-based lookup. This is + * needed because objects can be hidden or re-exposed under a different + * name which is not reported back to the object system by the [interp + * hide|expose] mechanism. However, we still want to process hidden and + * re-exposed objects during cleanup like ordinary, exposed ones. + */ + if (object == NULL) { + object = GetObjectScreenedByCmdName(interp, inst->id); + } assert(object); } #endif @@ -5697,7 +5833,17 @@ ObjectName(inst), inst->id, cmdPtr->flags, cmdPtr->nsPtr ? cmdPtr->nsPtr->flags : 0, ClassName(startCl));*/ - Tcl_CreateHashEntry(destTablePtr, ObjectName(inst), &new); + hPtr2 = Tcl_CreateHashEntry(destTablePtr, ObjectName(inst), &new); + /* + * HIDDEN OBJECTS: To be able to lookup hidden and re-exposed objects by + * their command pointers, we need to preserve them in the result + * table. Otherwise, pointer-based lookups in the cleanup procedures + * (ObjectSystemsCleanup(), FreeAllNsfObjectsAndClasses()) would not be + * possible. + */ + if (new) { + Tcl_SetHashValue(hPtr2, (ClientData)inst->id); + } } for (sc = startCl->sub; sc; sc = sc->nextPtr) { @@ -5822,8 +5968,15 @@ NsfClass *cl; for (m = startCl->opt->isClassMixinOf; m; m = m->nextPtr) { - /* we should have no deleted commands in the list */ - assert(Tcl_Command_cmdEpoch(m->cmdPtr) == 0); + /* + * HIDDEN OBJECTS: We may encounter situations in which the assertion + * about an cmdEpoch == 0 is too strict. Hidden and re-exposed commands + * have a cmdEpoch > 0. See Tcl_HideCommand() and + * Tcl_ExposeCommand(). Later uses of the command pointer collected here + * (e.g., dispatches) must verify the epoch or perform a safety check by + * refetching the command token. + */ + assert(m->cmdPtr); /* assert(Tcl_Command_cmdEpoch(m->cmdPtr) == 0); */ cl = NsfGetClassFromCmdPtr(m->cmdPtr); assert(cl); @@ -5845,10 +5998,16 @@ NsfObject *object; for (m = startCl->opt->isObjectMixinOf; m; m = m->nextPtr) { + /* + * HIDDEN OBJECTS: We may encounter situations in which the assertion + * about an cmdEpoch == 0 is too strict. Hidden and re-exposed commands + * have a cmdEpoch > 0. See Tcl_HideCommand() and + * Tcl_ExposeCommand(). Later uses of the command pointer collected here + * (e.g., dispatches) must verify the epoch or perform a safety check by + * refetching the command token. + */ + assert(m->cmdPtr); /* assert(Tcl_Command_cmdEpoch(m->cmdPtr) == 0); */ - /* we should have no deleted commands in the list */ - assert(Tcl_Command_cmdEpoch(m->cmdPtr) == 0); - object = NsfGetObjectFromCmdPtr(m->cmdPtr); assert(object); @@ -5935,8 +6094,15 @@ for (m = startCl->opt->isClassMixinOf; m; m = m->nextPtr) { - /* we should have no deleted commands in the list */ - assert(Tcl_Command_cmdEpoch(m->cmdPtr) == 0); + /* + * HIDDEN OBJECTS: We may encounter situations in which the assertion + * about an cmdEpoch == 0 is too strict. Hidden and re-exposed commands + * have a cmdEpoch > 0. See Tcl_HideCommand() and + * Tcl_ExposeCommand(). Later uses of the command pointer collected here + * (e.g., dispatches) must verify the epoch or perform a safety check by + * refetching the command token. + */ + assert(m->cmdPtr); /* assert(Tcl_Command_cmdEpoch(m->cmdPtr) == 0); */ cl = NsfGetClassFromCmdPtr(m->cmdPtr); assert(cl); @@ -5991,8 +6157,15 @@ for (m = startCl->opt->classmixins; m; m = m->nextPtr) { - /* we should have no deleted commands in the list */ - assert(Tcl_Command_cmdEpoch(m->cmdPtr) == 0); + /* + * HIDDEN OBJECTS: We may encounter situations in which the assertion + * about an cmdEpoch == 0 is too strict. Hidden and re-exposed commands + * have a cmdEpoch > 0. See Tcl_HideCommand() and + * Tcl_ExposeCommand(). Later uses of the command pointer collected here + * (e.g., dispatches) must verify the epoch or perform a safety check by + * refetching the command token. + */ + assert(m->cmdPtr); /* assert(Tcl_Command_cmdEpoch(m->cmdPtr) == 0); */ cl = NsfGetClassFromCmdPtr(m->cmdPtr); assert(cl); @@ -16872,16 +17045,24 @@ /* collect all instances from all object systems */ Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS); + MEM_COUNT_ALLOC("Tcl_InitHashTable", &tablePtr); for (osPtr = RUNTIME_STATE(interp)->objectSystems; osPtr; osPtr = osPtr->nextPtr) { GetAllInstances(interp, tablePtr, osPtr->rootClass); } for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { char *key = Tcl_GetHashKey(tablePtr, hPtr); NsfObject *object = GetObjectFromString(interp, key); - - if (!object) { - fprintf(stderr,"key %s\n", key); + /* + * HIDDEN OBJECTS: Provide a fallback to a pointer-based lookup. This is + * needed because objects can be hidden and re-exposed under a different + * name which is not reported back to the object system by the [interp + * hide|expose] mechanism. Yet, we want to process them here ... + */ + if (object == NULL) { + Tcl_Command objectCmdPtr; + objectCmdPtr = (Tcl_Command)Tcl_GetHashValue(hPtr); + object = GetObjectScreenedByCmdName(interp, objectCmdPtr); } assert(object); @@ -16927,6 +17108,7 @@ } /*fprintf(stderr, "all assertions passed\n");*/ Tcl_DeleteHashTable(tablePtr); + MEM_COUNT_FREE("Tcl_InitHashTable", &tablePtr); return TCL_OK; } @@ -22062,7 +22244,18 @@ hPtr = Tcl_NextHashEntry(&hSrch)) { char *key = Tcl_GetHashKey(commandNameTablePtr, hPtr); object = GetObjectFromString(interp, key); - + /* + * HIDDEN OBJECTS: Provide a fallback to a pointer-based lookup. This is + * needed because objects can be hidden and re-exposed under a different + * command name which is not reported back to the object system by the + * [interp hide|expose] mechanism. Yet, we want to perform the standard cleanup + * procedure on hidden objects. + */ + if (object == NULL) { + Tcl_Command objectCmdPtr; + objectCmdPtr = (Tcl_Command)Tcl_GetHashValue(hPtr); + object = GetObjectScreenedByCmdName(interp, objectCmdPtr); + } /* delete per-object methods */ if (object && object->nsPtr) { for (hPtr2 = Tcl_FirstHashEntry(Tcl_Namespace_cmdTablePtr(object->nsPtr), &hSrch2); hPtr2; @@ -22119,8 +22312,21 @@ for (hPtr = Tcl_FirstHashEntry(commandNameTablePtr, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { char *key = Tcl_GetHashKey(commandNameTablePtr, hPtr); - object = GetObjectFromString(interp, key); + /* + * HIDDEN OBJECTS: Provide a fallback to a pointer-based lookup. This is + * needed because objects can be hidden and re-exposed under a different + * command name which is not reported back to the object system by the + * [interp hide|expose] mechanism. Yet, we want to perform the standard cleanup + * procedure on hidden objects. + */ + if (object == NULL) { + Tcl_Command objectCmdPtr; + + objectCmdPtr = (Tcl_Command)Tcl_GetHashValue(hPtr); + object = GetObjectScreenedByCmdName(interp, objectCmdPtr); + } + if (object && !NsfObjectIsClass(object) && !ObjectHasChildren(object)) { /*if (object->id) { fprintf(stderr, " ... delete object %s %p, class=%s id %p ns %p\n", key, object, @@ -22145,6 +22351,22 @@ char *key = Tcl_GetHashKey(commandNameTablePtr, hPtr); NsfClass *cl = GetClassFromString(interp, key); + /* + * HIDDEN OBJECTS: Provide a fallback to a pointer-based lookup. This is + * needed because objects can be hidden and re-exposed under a different + * command name which is not reported back to the object system by the + * [interp hide|expose] mechanism. Yet, we want to perform the standard + * cleanup procedure on hidden objects. + */ + if (cl == NULL) { + Tcl_Command objectCmdPtr; + NsfObject *hiddenObject; + + objectCmdPtr = (Tcl_Command)Tcl_GetHashValue(hPtr); + hiddenObject = GetObjectScreenedByCmdName(interp, objectCmdPtr); + cl = hiddenObject && NsfObjectIsClass(hiddenObject) ? (NsfClass *)hiddenObject : NULL; + } + /*fprintf(stderr, "cl key = %s %p\n", key, cl);*/ if (cl && !ObjectHasChildren((NsfObject *)cl) Index: tests/interp.test =================================================================== diff -u --- tests/interp.test (revision 0) +++ tests/interp.test (revision d72a757e0aa13c9e34e5e8d284a6a3a833b9f6e6) @@ -0,0 +1,465 @@ +# -*- Tcl -*- +package req nx::test + +proc traceStderr args { + puts ">>> traceStderr HA! $args" +} + +nx::Test case hidden-cmds { + + # + # Create a slave interp for testing + # + set i [interp create] + + # + # Some baseline + # + + $i eval { + proc foo {} {;} + } + $i hide foo + + ? [list $i eval [list info commands ::nx::Object]] "" + $i eval [list package req nx] + ? [list $i eval [list info commands ::nx::Object]] ::nx::Object + # + # Tcl's hiding mechansim only applies to objects/classes in the + # top-level namespace. So any non-globally namespaced ones and + # nested objects are not concerned ... + # + $i eval {nx::Object create ::o { + :public method baz {} { return KO } + :public method destroy {} { + # + # sets a global variable for tracing the processing of the + # app-level destructor! + # + set ::[namespace tail [::nsf::current object]] [::nsf::current class] + next + } + }} + $i eval {nx::Class create ::C { + :public method destroy {} { + # + # sets a global variable for tracing the processing of the + # app-level destructor! + # + set ::[namespace tail [::nsf::current object]] [::nsf::current class] + next + } + + :public method bar {} { + return OK + } + }} + $i eval {nx::Class create ::M { + :public method foo {} { + return [::nsf::current object]-[:info class]-[::nsf::current class] + } + }} + ? [list $i eval [list info commands ::o]] ::o + ? [list $i eval [list info commands ::C]] ::C + ? [list $i eval [list info commands ::M]] ::M + + # + # [interp hide] performs a partial and widely silent deletion + # (Tcl_HideCommand(); note, while the idea resembles that of a + # non-deleting rename, there is no C-level trace available!). The + # object's Tcl_command cmdEpoch counter is increased. However, + # hiding does not prune the command structure, nor does is the cmd's + # client data touched. It is merely re-assigned to another, + # interp-wide hash table. The object's command is no valid dispatch + # target anymore ... + # + + ? [list interp hidden $i] "foo" + $i hide o + ? [list interp hidden $i] "foo o" + ? [list $i eval [list ::o]] "invalid command name \"::o\"" + ? [list $i eval [list info commands ::o]] "" + + ? [list interp eval $i [list ::C create ::c]] ::c + # set some relationships to test later ... + ? [list interp eval $i [list ::C mixin add ::M]] ::M + ? [list interp eval $i [list ::C class mixin add ::M]] ::M + + $i hide C + ? [list interp eval $i [list ::C create ::c2]] {invalid command name "::C"} + + # + # However, the object structure is effectively preserved within the + # object system and object relations are intact, e.g., the object is + # still reported as an instance of a class. + # + + ? [list $i eval [list nx::Object info instances ::o]] "::o" + ? [list interp invokehidden $i o ::nsf::methods::object::info::class] "::nx::Object" + ? [list interp invokehidden $i o info class] "::nx::Object" + + ? [list interp eval $i {c info class}] ::C + ? [list interp eval $i {c info class}] ::C + ? [list interp invokehidden $i C info instances ::c] ::c + ? [list interp invokehidden $i C info mixin classes] ::M + # Note, for all introspections that do *not* try to convert the + # Tcl_Obj into an object or a class, but treat it as a pattern (or + # the like) we are fine ... + ? [list $i eval {M info mixinof ::C}] "::C ::C" + ? [list $i eval {M info mixinof -scope class ::C}] "::C" + ? [list $i eval {M info mixinof -scope object ::C}] "::C" + + # dispatch to object-provided method (with the object being hidden) + ? [list interp eval $i {c bar}] OK + + + # dispatch to class-provided methods (with the class being hidden) + ? [list interp eval $i {c bar}] OK + + # dispatch to mixed-in methods (which do basic introspection on the hidden object) ... + ? [list interp invokehidden $i C foo] ::C-::nx::Class-::M + ? [list interp eval $i {c foo}] ::c-::C-::M + + # + # 1) Implicit destruction (through NSF's exit handler) + # + # An important characteristic of a hidden cmd is that it is cleaned + # up later than ordinary, exposed (and namespaced) commands; see + # DeleteInterpProc(). Hidden commands are processed during a interp + # shutdown *after* the exit handler returned! + # + # For testing, we shutdown the NSF object systems in our slave + # interp by using ::nsf::finalize; to do some smoke testing of the + # cleanup results. As for the cleanup procedre, this is equivalent + # to: interp delete $i + $i eval {::nsf::finalize} + + ? [list $i eval {interp hidden}] foo + ? [list $i eval [list info commands ::o]] "" + ? [list $i eval [list info commands ::C]] "" + + # + # Were the app-level destructors called effectively? + # + ? [list $i eval { info exists ::o }] 1 + ? [list $i eval { set ::o }] "" + ? [list $i eval { info exists ::c }] 1 + ? [list $i eval { set ::c }] ::C + + + interp delete $i + + # + # 2) Explicit destruction + # + set i [interp create] + $i eval { + package req nx + nx::Object create ::o2 { + :public method destroy {} { + next + return ok + } + }} + + ? [list interp eval $i { + list [interp hidden] \ + [info commands ::o2] \ + [nx::Object info instances ::o2] \ + [::nsf::object::exists ::o2] + }] {{} ::o2 ::o2 1} + + $i hide o2 + + ? [list interp eval $i { + list [interp hidden] \ + [info commands ::o2] \ + [nx::Object info instances ::o2] \ + [::nsf::object::exists ::o2] + }] {o2 {} ::o2 0} + + ? [list interp invokehidden $i o2 destroy] "ok" + + ? [list interp eval $i { + list [interp hidden] \ + [info commands ::o2] \ + [nx::Object info instances ::o2] \ + [::nsf::object::exists ::o2] + }] {{} {} {} 0} + + # + # 3) hide and re-expose + # + + set i [interp create] + $i eval { + package req nx + nx::Object create ::o { + :public method destroy {} { + incr ::[namespace tail [current]] + return OK + } + :public method foo {} { + return [list [current object] [current class] [:info class] [[current] info class]] + } + } + interp hide {} o + } + + ? [list interp eval $i { + list [interp hidden] \ + [info commands ::o] \ + [nx::Object info instances ::o] \ + [::nsf::object::exists ::o] + }] {o {} ::o 0} "Check hidden state" + + interp expose $i o + ? [list interp eval $i { + list [interp hidden] \ + [info commands ::o] \ + [nx::Object info instances ::o] \ + [::nsf::object::exists ::o] + }] {{} ::o ::o 1} "Check re-exposed state" + + # + # Is the object "alive"? + # + ? [list $i eval {::o foo}] {::o {} ::nx::Object ::nx::Object} + + $i eval {::nsf::finalize} + + # Was the destructor called? + ? [list interp eval $i {info exists ::o}] 1 + ? [list interp eval $i {set ::o}] 1 + + ? [list interp eval $i { + list [interp hidden] \ + [info commands ::o] + }] {{} {}} "Check cleaned-up state" + + interp delete $i + + # 4) hide/re-expose with "command renaming" + + set i [interp create] + $i eval { + package req nx + nx::Object create ::o { + :public method destroy {} { + incr ::[namespace tail [current]] + return OK + } + :public method foo {} { + catch {[current] info class} msg + return [list [current object] [current class] [:info class] $msg] + } + } + interp hide {} o O + } + + ? [list interp eval $i { + list [interp hidden] \ + [info commands ::o] \ + [nx::Object info instances ::o] \ + [::nsf::object::exists ::o] + }] {O {} ::o 0} "Check hidden state -> object command renamed" + + ? [list interp invokehidden $i O foo] {::o {} ::nx::Object {invalid command name "::o"}} + + interp expose $i O OO + + ? [list interp eval $i {OO foo}] {::o {} ::nx::Object {invalid command name "::o"}} + + ? [list interp eval $i { + list [interp hidden] \ + [info commands ::o] \ + [info commands ::OO] \ + [nx::Object info instances ::o] \ + [nx::Object info instances ::OO] \ + [::nsf::object::exists ::o] \ + [::nsf::object::exists ::OO] + }] {{} {} ::OO ::o ::o 0 1} "Check re-exposed state -> object command renamed again"; # should be {} {} ::OO ::o {} 0 1 + + $i eval {::nsf::finalize} + + # Was the destructor called? + ? [list interp eval $i {info exists ::o}] 1 + ? [list interp eval $i {set ::o}] 1 + + ? [list interp eval $i { + list [interp hidden] \ + [info commands ::o] + }] {{} {}} "Check cleaned-up state" + + interp delete $i + + # 5) Rename namespaced object to global one and hide ... + + set i [interp create] + $i eval { + package req nx + namespace eval ::ns1 { + nx::Object create o { + :public method destroy {} { + incr ::[namespace tail [current]] + return OK + } + } + } + } + + ? [list $i hide ::ns1::o] {cannot use namespace qualifiers in hidden command token (rename)} + $i eval {::rename ::ns1::o ::X} + ? [list interp eval $i { + list [interp hidden] \ + [info commands ::X] \ + [nx::Object info instances ::X] \ + [::nsf::object::exists ::X] + }] {{} ::X ::X 1} + $i eval {interp hide {} X} + ? [list interp eval $i { + list [interp hidden] \ + [info commands ::X] \ + [nx::Object info instances ::X] \ + [::nsf::object::exists ::X] + }] {X {} ::X 0} + $i eval {::nsf::finalize} + ? [list interp eval $i {info exists ::X}] 1 + ? [list interp eval $i {set ::X}] 1 + interp delete $i + + # + # 6) Deletion order + # + + set i [interp create] + $i eval { + package req nx + nx::Object create ::o { + :public method destroy {} { + incr ::[namespace tail [current]] + interp invokehidden {} C destroy + next + } + } + + nx::Class create ::C { + :public class method destroy {} { + incr ::[namespace tail [current]] + next + } + } + + } + $i hide o + $i hide C + $i eval {::nsf::finalize} + ? [list interp eval $i {info exists ::C}] 1 + ? [list interp eval $i {set ::C}] 1 + ? [list interp eval $i {info exists ::o}] 1 + ? [list interp eval $i {set ::o}] 1 + interp delete $i + + # 8a) Some stumbling blocks in destructors: [error] in app-level destroy + set i [interp create] + $i eval { + package req nx + nx::Object create ::o { + :public method destroy {} { + error BAFF! + } + } + interp hide {} o + } + + ? [list interp eval $i {::rename ::o ""}] {can't delete "::o": command doesn't exist} + + ? [list interp invokehidden $i o destroy] "BAFF!" + ? [list interp eval $i { + list [interp hidden] \ + [info commands ::o] \ + [nx::Object info instances ::o] \ + [::nsf::object::exists ::o] + }] {o {} ::o 0} + $i eval {::nsf::finalize} + ? [list interp eval $i { + list [interp hidden] \ + [info commands ::o] + }] {{} {}} + interp delete $i + + # 3b) Some stumbling blocks in destructors: [interp hide] in app-level destroy + set i [interp create] + $i eval { + package req nx + proc ::bar {} { + interp hide {} bar; + return 1 + } + + nx::Object create ::o { + :public method destroy {} { + # + # Would not be an issue in safe interps, as [interp hide] & + # friends are disallowed ... + # + set res [catch {interp hide {} o} msg] + # + # TODO: a simple, uncaught 'interp hide {} o' leads to a lookup issue + # and weird error handling; however, the cleanup is not + # affected ... + # + + next + return OK + } + } + } + + ? [list interp eval $i {::bar}] 1 + ? [list interp eval $i {::o destroy}] OK + ? [list interp eval $i { + list [interp hidden] \ + [info commands ::o] \ + [nx::Object info instances ::o] \ + [::nsf::object::exists ::o] + }] {bar {} {} 0} + interp delete $i + + # 3b) Some stumbling blocks in destructors: [interp hide] in app-level destroy + set i [interp create] + $i eval { + package req nx + nx::Object create ::o { + :public method destroy {} { + catch {::rename [current] ""} msg + next + return $msg + } + } + interp hide {} o + } + + # ? [list interp eval $i {::o destroy}] OK; weird error message when channeling back the error info! + ? [list interp invokehidden $i o destroy] {can't delete "::o": command doesn't exist}; + ? [list interp eval $i { + list [interp hidden] \ + [info commands ::o] \ + [nx::Object info instances ::o] \ + [::nsf::object::exists ::o] + }] {{} {} {} 0} + interp delete $i +} + +# +# TODO: +# - [::nsf::current calledclass] seems broken -> returns NULL as string value?! +# - renames to "" in destroy run into an endless loop: +# nx::Object create ::o { +# :public method destroy {} { +# ::rename [current] "" +# next +# } +# :destroy +# } +# # \ No newline at end of file