summaryrefslogtreecommitdiffstats
path: root/generic/tclOOBasic.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclOOBasic.c')
-rw-r--r--generic/tclOOBasic.c1239
1 files changed, 1239 insertions, 0 deletions
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
new file mode 100644
index 0000000..0676618
--- /dev/null
+++ b/generic/tclOOBasic.c
@@ -0,0 +1,1239 @@
+/*
+ * tclOOBasic.c --
+ *
+ * This file contains implementations of the "simple" commands and
+ * methods from the object-system core.
+ *
+ * Copyright (c) 2005-2012 by Donal K. Fellows
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+#include "tclInt.h"
+#include "tclOOInt.h"
+
+static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp);
+static int AfterNRDestructor(ClientData data[],
+ Tcl_Interp *interp, int result);
+static int DecrRefsPostClassConstructor(ClientData data[],
+ Tcl_Interp *interp, int result);
+static int FinalizeConstruction(ClientData data[],
+ Tcl_Interp *interp, int result);
+static int FinalizeEval(ClientData data[],
+ Tcl_Interp *interp, int result);
+static int RestoreFrame(ClientData data[],
+ Tcl_Interp *interp, int result);
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AddCreateCallback, FinalizeConstruction --
+ *
+ * Special version of TclNRAddCallback that allows the caller to splice
+ * the object created later on. Always calls FinalizeConstruction, which
+ * converts the object into its name and stores that in the interpreter
+ * result. This is shared by all the construction methods (create,
+ * createWithNamespace, new).
+ *
+ * Note that this is the only code in this file (or, indeed, the whole of
+ * TclOO) that uses NRE internals; it is the only code that does
+ * non-standard poking in the NRE guts.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline Tcl_Object *
+AddConstructionFinalizer(
+ Tcl_Interp *interp)
+{
+ TclNRAddCallback(interp, FinalizeConstruction, NULL, NULL, NULL, NULL);
+ return (Tcl_Object *) &(TOP_CB(interp)->data[0]);
+}
+
+static int
+FinalizeConstruction(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Object *oPtr = data[0];
+
+ if (result != TCL_OK) {
+ return result;
+ }
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Class_Constructor --
+ *
+ * Implementation for oo::class constructor.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Class_Constructor(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ Tcl_Obj *invoke[3];
+
+ if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "?definitionScript?");
+ return TCL_ERROR;
+ } else if (objc == Tcl_ObjectContextSkippedArgs(context)) {
+ return TCL_OK;
+ }
+
+ /*
+ * Delegate to [oo::define] to do the work.
+ */
+
+ invoke[0] = oPtr->fPtr->defineName;
+ invoke[1] = TclOOObjectName(interp, oPtr);
+ invoke[2] = objv[objc-1];
+
+ /*
+ * Must add references or errors in configuration script will cause
+ * trouble.
+ */
+
+ Tcl_IncrRefCount(invoke[0]);
+ Tcl_IncrRefCount(invoke[1]);
+ Tcl_IncrRefCount(invoke[2]);
+ TclNRAddCallback(interp, DecrRefsPostClassConstructor,
+ invoke[0], invoke[1], invoke[2], NULL);
+
+ /*
+ * Tricky point: do not want the extra reported level in the Tcl stack
+ * trace, so use TCL_EVAL_NOERR.
+ */
+
+ return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL);
+}
+
+static int
+DecrRefsPostClassConstructor(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ TclDecrRefCount((Tcl_Obj *) data[0]);
+ TclDecrRefCount((Tcl_Obj *) data[1]);
+ TclDecrRefCount((Tcl_Obj *) data[2]);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Class_Create --
+ *
+ * Implementation for oo::class->create method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Class_Create(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ const char *objName;
+ int len;
+
+ /*
+ * Sanity check; should not be possible to invoke this method on a
+ * non-class.
+ */
+
+ if (oPtr->classPtr == NULL) {
+ Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "object \"%s\" is not a class", TclGetString(cmdnameObj)));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Check we have the right number of (sensible) arguments.
+ */
+
+ if (objc - Tcl_ObjectContextSkippedArgs(context) < 1) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "objectName ?arg ...?");
+ return TCL_ERROR;
+ }
+ objName = Tcl_GetStringFromObj(
+ objv[Tcl_ObjectContextSkippedArgs(context)], &len);
+ if (len == 0) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "object name must not be empty", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the object and return its name.
+ */
+
+ return TclNRNewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
+ objName, NULL, objc, objv,
+ Tcl_ObjectContextSkippedArgs(context)+1,
+ AddConstructionFinalizer(interp));
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Class_CreateNs --
+ *
+ * Implementation for oo::class->createWithNamespace method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Class_CreateNs(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ const char *objName, *nsName;
+ int len;
+
+ /*
+ * Sanity check; should not be possible to invoke this method on a
+ * non-class.
+ */
+
+ if (oPtr->classPtr == NULL) {
+ Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "object \"%s\" is not a class", TclGetString(cmdnameObj)));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Check we have the right number of (sensible) arguments.
+ */
+
+ if (objc - Tcl_ObjectContextSkippedArgs(context) < 2) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "objectName namespaceName ?arg ...?");
+ return TCL_ERROR;
+ }
+ objName = Tcl_GetStringFromObj(
+ objv[Tcl_ObjectContextSkippedArgs(context)], &len);
+ if (len == 0) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "object name must not be empty", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
+ return TCL_ERROR;
+ }
+ nsName = Tcl_GetStringFromObj(
+ objv[Tcl_ObjectContextSkippedArgs(context)+1], &len);
+ if (len == 0) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "namespace name must not be empty", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the object and return its name.
+ */
+
+ return TclNRNewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
+ objName, nsName, objc, objv,
+ Tcl_ObjectContextSkippedArgs(context)+2,
+ AddConstructionFinalizer(interp));
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Class_New --
+ *
+ * Implementation for oo::class->new method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Class_New(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+
+ /*
+ * Sanity check; should not be possible to invoke this method on a
+ * non-class.
+ */
+
+ if (oPtr->classPtr == NULL) {
+ Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "object \"%s\" is not a class", TclGetString(cmdnameObj)));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the object and return its name.
+ */
+
+ return TclNRNewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
+ NULL, NULL, objc, objv, Tcl_ObjectContextSkippedArgs(context),
+ AddConstructionFinalizer(interp));
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Object_Destroy --
+ *
+ * Implementation for oo::object->destroy method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Object_Destroy(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
+ CallContext *contextPtr;
+
+ if (objc != Tcl_ObjectContextSkippedArgs(context)) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
+ if (!(oPtr->flags & DESTRUCTOR_CALLED)) {
+ oPtr->flags |= DESTRUCTOR_CALLED;
+ contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+ if (contextPtr != NULL) {
+ contextPtr->callPtr->flags |= DESTRUCTOR;
+ contextPtr->skip = 0;
+ TclNRAddCallback(interp, AfterNRDestructor, contextPtr,
+ NULL, NULL, NULL);
+ TclPushTailcallPoint(interp);
+ return TclOOInvokeContext(contextPtr, interp, 0, NULL);
+ }
+ }
+ if (oPtr->command) {
+ Tcl_DeleteCommandFromToken(interp, oPtr->command);
+ }
+ return TCL_OK;
+}
+
+static int
+AfterNRDestructor(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CallContext *contextPtr = data[0];
+
+ if (contextPtr->oPtr->command) {
+ Tcl_DeleteCommandFromToken(interp, contextPtr->oPtr->command);
+ }
+ TclOODeleteContext(contextPtr);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Object_Eval --
+ *
+ * Implementation for oo::object->eval method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Object_Eval(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ CallContext *contextPtr = (CallContext *) context;
+ Tcl_Object object = Tcl_ObjectContextObject(context);
+ register const int skip = Tcl_ObjectContextSkippedArgs(context);
+ CallFrame *framePtr, **framePtrPtr = &framePtr;
+ Tcl_Obj *scriptPtr;
+ int result;
+ CmdFrame *invoker;
+
+ if (objc-1 < skip) {
+ Tcl_WrongNumArgs(interp, skip, objv, "arg ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the object's namespace the current namespace and evaluate the
+ * command(s).
+ */
+
+ result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
+ Tcl_GetObjectNamespace(object), 0);
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+ framePtr->objc = objc;
+ framePtr->objv = objv; /* Reference counts do not need to be
+ * incremented here. */
+
+ if (!(contextPtr->callPtr->flags & PUBLIC_METHOD)) {
+ object = NULL; /* Now just for error mesage printing. */
+ }
+
+ /*
+ * Work out what script we are actually going to evaluate.
+ *
+ * When there's more than one argument, we concatenate them together with
+ * spaces between, then evaluate the result. Tcl_EvalObjEx will delete the
+ * object when it decrements its refcount after eval'ing it.
+ */
+
+ if (objc != skip+1) {
+ scriptPtr = Tcl_ConcatObj(objc-skip, objv+skip);
+ invoker = NULL;
+ } else {
+ scriptPtr = objv[skip];
+ invoker = ((Interp *) interp)->cmdFramePtr;
+ }
+
+ /*
+ * Evaluate the script now, with FinalizeEval to do the processing after
+ * the script completes.
+ */
+
+ TclNRAddCallback(interp, FinalizeEval, object, NULL, NULL, NULL);
+ return TclNREvalObjEx(interp, scriptPtr, 0, invoker, skip);
+}
+
+static int
+FinalizeEval(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ if (result == TCL_ERROR) {
+ Object *oPtr = data[0];
+ const char *namePtr;
+
+ if (oPtr) {
+ namePtr = TclGetString(TclOOObjectName(interp, oPtr));
+ } else {
+ namePtr = "my";
+ }
+
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (in \"%s eval\" script line %d)",
+ namePtr, Tcl_GetErrorLine(interp)));
+ }
+
+ /*
+ * Restore the previous "current" namespace.
+ */
+
+ TclPopStackFrame(interp);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Object_Unknown --
+ *
+ * Default unknown method handler method (defined in oo::object). This
+ * just creates a suitable error message.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Object_Unknown(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ CallContext *contextPtr = (CallContext *) context;
+ Object *oPtr = contextPtr->oPtr;
+ const char **methodNames;
+ int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);
+ Tcl_Obj *errorMsg;
+
+ /*
+ * If no method name, generate an error asking for a method name. (Only by
+ * overriding *this* method can an object handle the absence of a method
+ * name without an error).
+ */
+
+ if (objc < skip+1) {
+ Tcl_WrongNumArgs(interp, skip, objv, "method ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the list of methods that we want to know about.
+ */
+
+ numMethodNames = TclOOGetSortedMethodList(oPtr,
+ contextPtr->callPtr->flags & PUBLIC_METHOD, &methodNames);
+
+ /*
+ * Special message when there are no visible methods at all.
+ */
+
+ if (numMethodNames == 0) {
+ Tcl_Obj *tmpBuf = TclOOObjectName(interp, oPtr);
+ const char *piece;
+
+ if (contextPtr->callPtr->flags & PUBLIC_METHOD) {
+ piece = "visible methods";
+ } else {
+ piece = "methods";
+ }
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "object \"%s\" has no %s", TclGetString(tmpBuf), piece));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[skip]), NULL);
+ return TCL_ERROR;
+ }
+
+ errorMsg = Tcl_ObjPrintf("unknown method \"%s\": must be ",
+ TclGetString(objv[skip]));
+ for (i=0 ; i<numMethodNames-1 ; i++) {
+ if (i) {
+ Tcl_AppendToObj(errorMsg, ", ", -1);
+ }
+ Tcl_AppendToObj(errorMsg, methodNames[i], -1);
+ }
+ if (i) {
+ Tcl_AppendToObj(errorMsg, " or ", -1);
+ }
+ Tcl_AppendToObj(errorMsg, methodNames[i], -1);
+ ckfree(methodNames);
+ Tcl_SetObjResult(interp, errorMsg);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(objv[skip]), NULL);
+ return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Object_LinkVar --
+ *
+ * Implementation of oo::object->variable method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Object_LinkVar(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Object object = Tcl_ObjectContextObject(context);
+ Namespace *savedNsPtr;
+ int i;
+
+ if (objc-Tcl_ObjectContextSkippedArgs(context) < 0) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "?varName ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * A sanity check. Shouldn't ever happen. (This is all that remains of a
+ * more complex check inherited from [global] after we have applied the
+ * fix for [Bug 2903811]; note that the fix involved *removing* code.)
+ */
+
+ if (iPtr->varFramePtr == NULL) {
+ return TCL_OK;
+ }
+
+ for (i=Tcl_ObjectContextSkippedArgs(context) ; i<objc ; i++) {
+ Var *varPtr, *aryPtr;
+ const char *varName = TclGetString(objv[i]);
+
+ /*
+ * The variable name must not contain a '::' since that's illegal in
+ * local names.
+ */
+
+ if (strstr(varName, "::") != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "variable name \"%s\" illegal: must not contain namespace"
+ " separator", varName));
+ Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Switch to the object's namespace for the duration of this call.
+ * Like this, the variable is looked up in the namespace of the
+ * object, and not in the namespace of the caller. Otherwise this
+ * would only work if the caller was a method of the object itself,
+ * which might not be true if the method was exported. This is a bit
+ * of a hack, but the simplest way to do this (pushing a stack frame
+ * would be horribly expensive by comparison).
+ */
+
+ savedNsPtr = iPtr->varFramePtr->nsPtr;
+ iPtr->varFramePtr->nsPtr = (Namespace *)
+ Tcl_GetObjectNamespace(object);
+ varPtr = TclObjLookupVar(interp, objv[i], NULL, TCL_NAMESPACE_ONLY,
+ "define", 1, 0, &aryPtr);
+ iPtr->varFramePtr->nsPtr = savedNsPtr;
+
+ if (varPtr == NULL || aryPtr != NULL) {
+ /*
+ * Variable cannot be an element in an array. If aryPtr is not
+ * NULL, it is an element, so throw up an error and return.
+ */
+
+ TclVarErrMsg(interp, varName, NULL, "define",
+ "name refers to an element in an array");
+ Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Arrange for the lifetime of the variable to be correctly managed.
+ * This is copied out of Tcl_VariableObjCmd...
+ */
+
+ if (!TclIsVarNamespaceVar(varPtr)) {
+ TclSetVarNamespaceVar(varPtr);
+ }
+
+ if (TclPtrMakeUpvar(interp, varPtr, varName, 0, -1) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Object_VarName --
+ *
+ * Implementation of the oo::object->varname method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Object_VarName(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* Interpreter in which to create the object;
+ * also used for error reporting. */
+ Tcl_ObjectContext context, /* The object/call context. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* The actual arguments. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Var *varPtr, *aryVar;
+ Tcl_Obj *varNamePtr;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "varName");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Switch to the object's namespace for the duration of this call. Like
+ * this, the variable is looked up in the namespace of the object, and not
+ * in the namespace of the caller. Otherwise this would only work if the
+ * caller was a method of the object itself, which might not be true if
+ * the method was exported. This is a bit of a hack, but the simplest way
+ * to do this (pushing a stack frame would be horribly expensive by
+ * comparison, and is only done when we'd otherwise interfere with the
+ * global namespace).
+ */
+
+ if (iPtr->varFramePtr == NULL) {
+ Tcl_CallFrame *dummyFrame;
+
+ TclPushStackFrame(interp, &dummyFrame,
+ Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)),0);
+ varPtr = TclObjLookupVar(interp, objv[objc-1], NULL,
+ TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar);
+ TclPopStackFrame(interp);
+ } else {
+ Namespace *savedNsPtr;
+
+ savedNsPtr = iPtr->varFramePtr->nsPtr;
+ iPtr->varFramePtr->nsPtr = (Namespace *)
+ Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
+ varPtr = TclObjLookupVar(interp, objv[objc-1], NULL,
+ TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar);
+ iPtr->varFramePtr->nsPtr = savedNsPtr;
+ }
+
+ if (varPtr == NULL) {
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE",
+ TclGetString(objv[objc-1]), NULL);
+ return TCL_ERROR;
+ }
+
+ varNamePtr = Tcl_NewObj();
+ if (aryVar != NULL) {
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+
+ Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr);
+
+ /*
+ * WARNING! This code pokes inside the implementation of hash tables!
+ */
+
+ hPtr = Tcl_FirstHashEntry((Tcl_HashTable *) aryVar->value.tablePtr,
+ &search);
+ while (hPtr != NULL) {
+ if (varPtr == Tcl_GetHashValue(hPtr)) {
+ Tcl_AppendToObj(varNamePtr, "(", -1);
+ Tcl_AppendObjToObj(varNamePtr, hPtr->key.objPtr);
+ Tcl_AppendToObj(varNamePtr, ")", -1);
+ break;
+ }
+ hPtr = Tcl_NextHashEntry(&search);
+ }
+ } else {
+ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
+ }
+ Tcl_SetObjResult(interp, varNamePtr);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONextObjCmd, TclOONextToObjCmd --
+ *
+ * Implementation of the [next] and [nextto] commands. Note that these
+ * commands are only ever to be used inside the body of a procedure-like
+ * method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOONextObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *framePtr = iPtr->varFramePtr;
+ Tcl_ObjectContext context;
+
+ /*
+ * Start with sanity checks on the calling context to make sure that we
+ * are invoked from a suitable method context. If so, we can safely
+ * retrieve the handle to the object call context.
+ */
+
+ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s may only be called from inside a method",
+ TclGetString(objv[0])));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ return TCL_ERROR;
+ }
+ context = framePtr->clientData;
+
+ /*
+ * Invoke the (advanced) method call context in the caller context. Note
+ * that this is like [uplevel 1] and not [eval].
+ */
+
+ TclNRAddCallback(interp, RestoreFrame, framePtr, NULL, NULL, NULL);
+ iPtr->varFramePtr = framePtr->callerVarPtr;
+ return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1);
+}
+
+int
+TclOONextToObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *framePtr = iPtr->varFramePtr;
+ Class *classPtr;
+ CallContext *contextPtr;
+ int i;
+ Tcl_Object object;
+
+ /*
+ * Start with sanity checks on the calling context to make sure that we
+ * are invoked from a suitable method context. If so, we can safely
+ * retrieve the handle to the object call context.
+ */
+
+ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s may only be called from inside a method",
+ TclGetString(objv[0])));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ return TCL_ERROR;
+ }
+ contextPtr = framePtr->clientData;
+
+ /*
+ * Sanity check the arguments; we need the first one to refer to a class.
+ */
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "class ?arg...?");
+ return TCL_ERROR;
+ }
+ object = Tcl_GetObjectFromObj(interp, objv[1]);
+ if (object == NULL) {
+ return TCL_ERROR;
+ }
+ classPtr = ((Object *)object)->classPtr;
+ if (classPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" is not a class", TclGetString(objv[1])));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Search for an implementation of a method associated with the current
+ * call on the call chain past the point where we currently are. Do not
+ * allow jumping backwards!
+ */
+
+ for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) {
+ struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
+
+ if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
+ /*
+ * Invoke the (advanced) method call context in the caller
+ * context. Note that this is like [uplevel 1] and not [eval].
+ */
+
+ TclNRAddCallback(interp, RestoreFrame, framePtr, contextPtr,
+ INT2PTR(contextPtr->index), NULL);
+ contextPtr->index = i-1;
+ iPtr->varFramePtr = framePtr->callerVarPtr;
+ return TclNRObjectContextInvokeNext(interp,
+ (Tcl_ObjectContext) contextPtr, objc, objv, 2);
+ }
+ }
+
+ /*
+ * Generate an appropriate error message, depending on whether the value
+ * is on the chain but unreachable, or not on the chain at all.
+ */
+
+ for (i=contextPtr->index ; i>=0 ; i--) {
+ struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
+
+ if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "method implementation by \"%s\" not reachable from here",
+ TclGetString(objv[1])));
+ return TCL_ERROR;
+ }
+ }
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "method has no non-filter implementation by \"%s\"",
+ TclGetString(objv[1])));
+ return TCL_ERROR;
+}
+
+static int
+RestoreFrame(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ CallContext *contextPtr = data[1];
+
+ iPtr->varFramePtr = data[0];
+ if (contextPtr != NULL) {
+ contextPtr->index = PTR2INT(data[2]);
+ }
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOSelfObjCmd --
+ *
+ * Implementation of the [self] command, which provides introspection of
+ * the call context.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOSelfObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ static const char *const subcmds[] = {
+ "call", "caller", "class", "filter", "method", "namespace", "next",
+ "object", "target", NULL
+ };
+ enum SelfCmds {
+ SELF_CALL, SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS,
+ SELF_NEXT, SELF_OBJECT, SELF_TARGET
+ };
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *framePtr = iPtr->varFramePtr;
+ CallContext *contextPtr;
+ Tcl_Obj *result[3];
+ int index;
+
+#define CurrentlyInvoked(contextPtr) \
+ ((contextPtr)->callPtr->chain[(contextPtr)->index])
+
+ /*
+ * Start with sanity checks on the calling context and the method context.
+ */
+
+ if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s may only be called from inside a method",
+ TclGetString(objv[0])));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ return TCL_ERROR;
+ }
+
+ contextPtr = framePtr->clientData;
+
+ /*
+ * Now we do "conventional" argument parsing for a while. Note that no
+ * subcommand takes arguments.
+ */
+
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "subcommand");
+ return TCL_ERROR;
+ } else if (objc == 1) {
+ index = SELF_OBJECT;
+ } else if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "subcommand", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum SelfCmds) index) {
+ case SELF_OBJECT:
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, contextPtr->oPtr));
+ return TCL_OK;
+ case SELF_NS:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ contextPtr->oPtr->namespacePtr->fullName,-1));
+ return TCL_OK;
+ case SELF_CLASS: {
+ Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;
+
+ if (clsPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method not defined by a class", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
+ return TCL_OK;
+ }
+ case SELF_METHOD:
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->constructorName);
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->destructorName);
+ } else {
+ Tcl_SetObjResult(interp,
+ CurrentlyInvoked(contextPtr).mPtr->namePtr);
+ }
+ return TCL_OK;
+ case SELF_FILTER:
+ if (!CurrentlyInvoked(contextPtr).isFilter) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "not inside a filtering context", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
+ return TCL_ERROR;
+ } else {
+ register struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
+ Object *oPtr;
+ const char *type;
+
+ if (miPtr->filterDeclarer != NULL) {
+ oPtr = miPtr->filterDeclarer->thisPtr;
+ type = "class";
+ } else {
+ oPtr = contextPtr->oPtr;
+ type = "object";
+ }
+
+ result[0] = TclOOObjectName(interp, oPtr);
+ result[1] = Tcl_NewStringObj(type, -1);
+ result[2] = miPtr->mPtr->namePtr;
+ Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
+ return TCL_OK;
+ }
+ case SELF_CALLER:
+ if ((framePtr->callerVarPtr == NULL) ||
+ !(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "caller is not an object", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ return TCL_ERROR;
+ } else {
+ CallContext *callerPtr = framePtr->callerVarPtr->clientData;
+ Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
+ Object *declarerPtr;
+
+ if (mPtr->declaringClassPtr != NULL) {
+ declarerPtr = mPtr->declaringClassPtr->thisPtr;
+ } else if (mPtr->declaringObjectPtr != NULL) {
+ declarerPtr = mPtr->declaringObjectPtr;
+ } else {
+ /*
+ * This should be unreachable code.
+ */
+
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method without declarer!", -1));
+ return TCL_ERROR;
+ }
+
+ result[0] = TclOOObjectName(interp, declarerPtr);
+ result[1] = TclOOObjectName(interp, callerPtr->oPtr);
+ if (callerPtr->callPtr->flags & CONSTRUCTOR) {
+ result[2] = declarerPtr->fPtr->constructorName;
+ } else if (callerPtr->callPtr->flags & DESTRUCTOR) {
+ result[2] = declarerPtr->fPtr->destructorName;
+ } else {
+ result[2] = mPtr->namePtr;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
+ return TCL_OK;
+ }
+ case SELF_NEXT:
+ if (contextPtr->index < contextPtr->callPtr->numChain-1) {
+ Method *mPtr =
+ contextPtr->callPtr->chain[contextPtr->index+1].mPtr;
+ Object *declarerPtr;
+
+ if (mPtr->declaringClassPtr != NULL) {
+ declarerPtr = mPtr->declaringClassPtr->thisPtr;
+ } else if (mPtr->declaringObjectPtr != NULL) {
+ declarerPtr = mPtr->declaringObjectPtr;
+ } else {
+ /*
+ * This should be unreachable code.
+ */
+
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method without declarer!", -1));
+ return TCL_ERROR;
+ }
+
+ result[0] = TclOOObjectName(interp, declarerPtr);
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ result[1] = declarerPtr->fPtr->constructorName;
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ result[1] = declarerPtr->fPtr->destructorName;
+ } else {
+ result[1] = mPtr->namePtr;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
+ }
+ return TCL_OK;
+ case SELF_TARGET:
+ if (!CurrentlyInvoked(contextPtr).isFilter) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "not inside a filtering context", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
+ return TCL_ERROR;
+ } else {
+ Method *mPtr;
+ Object *declarerPtr;
+ int i;
+
+ for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++){
+ if (!contextPtr->callPtr->chain[i].isFilter) {
+ break;
+ }
+ }
+ if (i == contextPtr->callPtr->numChain) {
+ Tcl_Panic("filtering call chain without terminal non-filter");
+ }
+ mPtr = contextPtr->callPtr->chain[i].mPtr;
+ if (mPtr->declaringClassPtr != NULL) {
+ declarerPtr = mPtr->declaringClassPtr->thisPtr;
+ } else if (mPtr->declaringObjectPtr != NULL) {
+ declarerPtr = mPtr->declaringObjectPtr;
+ } else {
+ /*
+ * This should be unreachable code.
+ */
+
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method without declarer!", -1));
+ return TCL_ERROR;
+ }
+ result[0] = TclOOObjectName(interp, declarerPtr);
+ result[1] = mPtr->namePtr;
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
+ return TCL_OK;
+ }
+ case SELF_CALL:
+ result[0] = TclOORenderCallChain(interp, contextPtr->callPtr);
+ result[1] = Tcl_NewIntObj(contextPtr->index);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
+ return TCL_OK;
+ }
+ return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * CopyObjectCmd --
+ *
+ * Implementation of the [oo::copy] command, which clones an object (but
+ * not its namespace). Note that no constructors are called during this
+ * process.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOCopyObjectCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Object oPtr, o2Ptr;
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "sourceName ?targetName?");
+ return TCL_ERROR;
+ }
+
+ oPtr = Tcl_GetObjectFromObj(interp, objv[1]);
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Create a cloned object of the correct class. Note that constructors are
+ * not called. Also note that we must resolve the object name ourselves
+ * because we do not want to create the object in the current namespace,
+ * but rather in the context of the namespace of the caller of the overall
+ * [oo::define] command.
+ */
+
+ if (objc == 2) {
+ o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL, NULL);
+ } else {
+ const char *name;
+ Tcl_DString buffer;
+
+ name = TclGetString(objv[2]);
+ Tcl_DStringInit(&buffer);
+ if (name[0]!=':' || name[1]!=':') {
+ Interp *iPtr = (Interp *) interp;
+
+ if (iPtr->varFramePtr != NULL) {
+ Tcl_DStringAppend(&buffer,
+ iPtr->varFramePtr->nsPtr->fullName, -1);
+ }
+ TclDStringAppendLiteral(&buffer, "::");
+ Tcl_DStringAppend(&buffer, name, -1);
+ name = Tcl_DStringValue(&buffer);
+ }
+ o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, NULL);
+ Tcl_DStringFree(&buffer);
+ }
+
+ if (o2Ptr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Return the name of the cloned object.
+ */
+
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) o2Ptr));
+ return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */