summaryrefslogtreecommitdiffstats
path: root/generic/tclOOBasic.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclOOBasic.c')
-rw-r--r--generic/tclOOBasic.c194
1 files changed, 114 insertions, 80 deletions
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index a3cccc7..aa9d8dd 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -56,7 +56,7 @@ FinalizeConstruction(
Tcl_Interp *interp,
int result)
{
- Object *oPtr = (Object *)data[0];
+ Object *oPtr = (Object *) data[0];
if (result != TCL_OK) {
return result;
@@ -87,11 +87,11 @@ TclOO_Class_Constructor(
Tcl_Obj **invoke, *nameObj;
size_t skip = Tcl_ObjectContextSkippedArgs(context);
- if ((size_t)objc > skip + 1) {
+ if ((size_t) objc > skip + 1) {
Tcl_WrongNumArgs(interp, skip, objv,
"?definitionScript?");
return TCL_ERROR;
- } else if ((size_t)objc == skip) {
+ } else if ((size_t) objc == skip) {
return TCL_OK;
}
@@ -100,17 +100,17 @@ TclOO_Class_Constructor(
* here (and the class definition delegate doesn't run any constructors).
*/
- nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1);
- Tcl_AppendToObj(nameObj, ":: oo ::delegate", -1);
+ nameObj = Tcl_ObjPrintf("%s:: oo ::delegate",
+ oPtr->namespacePtr->fullName);
Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
TclGetString(nameObj), NULL, -1, NULL, -1);
- Tcl_DecrRefCount(nameObj);
+ Tcl_BounceRefCount(nameObj);
/*
* Delegate to [oo::define] to do the work.
*/
- invoke = (Tcl_Obj **)Tcl_Alloc(3 * sizeof(Tcl_Obj *));
+ invoke = (Tcl_Obj **) TclStackAlloc(interp, 3 * sizeof(Tcl_Obj *));
invoke[0] = oPtr->fPtr->defineName;
invoke[1] = TclOOObjectName(interp, oPtr);
invoke[2] = objv[objc-1];
@@ -140,8 +140,8 @@ DecrRefsPostClassConstructor(
Tcl_Interp *interp,
int result)
{
- Tcl_Obj **invoke = (Tcl_Obj **)data[0];
- Object *oPtr = (Object *)data[1];
+ Tcl_Obj **invoke = (Tcl_Obj **) data[0];
+ Object *oPtr = (Object *) data[1];
Tcl_InterpState saved;
int code;
@@ -156,7 +156,7 @@ DecrRefsPostClassConstructor(
code = Tcl_EvalObjv(interp, 2, invoke, 0);
TclDecrRefCount(invoke[0]);
TclDecrRefCount(invoke[1]);
- Tcl_Free(invoke);
+ TclStackFree(interp, invoke);
if (code != TCL_OK) {
Tcl_DiscardInterpState(saved);
return code;
@@ -368,7 +368,7 @@ TclOO_Object_Destroy(
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
CallContext *contextPtr;
- if (objc != (int)Tcl_ObjectContextSkippedArgs(context)) {
+ if (objc != (int) Tcl_ObjectContextSkippedArgs(context)) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
return TCL_ERROR;
@@ -398,7 +398,7 @@ AfterNRDestructor(
Tcl_Interp *interp,
int result)
{
- CallContext *contextPtr = (CallContext *)data[0];
+ CallContext *contextPtr = (CallContext *) data[0];
if (contextPtr->oPtr->command) {
Tcl_DeleteCommandFromToken(interp, contextPtr->oPtr->command);
@@ -433,7 +433,7 @@ TclOO_Object_Eval(
Tcl_Obj *scriptPtr;
CmdFrame *invoker;
- if ((size_t)objc < skip + 1) {
+ if ((size_t) objc < skip + 1) {
Tcl_WrongNumArgs(interp, skip, objv, "arg ?arg ...?");
return TCL_ERROR;
}
@@ -462,7 +462,7 @@ TclOO_Object_Eval(
* object when it decrements its refcount after eval'ing it.
*/
- if ((size_t)objc != skip+1) {
+ if ((size_t) objc != skip+1) {
scriptPtr = Tcl_ConcatObj(objc-skip, objv+skip);
invoker = NULL;
} else {
@@ -486,7 +486,7 @@ FinalizeEval(
int result)
{
if (result == TCL_ERROR) {
- Object *oPtr = (Object *)data[0];
+ Object *oPtr = (Object *) data[0];
const char *namePtr;
if (oPtr) {
@@ -544,7 +544,7 @@ TclOO_Object_Unknown(
* name without an error).
*/
- if ((size_t)objc < skip+1) {
+ if ((size_t) objc < skip + 1) {
Tcl_WrongNumArgs(interp, skip, objv, "method ?arg ...?");
return TCL_ERROR;
}
@@ -555,7 +555,7 @@ TclOO_Object_Unknown(
*/
if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
- CallContext *callerContext = (CallContext *)framePtr->clientData;
+ CallContext *callerContext = (CallContext *) framePtr->clientData;
Method *mPtr = callerContext->callPtr->chain[
callerContext->index].mPtr;
@@ -609,7 +609,7 @@ TclOO_Object_Unknown(
Tcl_AppendToObj(errorMsg, " or ", -1);
}
Tcl_AppendToObj(errorMsg, methodNames[i], -1);
- Tcl_Free((void *)methodNames);
+ Tcl_Free((void *) methodNames);
Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[skip]), (char *)NULL);
@@ -721,34 +721,27 @@ TclOO_Object_LinkVar(
/*
* ----------------------------------------------------------------------
*
- * TclOO_Object_VarName --
+ * TclOOLookupObjectVar --
*
- * Implementation of the oo::object->varname method.
+ * Look up a variable in an object. Tricky because of private variables.
+ *
+ * Returns:
+ * Handle to the variable if it can be found, or NULL if there's an error.
*
* ----------------------------------------------------------------------
*/
-
-int
-TclOO_Object_VarName(
- TCL_UNUSED(void *),
- 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. */
+Tcl_Var
+TclOOLookupObjectVar(
+ Tcl_Interp *interp,
+ Tcl_Object object, /* Object we're looking up within. */
+ Tcl_Obj *varName, /* User-visible name we're looking up. */
+ Tcl_Var *aryPtr) /* Where to write the handle to the array
+ * containing the element; if not an element,
+ * then the variable this points to is set to
+ * NULL. */
{
- Var *varPtr, *aryVar;
- Tcl_Obj *varNamePtr, *argPtr;
- CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
- const char *arg;
-
- if ((int)Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
- Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
- "varName");
- return TCL_ERROR;
- }
- argPtr = objv[objc-1];
- arg = TclGetString(argPtr);
+ const char *arg = TclGetString(varName);
+ Tcl_Obj *varNamePtr;
/*
* Convert the variable name to fully-qualified form if it wasn't already.
@@ -760,10 +753,10 @@ TclOO_Object_VarName(
*/
if (arg[0] == ':' && arg[1] == ':') {
- varNamePtr = argPtr;
+ varNamePtr = varName;
} else {
- Tcl_Namespace *namespacePtr =
- Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
+ Tcl_Namespace *namespacePtr = Tcl_GetObjectNamespace(object);
+ CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
/*
* Private method handling. [TIP 500]
@@ -776,8 +769,8 @@ TclOO_Object_VarName(
*/
if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
- Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
- CallContext *callerContext = (CallContext *)framePtr->clientData;
+ Object *oPtr = (Object *) object;
+ CallContext *callerContext = (CallContext *) framePtr->clientData;
Method *mPtr = callerContext->callPtr->chain[
callerContext->index].mPtr;
PrivateVariableMapping *pvPtr;
@@ -785,9 +778,9 @@ TclOO_Object_VarName(
if (mPtr->declaringObjectPtr == oPtr) {
FOREACH_STRUCT(pvPtr, oPtr->privateVariables) {
- if (!strcmp(TclGetString(pvPtr->variableObj),
- TclGetString(argPtr))) {
- argPtr = pvPtr->fullNameObj;
+ if (!TclStringCmp(pvPtr->variableObj, varName, 1, 0,
+ TCL_INDEX_NONE)) {
+ varName = pvPtr->fullNameObj;
break;
}
}
@@ -807,9 +800,9 @@ TclOO_Object_VarName(
}
if (isInstance) {
FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) {
- if (!strcmp(TclGetString(pvPtr->variableObj),
- TclGetString(argPtr))) {
- argPtr = pvPtr->fullNameObj;
+ if (!TclStringCmp(pvPtr->variableObj, varName, 1, 0,
+ TCL_INDEX_NONE)) {
+ varName = pvPtr->fullNameObj;
break;
}
}
@@ -817,23 +810,69 @@ TclOO_Object_VarName(
}
}
- varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1);
- Tcl_AppendToObj(varNamePtr, "::", 2);
- Tcl_AppendObjToObj(varNamePtr, argPtr);
+ // The namespace isn't the global one; necessarily true for any object!
+ varNamePtr = Tcl_ObjPrintf("%s::%s",
+ namespacePtr->fullName, TclGetString(varName));
}
Tcl_IncrRefCount(varNamePtr);
- varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
- TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, &aryVar);
+ Tcl_Var var = (Tcl_Var) TclObjLookupVar(interp, varNamePtr, NULL,
+ TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1,
+ (Var **) aryPtr);
Tcl_DecrRefCount(varNamePtr);
+ if (var == NULL) {
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, (void *) NULL);
+ } else if (*aryPtr == NULL && TclIsVarArrayElement((Var *) var)) {
+ /*
+ * If the varPtr points to an element of an array but we don't already
+ * have the array, find it now. Note that this can't be easily
+ * backported; the arrayPtr field is new in Tcl 9.0. [Bug 2da1cb0c80]
+ */
+ *aryPtr = (Tcl_Var) TclVarParentArray(var);
+ }
+
+ return var;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOO_Object_VarName --
+ *
+ * Implementation of the oo::object->varname method.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOO_Object_VarName(
+ TCL_UNUSED(void *),
+ 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. */
+{
+ Tcl_Var varPtr, aryVar;
+ Tcl_Obj *varNamePtr;
+
+ if ((int) Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "varName");
+ return TCL_ERROR;
+ }
+
+ varPtr = TclOOLookupObjectVar(interp, Tcl_ObjectContextObject(context),
+ objv[objc - 1], &aryVar);
if (varPtr == NULL) {
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, (char *)NULL);
return TCL_ERROR;
}
/*
* The variable reference must not disappear too soon. [Bug 74b6110204]
*/
- TclSetVarNamespaceVar(varPtr);
+ if (!TclIsVarArrayElement((Var *) varPtr)) {
+ TclSetVarNamespaceVar((Var *) varPtr);
+ }
/*
* Now that we've pinned down what variable we're really talking about
@@ -841,19 +880,13 @@ TclOO_Object_VarName(
*/
TclNewObj(varNamePtr);
- if (aryVar != NULL) {
- Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr);
- /*
- * WARNING! This code pokes inside the implementation of hash tables!
- */
-
- Tcl_AppendToObj(varNamePtr, "(", -1);
- Tcl_AppendObjToObj(varNamePtr, ((VarInHash *)
- varPtr)->entry.key.objPtr);
- Tcl_AppendToObj(varNamePtr, ")", -1);
+ if (aryVar != NULL) {
+ Tcl_GetVariableFullName(interp, aryVar, varNamePtr);
+ Tcl_AppendPrintfToObj(varNamePtr, "(%s)", Tcl_GetString(
+ VarHashGetKey(varPtr)));
} else {
- Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
+ Tcl_GetVariableFullName(interp, varPtr, varNamePtr);
}
Tcl_SetObjResult(interp, varNamePtr);
return TCL_OK;
@@ -895,7 +928,7 @@ TclOONextObjCmd(
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL);
return TCL_ERROR;
}
- context = (Tcl_ObjectContext)framePtr->clientData;
+ context = (Tcl_ObjectContext) framePtr->clientData;
/*
* Invoke the (advanced) method call context in the caller context. Note
@@ -935,7 +968,7 @@ TclOONextToObjCmd(
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL);
return TCL_ERROR;
}
- contextPtr = (CallContext *)framePtr->clientData;
+ contextPtr = (CallContext *) framePtr->clientData;
/*
* Sanity check the arguments; we need the first one to refer to a class.
@@ -949,7 +982,7 @@ TclOONextToObjCmd(
if (object == NULL) {
return TCL_ERROR;
}
- classPtr = ((Object *)object)->classPtr;
+ classPtr = ((Object *) object)->classPtr;
if (classPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not a class", TclGetString(objv[1])));
@@ -964,7 +997,7 @@ TclOONextToObjCmd(
*/
for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) {
- struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
+ MInvoke *miPtr = &contextPtr->callPtr->chain[i];
if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
/*
@@ -995,7 +1028,7 @@ TclOONextToObjCmd(
}
for (i=contextPtr->index ; i != TCL_INDEX_NONE ; i--) {
- struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
+ MInvoke *miPtr = &contextPtr->callPtr->chain[i];
if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -1020,9 +1053,9 @@ NextRestoreFrame(
int result)
{
Interp *iPtr = (Interp *) interp;
- CallContext *contextPtr = (CallContext *)data[1];
+ CallContext *contextPtr = (CallContext *) data[1];
- iPtr->varFramePtr = (CallFrame *)data[0];
+ iPtr->varFramePtr = (CallFrame *) data[0];
if (contextPtr != NULL) {
contextPtr->index = PTR2UINT(data[2]);
}
@@ -1075,7 +1108,7 @@ TclOOSelfObjCmd(
return TCL_ERROR;
}
- contextPtr = (CallContext*)framePtr->clientData;
+ contextPtr = (CallContext *) framePtr->clientData;
/*
* Now we do "conventional" argument parsing for a while. Note that no
@@ -1130,7 +1163,7 @@ TclOOSelfObjCmd(
Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (char *)NULL);
return TCL_ERROR;
} else {
- struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
+ MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
Object *oPtr;
const char *type;
@@ -1156,7 +1189,8 @@ TclOOSelfObjCmd(
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL);
return TCL_ERROR;
} else {
- CallContext *callerPtr = (CallContext *)framePtr->callerVarPtr->clientData;
+ CallContext *callerPtr = (CallContext *)
+ framePtr->callerVarPtr->clientData;
Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
Object *declarerPtr;
generated by cgit v0.12 at 2024-10-21 18:58:52 (GMT)