summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog12
-rw-r--r--generic/tclOOBasic.c55
-rw-r--r--generic/tclOOInfo.c273
3 files changed, 152 insertions, 188 deletions
diff --git a/ChangeLog b/ChangeLog
index 8c71580..5e772f7 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,4 +1,12 @@
-2008-10-4 Jan Nijtmans <nijtmans@users.sf.net>
+2008-10-04 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclOOInfo.c (GetClassFromObj): Factor out the code to parse
+ a Tcl_Obj and get a class. Also make result handling hygienic.
+ * generic/tclOOBasic.c (TclOOSelfObjCmd): Better hygiene of results,
+ and stop allocating quite so much memory by sharing special "method"
+ names.
+
+2008-10-04 Jan Nijtmans <nijtmans@users.sf.net>
* doc/Hash.3: CONSTified the typePtr argument
* generic/tcl.decls: of Tcl_InitCustomHashTable.
@@ -8,8 +16,6 @@
* generic/tclDecls.h: regenerated
This change complies with TIP #27.
-2008-10-4 Jan Nijtmans <nijtmans@users.sf.net>
-
* doc/GetIndex.3: CONSTified the tablePtr argument
* generic/tcl.decls: of Tcl_GetIndexFromObj.
* generic/tclIndexObj.c
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 2e3868d..2d224dd 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -9,7 +9,7 @@
* 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.11 2008/09/26 20:16:39 dgp Exp $
+ * RCS: @(#) $Id: tclOOBasic.c,v 1.12 2008/10/04 12:00:25 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -761,9 +761,9 @@ TclOOSelfObjCmd(
}
case SELF_METHOD:
if (contextPtr->callPtr->flags & CONSTRUCTOR) {
- Tcl_AppendResult(interp, "<constructor>", NULL);
+ Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->constructorName);
} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
- Tcl_AppendResult(interp, "<destructor>", NULL);
+ Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->destructorName);
} else {
Tcl_SetObjResult(interp,
CurrentlyInvoked(contextPtr).mPtr->namePtr);
@@ -794,11 +794,15 @@ TclOOSelfObjCmd(
return TCL_OK;
}
case SELF_CALLER:
- if ((framePtr->callerVarPtr != NULL) &&
- (framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ if ((framePtr->callerVarPtr == NULL) ||
+ !(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){
+ Tcl_AppendResult(interp, "caller is not an object", NULL);
+ return TCL_ERROR;
+ } else {
CallContext *callerPtr = framePtr->callerVarPtr->clientData;
Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
Object *declarerPtr;
+ Tcl_Obj *result[3];
if (mPtr->declaringClassPtr != NULL) {
declarerPtr = mPtr->declaringClassPtr->thisPtr;
@@ -813,30 +817,24 @@ TclOOSelfObjCmd(
return TCL_ERROR;
}
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- TclOOObjectName(interp, declarerPtr));
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- TclOOObjectName(interp, callerPtr->oPtr));
+ result[0] = TclOOObjectName(interp, declarerPtr);
+ result[1] = TclOOObjectName(interp, callerPtr->oPtr);
if (callerPtr->callPtr->flags & CONSTRUCTOR) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj("<constructor>", -1));
+ result[2] = declarerPtr->fPtr->constructorName;
} else if (callerPtr->callPtr->flags & DESTRUCTOR) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj("<destructor>", -1));
+ result[2] = declarerPtr->fPtr->destructorName;
} else {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- mPtr->namePtr);
+ result[2] = mPtr->namePtr;
}
+ Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
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;
+ Tcl_Obj *result[2];
if (mPtr->declaringClassPtr != NULL) {
declarerPtr = mPtr->declaringClassPtr->thisPtr;
@@ -851,18 +849,15 @@ TclOOSelfObjCmd(
return TCL_ERROR;
}
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- TclOOObjectName(interp, declarerPtr));
+ result[0] = TclOOObjectName(interp, declarerPtr);
if (contextPtr->callPtr->flags & CONSTRUCTOR) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj("<constructor>", -1));
+ result[1] = declarerPtr->fPtr->constructorName;
} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- Tcl_NewStringObj("<destructor>", -1));
+ result[1] = declarerPtr->fPtr->destructorName;
} else {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- mPtr->namePtr);
+ result[1] = mPtr->namePtr;
}
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
}
return TCL_OK;
case SELF_TARGET:
@@ -872,6 +867,7 @@ TclOOSelfObjCmd(
} else {
Method *mPtr;
Object *declarerPtr;
+ Tcl_Obj *result[2];
int i;
for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++){
@@ -895,10 +891,9 @@ TclOOSelfObjCmd(
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);
+ result[0] = TclOOObjectName(interp, declarerPtr);
+ result[1] = mPtr->namePtr;
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
return TCL_OK;
}
}
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index 41d90a4..ee19373 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOOInfo.c,v 1.7 2008/09/23 05:05:54 dkf Exp $
+ * RCS: @(#) $Id: tclOOInfo.c,v 1.8 2008/10/04 12:00:25 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -18,6 +18,7 @@
#include "tclInt.h"
#include "tclOOInt.h"
+static inline Class * GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
static Tcl_ObjCmdProc InfoObjectClassCmd;
static Tcl_ObjCmdProc InfoObjectDefnCmd;
static Tcl_ObjCmdProc InfoObjectFiltersCmd;
@@ -149,6 +150,35 @@ TclOOInitInfo(
/*
* ----------------------------------------------------------------------
*
+ * GetClassFromObj --
+ *
+ * How to correctly get a class from a Tcl_Obj. Just a wrapper round
+ * Tcl_GetObjectFromObj, but this is an idiom that was used heavily.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline Class *
+GetClassFromObj(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr)
+{
+ Object *oPtr = (Object *) Tcl_GetObjectFromObj(interp, objPtr);
+
+ if (oPtr == NULL) {
+ return NULL;
+ }
+ if (oPtr->classPtr == NULL) {
+ Tcl_AppendResult(interp, "\"", TclGetString(objPtr),
+ "\" is not a class", NULL);
+ return NULL;
+ }
+ return oPtr->classPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* InfoObjectClassCmd --
*
* Implements [info object class $objName ?$className?]
@@ -227,7 +257,7 @@ InfoObjectDefnCmd(
Tcl_HashEntry *hPtr;
Proc *procPtr;
CompiledLocal *localPtr;
- Tcl_Obj *argsObj;
+ Tcl_Obj *resultObjs[2];
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "objName methodName");
@@ -256,7 +286,7 @@ InfoObjectDefnCmd(
return TCL_ERROR;
}
- argsObj = Tcl_NewObj();
+ resultObjs[0] = Tcl_NewObj();
for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
localPtr=localPtr->nextPtr) {
if (TclIsVarArgument(localPtr)) {
@@ -268,12 +298,11 @@ InfoObjectDefnCmd(
if (localPtr->defValuePtr != NULL) {
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
}
- Tcl_ListObjAppendElement(NULL, argsObj, argObj);
+ Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
}
}
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- TclOOGetMethodBody(Tcl_GetHashValue(hPtr)));
+ resultObjs[1] = TclOOGetMethodBody(Tcl_GetHashValue(hPtr));
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
return TCL_OK;
}
@@ -295,7 +324,7 @@ InfoObjectFiltersCmd(
Tcl_Obj *const objv[])
{
int i;
- Tcl_Obj *filterObj;
+ Tcl_Obj *filterObj, *resultObj;
Object *oPtr;
if (objc != 2) {
@@ -307,10 +336,12 @@ InfoObjectFiltersCmd(
if (oPtr == NULL) {
return TCL_ERROR;
}
+ resultObj = Tcl_NewObj();
FOREACH(filterObj, oPtr->filters) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj);
+ Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
}
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
@@ -507,7 +538,7 @@ InfoObjectMethodsCmd(
Object *oPtr;
int flag = PUBLIC_METHOD, recurse = 0;
FOREACH_HASH_DECLS;
- Tcl_Obj *namePtr;
+ Tcl_Obj *namePtr, *resultObj;
Method *mPtr;
static const char *options[] = {
"-all", "-localprivate", "-private", NULL
@@ -546,28 +577,24 @@ InfoObjectMethodsCmd(
}
}
+ resultObj = Tcl_NewObj();
if (recurse) {
const char **names;
int i, numNames = TclOOGetSortedMethodList(oPtr, flag, &names);
- Tcl_Obj *resultObj = Tcl_NewObj();
for (i=0 ; i<numNames ; i++) {
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(names[i], -1));
}
ckfree((char *) names);
- Tcl_SetObjResult(interp, resultObj);
- return TCL_OK;
- }
-
- if (oPtr->methodsPtr) {
+ } else if (oPtr->methodsPtr) {
FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- namePtr);
+ Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
}
}
}
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
@@ -590,6 +617,7 @@ InfoObjectMixinsCmd(
{
Class *mixinPtr;
Object *oPtr;
+ Tcl_Obj *resultObj;
int i;
if (objc != 2) {
@@ -601,10 +629,12 @@ InfoObjectMixinsCmd(
return TCL_ERROR;
}
+ resultObj = Tcl_NewObj();
FOREACH(mixinPtr, oPtr->mixins) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_ListObjAppendElement(NULL, resultObj,
TclOOObjectName(interp, mixinPtr->thisPtr));
}
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
@@ -626,7 +656,7 @@ InfoObjectVariablesCmd(
Tcl_Obj *const objv[])
{
Object *oPtr;
- Tcl_Obj *variableObj;
+ Tcl_Obj *variableObj, *resultObj;
int i;
if (objc != 2) {
@@ -638,9 +668,11 @@ InfoObjectVariablesCmd(
return TCL_ERROR;
}
+ resultObj = Tcl_NewObj();
FOREACH(variableObj, oPtr->variables) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), variableObj);
+ Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
}
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
@@ -724,25 +756,17 @@ InfoClassConstrCmd(
{
Proc *procPtr;
CompiledLocal *localPtr;
- Tcl_Obj *argsObj;
- Object *oPtr;
+ Tcl_Obj *resultObjs[2];
Class *clsPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
- oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
- "\" is not a class", NULL);
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
return TCL_ERROR;
}
- clsPtr = oPtr->classPtr;
-
if (clsPtr->constructorPtr == NULL) {
return TCL_OK;
}
@@ -753,7 +777,7 @@ InfoClassConstrCmd(
return TCL_ERROR;
}
- argsObj = Tcl_NewObj();
+ resultObjs[0] = Tcl_NewObj();
for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
localPtr=localPtr->nextPtr) {
if (TclIsVarArgument(localPtr)) {
@@ -765,12 +789,11 @@ InfoClassConstrCmd(
if (localPtr->defValuePtr != NULL) {
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
}
- Tcl_ListObjAppendElement(NULL, argsObj, argObj);
+ Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
}
}
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- TclOOGetMethodBody(clsPtr->constructorPtr));
+ resultObjs[1] = TclOOGetMethodBody(clsPtr->constructorPtr);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
return TCL_OK;
}
@@ -794,25 +817,17 @@ InfoClassDefnCmd(
Tcl_HashEntry *hPtr;
Proc *procPtr;
CompiledLocal *localPtr;
- Tcl_Obj *argsObj;
- Object *oPtr;
+ Tcl_Obj *resultObjs[2];
Class *clsPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
return TCL_ERROR;
}
- oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
- if (oPtr == NULL) {
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
return TCL_ERROR;
}
- if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
- "\" is not a class", NULL);
- return TCL_ERROR;
- }
- clsPtr = oPtr->classPtr;
-
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
if (hPtr == NULL) {
Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
@@ -826,7 +841,7 @@ InfoClassDefnCmd(
return TCL_ERROR;
}
- argsObj = Tcl_NewObj();
+ resultObjs[0] = Tcl_NewObj();
for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
localPtr=localPtr->nextPtr) {
if (TclIsVarArgument(localPtr)) {
@@ -838,12 +853,11 @@ InfoClassDefnCmd(
if (localPtr->defValuePtr != NULL) {
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
}
- Tcl_ListObjAppendElement(NULL, argsObj, argObj);
+ Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
}
}
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), argsObj);
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
- TclOOGetMethodBody(Tcl_GetHashValue(hPtr)));
+ resultObjs[1] = TclOOGetMethodBody(Tcl_GetHashValue(hPtr));
+ Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
return TCL_OK;
}
@@ -865,24 +879,13 @@ InfoClassDestrCmd(
Tcl_Obj *const objv[])
{
Proc *procPtr;
- Object *oPtr;
Class *clsPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
- oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
- "\" is not a class", NULL);
- return TCL_ERROR;
- }
- clsPtr = oPtr->classPtr;
-
+ clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr->destructorPtr == NULL) {
return TCL_OK;
}
@@ -915,28 +918,23 @@ InfoClassFiltersCmd(
Tcl_Obj *const objv[])
{
int i;
- Tcl_Obj *filterObj;
- Object *oPtr;
+ Tcl_Obj *filterObj, *resultObj;
Class *clsPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
- oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
- "\" is not a class", NULL);
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
return TCL_ERROR;
}
- clsPtr = oPtr->classPtr;
+ resultObj = Tcl_NewObj();
FOREACH(filterObj, clsPtr->filters) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj);
+ Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
}
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
@@ -959,24 +957,16 @@ InfoClassForwardCmd(
{
Tcl_HashEntry *hPtr;
Tcl_Obj *prefixObj;
- Object *oPtr;
Class *clsPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
return TCL_ERROR;
}
- oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
- "\" is not a class", NULL);
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
return TCL_ERROR;
}
- clsPtr = oPtr->classPtr;
-
hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]);
if (hPtr == NULL) {
Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]),
@@ -1016,33 +1006,30 @@ InfoClassInstancesCmd(
Class *clsPtr;
int i;
const char *pattern = NULL;
+ Tcl_Obj *resultObj;
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
return TCL_ERROR;
}
- oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
- if (oPtr == NULL) {
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
return TCL_ERROR;
}
- if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
- "\" is not a class", NULL);
- return TCL_ERROR;
- }
- clsPtr = oPtr->classPtr;
if (objc == 3) {
pattern = TclGetString(objv[2]);
}
+ resultObj = Tcl_NewObj();
FOREACH(oPtr, clsPtr->instances) {
Tcl_Obj *tmpObj = TclOOObjectName(interp, oPtr);
if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
continue;
}
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+ Tcl_ListObjAppendElement(NULL, resultObj, tmpObj);
}
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
@@ -1064,10 +1051,8 @@ InfoClassMethodsCmd(
Tcl_Obj *const objv[])
{
int flag = PUBLIC_METHOD, recurse = 0;
- FOREACH_HASH_DECLS;
- Tcl_Obj *namePtr;
+ Tcl_Obj *namePtr, *resultObj;
Method *mPtr;
- Object *oPtr;
Class *clsPtr;
static const char *options[] = {
"-all", "-localprivate", "-private", NULL
@@ -1080,16 +1065,10 @@ InfoClassMethodsCmd(
Tcl_WrongNumArgs(interp, 1, objv, "className ?-option value ...?");
return TCL_ERROR;
}
- oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
- "\" is not a class", NULL);
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
return TCL_ERROR;
}
- clsPtr = oPtr->classPtr;
if (objc != 2) {
int i, idx;
@@ -1112,25 +1091,26 @@ InfoClassMethodsCmd(
}
}
+ resultObj = Tcl_NewObj();
if (recurse) {
const char **names;
int i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names);
- Tcl_Obj *resultObj = Tcl_NewObj();
for (i=0 ; i<numNames ; i++) {
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(names[i], -1));
}
ckfree((char *) names);
- Tcl_SetObjResult(interp, resultObj);
- return TCL_OK;
- }
+ } else {
+ FOREACH_HASH_DECLS;
- FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
- if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), namePtr);
+ FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
+ if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
+ Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
+ }
}
}
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
@@ -1151,29 +1131,25 @@ InfoClassMixinsCmd(
int objc,
Tcl_Obj *const objv[])
{
- Object *oPtr;
Class *clsPtr, *mixinPtr;
+ Tcl_Obj *resultObj;
int i;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
- oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
- if (oPtr == NULL) {
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
return TCL_ERROR;
}
- if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
- "\" is not a class", NULL);
- return TCL_ERROR;
- }
- clsPtr = oPtr->classPtr;
+ resultObj = Tcl_NewObj();
FOREACH(mixinPtr, clsPtr->mixins) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_ListObjAppendElement(NULL, resultObj,
TclOOObjectName(interp, mixinPtr->thisPtr));
}
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
@@ -1194,8 +1170,8 @@ InfoClassSubsCmd(
int objc,
Tcl_Obj *const objv[])
{
- Object *oPtr;
Class *clsPtr, *subclassPtr;
+ Tcl_Obj *resultObj;
int i;
const char *pattern = NULL;
@@ -1203,27 +1179,22 @@ InfoClassSubsCmd(
Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
return TCL_ERROR;
}
- oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
- "\" is not a class", NULL);
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
return TCL_ERROR;
}
- clsPtr = oPtr->classPtr;
if (objc == 3) {
pattern = TclGetString(objv[2]);
}
+ resultObj = Tcl_NewObj();
FOREACH(subclassPtr, clsPtr->subclasses) {
Tcl_Obj *tmpObj = TclOOObjectName(interp, subclassPtr->thisPtr);
if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
continue;
}
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+ Tcl_ListObjAppendElement(NULL, resultObj, tmpObj);
}
FOREACH(subclassPtr, clsPtr->mixinSubs) {
Tcl_Obj *tmpObj = TclOOObjectName(interp, subclassPtr->thisPtr);
@@ -1231,8 +1202,9 @@ InfoClassSubsCmd(
if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) {
continue;
}
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj);
+ Tcl_ListObjAppendElement(NULL, resultObj, tmpObj);
}
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
@@ -1253,29 +1225,25 @@ InfoClassSupersCmd(
int objc,
Tcl_Obj *const objv[])
{
- Object *oPtr;
Class *clsPtr, *superPtr;
+ Tcl_Obj *resultObj;
int i;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
- oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
- "\" is not a class", NULL);
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
return TCL_ERROR;
}
- clsPtr = oPtr->classPtr;
+ resultObj = Tcl_NewObj();
FOREACH(superPtr, clsPtr->superclasses) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp),
+ Tcl_ListObjAppendElement(NULL, resultObj,
TclOOObjectName(interp, superPtr->thisPtr));
}
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
@@ -1296,29 +1264,24 @@ InfoClassVariablesCmd(
int objc,
Tcl_Obj *const objv[])
{
- Object *oPtr;
Class *clsPtr;
- Tcl_Obj *variableObj;
+ Tcl_Obj *variableObj, *resultObj;
int i;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className");
return TCL_ERROR;
}
- oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
- "\" is not a class", NULL);
+ clsPtr = GetClassFromObj(interp, objv[1]);
+ if (clsPtr == NULL) {
return TCL_ERROR;
}
- clsPtr = oPtr->classPtr;
+ resultObj = Tcl_NewObj();
FOREACH(variableObj, clsPtr->variables) {
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), variableObj);
+ Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
}
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}