summaryrefslogtreecommitdiffstats
path: root/generic/tclOOBasic.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclOOBasic.c')
-rw-r--r--generic/tclOOBasic.c206
1 files changed, 118 insertions, 88 deletions
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 5e983fc..0b0516b 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -4,7 +4,7 @@
* This file contains implementations of the "simple" commands and
* methods from the object-system core.
*
- * Copyright (c) 2005-2011 by Donal K. Fellows
+ * Copyright (c) 2005-2013 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.
@@ -17,16 +17,11 @@
#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);
+static Tcl_NRPostProc AfterNRDestructor;
+static Tcl_NRPostProc DecrRefsPostClassConstructor;
+static Tcl_NRPostProc FinalizeConstruction;
+static Tcl_NRPostProc FinalizeEval;
+static Tcl_NRPostProc NextRestoreFrame;
/*
* ----------------------------------------------------------------------
@@ -88,7 +83,7 @@ TclOO_Class_Constructor(
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
- Tcl_Obj *invoke[3];
+ Tcl_Obj **invoke;
if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -102,6 +97,7 @@ TclOO_Class_Constructor(
* Delegate to [oo::define] to do the work.
*/
+ invoke = ckalloc(3 * sizeof(Tcl_Obj *));
invoke[0] = oPtr->fPtr->defineName;
invoke[1] = TclOOObjectName(interp, oPtr);
invoke[2] = objv[objc-1];
@@ -115,7 +111,7 @@ TclOO_Class_Constructor(
Tcl_IncrRefCount(invoke[1]);
Tcl_IncrRefCount(invoke[2]);
TclNRAddCallback(interp, DecrRefsPostClassConstructor,
- invoke[0], invoke[1], invoke[2], NULL);
+ invoke, NULL, NULL, NULL);
/*
* Tricky point: do not want the extra reported level in the Tcl stack
@@ -131,9 +127,12 @@ DecrRefsPostClassConstructor(
Tcl_Interp *interp,
int result)
{
- TclDecrRefCount((Tcl_Obj *) data[0]);
- TclDecrRefCount((Tcl_Obj *) data[1]);
- TclDecrRefCount((Tcl_Obj *) data[2]);
+ Tcl_Obj **invoke = data[0];
+
+ TclDecrRefCount(invoke[0]);
+ TclDecrRefCount(invoke[1]);
+ TclDecrRefCount(invoke[2]);
+ ckfree(invoke);
return result;
}
@@ -168,8 +167,8 @@ TclOO_Class_Create(
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
- Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
- "\" is not a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "object \"%s\" is not a class", TclGetString(cmdnameObj)));
Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
return TCL_ERROR;
}
@@ -186,7 +185,8 @@ TclOO_Class_Create(
objName = Tcl_GetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)], &len);
if (len == 0) {
- Tcl_AppendResult(interp, "object name must not be empty", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "object name must not be empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
return TCL_ERROR;
}
@@ -232,8 +232,8 @@ TclOO_Class_CreateNs(
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
- Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
- "\" is not a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "object \"%s\" is not a class", TclGetString(cmdnameObj)));
Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
return TCL_ERROR;
}
@@ -250,14 +250,16 @@ TclOO_Class_CreateNs(
objName = Tcl_GetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)], &len);
if (len == 0) {
- Tcl_AppendResult(interp, "object name must not be empty", NULL);
+ 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_AppendResult(interp, "namespace name must not be empty", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "namespace name must not be empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
return TCL_ERROR;
}
@@ -301,8 +303,8 @@ TclOO_Class_New(
if (oPtr->classPtr == NULL) {
Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
- Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
- "\" is not a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "object \"%s\" is not a class", TclGetString(cmdnameObj)));
Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
return TCL_ERROR;
}
@@ -504,6 +506,7 @@ TclOO_Object_Unknown(
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
@@ -529,31 +532,34 @@ TclOO_Object_Unknown(
if (numMethodNames == 0) {
Tcl_Obj *tmpBuf = TclOOObjectName(interp, oPtr);
+ const char *piece;
- Tcl_AppendResult(interp, "object \"", TclGetString(tmpBuf), NULL);
if (contextPtr->callPtr->flags & PUBLIC_METHOD) {
- Tcl_AppendResult(interp, "\" has no visible methods", NULL);
+ piece = "visible methods";
} else {
- Tcl_AppendResult(interp, "\" has no methods", NULL);
+ 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;
}
- Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[skip]),
- "\": must be ", NULL);
+ errorMsg = Tcl_ObjPrintf("unknown method \"%s\": must be ",
+ TclGetString(objv[skip]));
for (i=0 ; i<numMethodNames-1 ; i++) {
if (i) {
- Tcl_AppendResult(interp, ", ", NULL);
+ Tcl_AppendToObj(errorMsg, ", ", -1);
}
- Tcl_AppendResult(interp, methodNames[i], NULL);
+ Tcl_AppendToObj(errorMsg, methodNames[i], -1);
}
if (i) {
- Tcl_AppendResult(interp, " or ", NULL);
+ Tcl_AppendToObj(errorMsg, " or ", -1);
}
- Tcl_AppendResult(interp, methodNames[i], NULL);
+ 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;
@@ -609,8 +615,9 @@ TclOO_Object_LinkVar(
*/
if (strstr(varName, "::") != NULL) {
- Tcl_AppendResult(interp, "variable name \"", varName,
- "\" illegal: must not contain namespace separator", 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;
}
@@ -679,52 +686,51 @@ TclOO_Object_VarName(
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
- Interp *iPtr = (Interp *) interp;
Var *varPtr, *aryVar;
- Tcl_Obj *varNamePtr;
+ Tcl_Obj *varNamePtr, *argPtr;
+ const char *arg;
if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"varName");
return TCL_ERROR;
}
+ argPtr = objv[objc-1];
+ arg = Tcl_GetString(argPtr);
/*
- * 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).
+ * Convert the variable name to fully-qualified form if it wasn't already.
+ * This has to be done prior to lookup because we can run into problems
+ * with resolvers otherwise. [Bug 3603695]
+ *
+ * We still need to do the lookup; the variable could be linked to another
+ * variable and we want the target's name.
*/
- 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);
+ if (arg[0] == ':' && arg[1] == ':') {
+ varNamePtr = argPtr;
} else {
- Namespace *savedNsPtr;
-
- savedNsPtr = iPtr->varFramePtr->nsPtr;
- iPtr->varFramePtr->nsPtr = (Namespace *)
+ Tcl_Namespace *namespacePtr =
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;
- }
+ varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1);
+ Tcl_AppendToObj(varNamePtr, "::", 2);
+ Tcl_AppendObjToObj(varNamePtr, argPtr);
+ }
+ Tcl_IncrRefCount(varNamePtr);
+ varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
+ TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, &aryVar);
+ Tcl_DecrRefCount(varNamePtr);
if (varPtr == NULL) {
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE",
- TclGetString(objv[objc-1]), NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, NULL);
return TCL_ERROR;
}
+ /*
+ * Now that we've pinned down what variable we're really talking about
+ * (including traversing variable links), convert back to a name.
+ */
+
varNamePtr = Tcl_NewObj();
if (aryVar != NULL) {
Tcl_HashEntry *hPtr;
@@ -784,8 +790,9 @@ TclOONextObjCmd(
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
- Tcl_AppendResult(interp, TclGetString(objv[0]),
- " may only be called from inside a method", NULL);
+ 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;
}
@@ -796,7 +803,7 @@ TclOONextObjCmd(
* that this is like [uplevel 1] and not [eval].
*/
- TclNRAddCallback(interp, RestoreFrame, framePtr, NULL, NULL, NULL);
+ TclNRAddCallback(interp, NextRestoreFrame, framePtr, NULL,NULL,NULL);
iPtr->varFramePtr = framePtr->callerVarPtr;
return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1);
}
@@ -814,6 +821,7 @@ TclOONextToObjCmd(
CallContext *contextPtr;
int i;
Tcl_Object object;
+ const char *methodType;
/*
* Start with sanity checks on the calling context to make sure that we
@@ -822,8 +830,9 @@ TclOONextToObjCmd(
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
- Tcl_AppendResult(interp, TclGetString(objv[0]),
- " may only be called from inside a method", NULL);
+ 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;
}
@@ -843,8 +852,9 @@ TclOONextToObjCmd(
}
classPtr = ((Object *)object)->classPtr;
if (classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
- "\" is not a class", 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;
}
@@ -863,8 +873,8 @@ TclOONextToObjCmd(
* context. Note that this is like [uplevel 1] and not [eval].
*/
- TclNRAddCallback(interp, RestoreFrame, framePtr, contextPtr,
- INT2PTR(contextPtr->index), NULL);
+ TclNRAddCallback(interp, NextRestoreFrame, framePtr,
+ contextPtr, INT2PTR(contextPtr->index), NULL);
contextPtr->index = i-1;
iPtr->varFramePtr = framePtr->callerVarPtr;
return TclNRObjectContextInvokeNext(interp,
@@ -877,23 +887,35 @@ TclOONextToObjCmd(
* is on the chain but unreachable, or not on the chain at all.
*/
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ methodType = "constructor";
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ methodType = "destructor";
+ } else {
+ methodType = "method";
+ }
+
for (i=contextPtr->index ; i>=0 ; i--) {
struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
- Tcl_AppendResult(interp, "method implementation by \"",
- TclGetString(objv[1]), "\" not reachable from here",
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s implementation by \"%s\" not reachable from here",
+ methodType, TclGetString(objv[1])));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE",
NULL);
return TCL_ERROR;
}
}
- Tcl_AppendResult(interp, "method has no non-filter implementation by \"",
- TclGetString(objv[1]), "\"", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s has no non-filter implementation by \"%s\"",
+ methodType, TclGetString(objv[1])));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL);
return TCL_ERROR;
}
static int
-RestoreFrame(
+NextRestoreFrame(
ClientData data[],
Tcl_Interp *interp,
int result)
@@ -948,8 +970,9 @@ TclOOSelfObjCmd(
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
- Tcl_AppendResult(interp, TclGetString(objv[0]),
- " may only be called from inside a method", NULL);
+ 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;
}
@@ -983,7 +1006,8 @@ TclOOSelfObjCmd(
Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;
if (clsPtr == NULL) {
- Tcl_AppendResult(interp, "method not defined by a class", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method not defined by a class", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
return TCL_ERROR;
}
@@ -1003,7 +1027,8 @@ TclOOSelfObjCmd(
return TCL_OK;
case SELF_FILTER:
if (!CurrentlyInvoked(contextPtr).isFilter) {
- Tcl_AppendResult(interp, "not inside a filtering context", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "not inside a filtering context", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
return TCL_ERROR;
} else {
@@ -1028,7 +1053,8 @@ TclOOSelfObjCmd(
case SELF_CALLER:
if ((framePtr->callerVarPtr == NULL) ||
!(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){
- Tcl_AppendResult(interp, "caller is not an object", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "caller is not an object", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
} else {
@@ -1045,7 +1071,8 @@ TclOOSelfObjCmd(
* This should be unreachable code.
*/
- Tcl_AppendResult(interp, "method without declarer!", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method without declarer!", -1));
return TCL_ERROR;
}
@@ -1076,7 +1103,8 @@ TclOOSelfObjCmd(
* This should be unreachable code.
*/
- Tcl_AppendResult(interp, "method without declarer!", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method without declarer!", -1));
return TCL_ERROR;
}
@@ -1093,7 +1121,8 @@ TclOOSelfObjCmd(
return TCL_OK;
case SELF_TARGET:
if (!CurrentlyInvoked(contextPtr).isFilter) {
- Tcl_AppendResult(interp, "not inside a filtering context", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "not inside a filtering context", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
return TCL_ERROR;
} else {
@@ -1119,7 +1148,8 @@ TclOOSelfObjCmd(
* This should be unreachable code.
*/
- Tcl_AppendResult(interp, "method without declarer!", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "method without declarer!", -1));
return TCL_ERROR;
}
result[0] = TclOOObjectName(interp, declarerPtr);
@@ -1190,7 +1220,7 @@ TclOOCopyObjectCmd(
Tcl_DStringAppend(&buffer,
iPtr->varFramePtr->nsPtr->fullName, -1);
}
- Tcl_DStringAppend(&buffer, "::", 2);
+ TclDStringAppendLiteral(&buffer, "::");
Tcl_DStringAppend(&buffer, name, -1);
name = Tcl_DStringValue(&buffer);
}
generated by cgit v0.12 at 2025-10-25 19:43:31 (GMT)