summaryrefslogtreecommitdiffstats
path: root/generic/tclOOBasic.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclOOBasic.c')
-rw-r--r--generic/tclOOBasic.c925
1 files changed, 925 insertions, 0 deletions
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
new file mode 100644
index 0000000..1cd07df
--- /dev/null
+++ b/generic/tclOOBasic.c
@@ -0,0 +1,925 @@
+/*
+ * tclOOBasic.c --
+ *
+ * This file contains implementations of the "simple" commands and
+ * methods from the object-system core.
+ *
+ * Copyright (c) 2005-2008 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.
+ *
+ * RCS: @(#) $Id: tclOOBasic.c,v 1.1 2008/05/31 11:42:17 dkf Exp $
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+#include "tclInt.h"
+#include "tclOOInt.h"
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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);
+ Tcl_Object newObject;
+ 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_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
+ "\" is not a class", 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_AppendResult(interp, "object name must not be empty", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the object and return its name.
+ */
+
+ newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
+ objName, NULL, objc, objv,
+ Tcl_ObjectContextSkippedArgs(context)+1);
+ if (newObject == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) newObject));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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);
+ Tcl_Object newObject;
+ 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_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
+ "\" is not a class", 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_AppendResult(interp, "object name must not be empty", NULL);
+ return TCL_ERROR;
+ }
+ nsName = Tcl_GetStringFromObj(
+ objv[Tcl_ObjectContextSkippedArgs(context)+1], &len);
+ if (len == 0) {
+ Tcl_AppendResult(interp, "namespace name must not be empty", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the object and return its name.
+ */
+
+ newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
+ objName, nsName, objc, objv,
+ Tcl_ObjectContextSkippedArgs(context)+2);
+ if (newObject == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) newObject));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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);
+ Tcl_Object newObject;
+
+ /*
+ * 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_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
+ "\" is not a class", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the object and return its name.
+ */
+
+ newObject = Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
+ NULL, NULL, objc, objv, Tcl_ObjectContextSkippedArgs(context));
+ if (newObject == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) newObject));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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. */
+{
+ if (objc != Tcl_ObjectContextSkippedArgs(context)) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
+ Tcl_DeleteCommandFromToken(interp,
+ Tcl_GetObjectCommand(Tcl_ObjectContextObject(context)));
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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);
+ CallFrame *framePtr, **framePtrPtr;
+ Tcl_Obj *objnameObj;
+ int result;
+
+ if (objc-1 < Tcl_ObjectContextSkippedArgs(context)) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "arg ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make the object's namespace the current namespace and evaluate the
+ * command(s).
+ */
+
+ /* This is needed to satisfy GCC 3.3's strict aliasing rules */
+ framePtrPtr = &framePtr;
+ 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) {
+ objnameObj = TclOOObjectName(interp, (Object *) object);
+ } else {
+ objnameObj = Tcl_NewStringObj("my", 2);
+ }
+ Tcl_IncrRefCount(objnameObj);
+
+ if (objc == Tcl_ObjectContextSkippedArgs(context)+1) {
+ result = Tcl_EvalObjEx(interp,
+ objv[Tcl_ObjectContextSkippedArgs(context)], 0);
+ } else {
+ Tcl_Obj *objPtr;
+
+ /*
+ * More than one argument: 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.
+ */
+
+ objPtr = Tcl_ConcatObj(objc-Tcl_ObjectContextSkippedArgs(context),
+ objv+Tcl_ObjectContextSkippedArgs(context));
+ result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
+ }
+
+ if (result == TCL_ERROR) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (in \"%s eval\" script line %d)",
+ TclGetString(objnameObj), interp->errorLine));
+ }
+
+ /*
+ * Restore the previous "current" namespace.
+ */
+
+ TclPopStackFrame(interp);
+ Tcl_DecrRefCount(objnameObj);
+ 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);
+
+ if (objc < skip+1) {
+ Tcl_WrongNumArgs(interp, skip, objv, "methodName ?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);
+
+ Tcl_AppendResult(interp, "object \"", TclGetString(tmpBuf), NULL);
+ if (contextPtr->callPtr->flags & PUBLIC_METHOD) {
+ Tcl_AppendResult(interp, "\" has no visible methods", NULL);
+ } else {
+ Tcl_AppendResult(interp, "\" has no methods", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[skip]),
+ "\": must be ", NULL);
+ for (i=0 ; i<numMethodNames-1 ; i++) {
+ if (i) {
+ Tcl_AppendResult(interp, ", ", NULL);
+ }
+ Tcl_AppendResult(interp, methodNames[i], NULL);
+ }
+ if (i) {
+ Tcl_AppendResult(interp, " or ", NULL);
+ }
+ Tcl_AppendResult(interp, methodNames[i], NULL);
+ ckfree((char *) methodNames);
+ 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) < 1) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "varName ?varName ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Do nothing if we are not called from the body of a method. In this
+ * respect, we are like the [global] command.
+ */
+
+ if (iPtr->varFramePtr == NULL ||
+ !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ 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_AppendResult(interp, "variable name \"", varName,
+ "\" illegal: must not contain namespace separator", 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). We never have to worry
+ * about the case where we're dealing with the global namespace; we've
+ * already checked that we are inside a method.
+ */
+
+ 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");
+ 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) {
+ return TCL_ERROR;
+ }
+
+ varNamePtr = Tcl_NewObj();
+ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
+ Tcl_SetObjResult(interp, varNamePtr);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOONextObjCmd --
+ *
+ * Implementation of the [next] command. Note that this command is 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;
+ int result;
+
+ /*
+ * 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_AppendResult(interp, TclGetString(objv[0]),
+ " may only be called from inside a method", 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].
+ */
+
+ iPtr->varFramePtr = framePtr->callerVarPtr;
+ result = Tcl_ObjectContextInvokeNext(interp, context, objc, objv, 1);
+ iPtr->varFramePtr = framePtr;
+ 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 *subcmds[] = {
+ "caller", "class", "filter", "method", "namespace", "next", "object",
+ "target", NULL
+ };
+ enum SelfCmds {
+ 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;
+ 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_AppendResult(interp, TclGetString(objv[0]),
+ " may only be called from inside a method", 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: {
+ Method *mPtr = CurrentlyInvoked(contextPtr).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_AppendResult(interp, "method without declarer!", NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp, TclOOObjectName(interp, declarerPtr));
+ return TCL_OK;
+ }
+ case SELF_METHOD:
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ Tcl_AppendResult(interp, "<constructor>", NULL);
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ Tcl_AppendResult(interp, "<destructor>", NULL);
+ } else {
+ Tcl_SetObjResult(interp,
+ CurrentlyInvoked(contextPtr).mPtr->namePtr);
+ }
+ return TCL_OK;
+ case SELF_FILTER:
+ if (!CurrentlyInvoked(contextPtr).isFilter) {
+ Tcl_AppendResult(interp, "not inside a filtering context", NULL);
+ return TCL_ERROR;
+ } else {
+ register struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
+ Tcl_Obj *result[3];
+ 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)) {
+ 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_AppendResult(interp, "method without declarer!", NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ TclOOObjectName(interp, declarerPtr));
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ TclOOObjectName(interp, callerPtr->oPtr));
+ if (callerPtr->callPtr->flags & CONSTRUCTOR) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj("<constructor>", -1));
+ } else if (callerPtr->callPtr->flags & DESTRUCTOR) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj("<destructor>", -1));
+ } else {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ mPtr->namePtr);
+ }
+ return TCL_OK;
+ } else {
+ Tcl_AppendResult(interp, "caller is not an object", NULL);
+ return TCL_ERROR;
+ }
+ 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_AppendResult(interp, "method without declarer!", NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ TclOOObjectName(interp, declarerPtr));
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj("<constructor>", -1));
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_NewStringObj("<destructor>", -1));
+ } else {
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ mPtr->namePtr);
+ }
+ }
+ return TCL_OK;
+ case SELF_TARGET:
+ if (!CurrentlyInvoked(contextPtr).isFilter) {
+ Tcl_AppendResult(interp, "not inside a filtering 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_AppendResult(interp, "method without declarer!", NULL);
+ return TCL_ERROR;
+ }
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ TclOOObjectName(interp, declarerPtr));
+ Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ mPtr->namePtr);
+ 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 {
+ 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);
+ }
+ Tcl_DStringAppend(&buffer, "::", 2);
+ 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:
+ */