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