diff options
Diffstat (limited to 'generic/tclOOInfo.c')
| -rw-r--r-- | generic/tclOOInfo.c | 793 |
1 files changed, 524 insertions, 269 deletions
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index bded40c..3217f98 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -4,12 +4,10 @@ * This file contains the implementation of the ::oo-related [info] * subcommands. * - * Copyright (c) 2006-2008 by Donal K. Fellows + * Copyright (c) 2006-2011 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: tclOOInfo.c,v 1.4 2008/05/31 11:42:18 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -18,14 +16,20 @@ #include "tclInt.h" #include "tclOOInt.h" +static inline Class * GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); +static Tcl_ObjCmdProc InfoObjectCallCmd; static Tcl_ObjCmdProc InfoObjectClassCmd; static Tcl_ObjCmdProc InfoObjectDefnCmd; static Tcl_ObjCmdProc InfoObjectFiltersCmd; static Tcl_ObjCmdProc InfoObjectForwardCmd; static Tcl_ObjCmdProc InfoObjectIsACmd; static Tcl_ObjCmdProc InfoObjectMethodsCmd; +static Tcl_ObjCmdProc InfoObjectMethodTypeCmd; static Tcl_ObjCmdProc InfoObjectMixinsCmd; +static Tcl_ObjCmdProc InfoObjectNsCmd; static Tcl_ObjCmdProc InfoObjectVarsCmd; +static Tcl_ObjCmdProc InfoObjectVariablesCmd; +static Tcl_ObjCmdProc InfoClassCallCmd; static Tcl_ObjCmdProc InfoClassConstrCmd; static Tcl_ObjCmdProc InfoClassDefnCmd; static Tcl_ObjCmdProc InfoClassDestrCmd; @@ -33,44 +37,51 @@ static Tcl_ObjCmdProc InfoClassFiltersCmd; static Tcl_ObjCmdProc InfoClassForwardCmd; static Tcl_ObjCmdProc InfoClassInstancesCmd; static Tcl_ObjCmdProc InfoClassMethodsCmd; +static Tcl_ObjCmdProc InfoClassMethodTypeCmd; static Tcl_ObjCmdProc InfoClassMixinsCmd; static Tcl_ObjCmdProc InfoClassSubsCmd; static Tcl_ObjCmdProc InfoClassSupersCmd; - -struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; }; +static Tcl_ObjCmdProc InfoClassVariablesCmd; /* * List of commands that are used to implement the [info object] subcommands. */ -static const struct NameProcMap infoObjectCmds[] = { - {"::oo::InfoObject::class", InfoObjectClassCmd}, - {"::oo::InfoObject::definition", InfoObjectDefnCmd}, - {"::oo::InfoObject::filters", InfoObjectFiltersCmd}, - {"::oo::InfoObject::forward", InfoObjectForwardCmd}, - {"::oo::InfoObject::isa", InfoObjectIsACmd}, - {"::oo::InfoObject::methods", InfoObjectMethodsCmd}, - {"::oo::InfoObject::mixins", InfoObjectMixinsCmd}, - {"::oo::InfoObject::vars", InfoObjectVarsCmd}, - {NULL, NULL} +static const EnsembleImplMap infoObjectCmds[] = { + {"call", InfoObjectCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0}, + {"definition", InfoObjectDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"filters", InfoObjectFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"forward", InfoObjectForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"isa", InfoObjectIsACmd, TclCompileInfoObjectIsACmd, NULL, NULL, 0}, + {"methods", InfoObjectMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, + {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0}, + {"variables", InfoObjectVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} }; /* * List of commands that are used to implement the [info class] subcommands. */ -static const struct NameProcMap infoClassCmds[] = { - {"::oo::InfoClass::constructor", InfoClassConstrCmd}, - {"::oo::InfoClass::definition", InfoClassDefnCmd}, - {"::oo::InfoClass::destructor", InfoClassDestrCmd}, - {"::oo::InfoClass::filters", InfoClassFiltersCmd}, - {"::oo::InfoClass::forward", InfoClassForwardCmd}, - {"::oo::InfoClass::instances", InfoClassInstancesCmd}, - {"::oo::InfoClass::methods", InfoClassMethodsCmd}, - {"::oo::InfoClass::mixins", InfoClassMixinsCmd}, - {"::oo::InfoClass::subclasses", InfoClassSubsCmd}, - {"::oo::InfoClass::superclasses", InfoClassSupersCmd}, - {NULL, NULL} +static const EnsembleImplMap infoClassCmds[] = { + {"call", InfoClassCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"constructor", InfoClassConstrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"definition", InfoClassDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"destructor", InfoClassDestrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"filters", InfoClassFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"forward", InfoClassForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"instances", InfoClassInstancesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"methods", InfoClassMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, + {"methodtype", InfoClassMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"variables", InfoClassVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} }; /* @@ -88,58 +99,58 @@ void TclOOInitInfo( Tcl_Interp *interp) { - Tcl_Namespace *nsPtr; Tcl_Command infoCmd; - int i; - - /* - * Build the ensemble used to implement [info object]. - */ - - nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoObject", NULL, NULL); - Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX); - Tcl_Export(interp, nsPtr, "[a-z]*", 1); - for (i=0 ; infoObjectCmds[i].name!=NULL ; i++) { - Tcl_CreateObjCommand(interp, infoObjectCmds[i].name, - infoObjectCmds[i].proc, NULL, NULL); - } + Tcl_Obj *mapDict; /* - * Build the ensemble used to implement [info class]. + * Build the ensembles used to implement [info object] and [info class]. */ - nsPtr = Tcl_CreateNamespace(interp, "::oo::InfoClass", NULL, NULL); - Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX); - Tcl_Export(interp, nsPtr, "[a-z]*", 1); - for (i=0 ; infoClassCmds[i].name!=NULL ; i++) { - Tcl_CreateObjCommand(interp, infoClassCmds[i].name, - infoClassCmds[i].proc, NULL, NULL); - } + TclMakeEnsemble(interp, "::oo::InfoObject", infoObjectCmds); + TclMakeEnsemble(interp, "::oo::InfoClass", infoClassCmds); /* * Install into the master [info] ensemble. */ infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); - if (infoCmd != NULL && Tcl_IsEnsemble(infoCmd)) { - Tcl_Obj *mapDict, *objectObj, *classObj; - - Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict); - if (mapDict != NULL) { - objectObj = Tcl_NewStringObj("object", -1); - classObj = Tcl_NewStringObj("class", -1); - - Tcl_IncrRefCount(objectObj); - Tcl_IncrRefCount(classObj); - Tcl_DictObjPut(NULL, mapDict, objectObj, - Tcl_NewStringObj("::oo::InfoObject", -1)); - Tcl_DictObjPut(NULL, mapDict, classObj, - Tcl_NewStringObj("::oo::InfoClass", -1)); - Tcl_DecrRefCount(objectObj); - Tcl_DecrRefCount(classObj); - Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict); - } + Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict); + Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("object", -1), + Tcl_NewStringObj("::oo::InfoObject", -1)); + Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("class", -1), + Tcl_NewStringObj("::oo::InfoClass", -1)); + Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict); +} + +/* + * ---------------------------------------------------------------------- + * + * 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_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objPtr))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(objPtr), NULL); + return NULL; } + return oPtr->classPtr; } /* @@ -176,28 +187,22 @@ InfoObjectClassCmd( TclOOObjectName(interp, oPtr->selfCls->thisPtr)); return TCL_OK; } else { - Object *o2Ptr; - Class *mixinPtr; + Class *mixinPtr, *o2clsPtr; int i; - o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (o2Ptr == NULL) { - return TCL_ERROR; - } - if (o2Ptr->classPtr == NULL) { - Tcl_AppendResult(interp, "object \"", TclGetString(objv[2]), - "\" is not a class", NULL); + o2clsPtr = GetClassFromObj(interp, objv[2]); + if (o2clsPtr == NULL) { return TCL_ERROR; } FOREACH(mixinPtr, oPtr->mixins) { - if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) { + if (TclOOIsReachable(o2clsPtr, mixinPtr)) { Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); return TCL_OK; } } Tcl_SetObjResult(interp, Tcl_NewIntObj( - TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls))); + TclOOIsReachable(o2clsPtr, oPtr->selfCls))); return TCL_OK; } } @@ -223,10 +228,10 @@ InfoObjectDefnCmd( Tcl_HashEntry *hPtr; Proc *procPtr; CompiledLocal *localPtr; - Tcl_Obj *argsObj; + Tcl_Obj *resultObjs[2]; if (objc != 3) { - Tcl_WrongNumArgs(interp, 3, objv, "objName methodName"); + Tcl_WrongNumArgs(interp, 1, objv, "objName methodName"); return TCL_ERROR; } @@ -241,18 +246,22 @@ InfoObjectDefnCmd( hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); if (hPtr == NULL) { unknownMethod: - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[2]), NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); if (procPtr == NULL) { - Tcl_AppendResult(interp, - "definition not available for this kind of method", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "definition not available for this kind of method", -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[2]), NULL); return TCL_ERROR; } - argsObj = Tcl_NewObj(); + resultObjs[0] = Tcl_NewObj(); for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { @@ -264,22 +273,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); - - /* - * This is copied from the [info body] implementation. See the comments - * there for why this copy has to be done here. - */ - - if (procPtr->bodyPtr->bytes == NULL) { - (void) Tcl_GetString(procPtr->bodyPtr); - } - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), - Tcl_NewStringObj(procPtr->bodyPtr->bytes, - procPtr->bodyPtr->length)); + resultObjs[1] = TclOOGetMethodBody(Tcl_GetHashValue(hPtr)); + Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs)); return TCL_OK; } @@ -301,7 +299,7 @@ InfoObjectFiltersCmd( Tcl_Obj *const objv[]) { int i; - Tcl_Obj *filterObj; + Tcl_Obj *filterObj, *resultObj; Object *oPtr; if (objc != 2) { @@ -313,10 +311,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; } @@ -357,15 +357,19 @@ InfoObjectForwardCmd( hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); if (hPtr == NULL) { unknownMethod: - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[2]), NULL); return TCL_ERROR; } prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr)); if (prefixObj == NULL) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "prefix argument list not available for this kind of method", - NULL); + -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[2]), NULL); return TCL_ERROR; } @@ -390,7 +394,7 @@ InfoObjectIsACmd( int objc, Tcl_Obj *const objv[]) { - static const char *categories[] = { + static const char *const categories[] = { "class", "metaclass", "mixin", "object", "typeof", NULL }; enum IsACats { @@ -454,7 +458,9 @@ InfoObjectIsACmd( return TCL_ERROR; } if (o2Ptr->classPtr == NULL) { - Tcl_AppendResult(interp, "non-classes cannot be mixins", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "non-classes cannot be mixins", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL); return TCL_ERROR; } else { Class *mixinPtr; @@ -478,7 +484,9 @@ InfoObjectIsACmd( return TCL_ERROR; } if (o2Ptr->classPtr == NULL) { - Tcl_AppendResult(interp, "non-classes cannot be types", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "non-classes cannot be types", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL); return TCL_ERROR; } if (TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)) { @@ -513,9 +521,9 @@ 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[] = { + static const char *const options[] = { "-all", "-localprivate", "-private", NULL }; enum Options { @@ -523,7 +531,7 @@ InfoObjectMethodsCmd( }; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "objName ?options...?"); + Tcl_WrongNumArgs(interp, 1, objv, "objName ?-option value ...?"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); @@ -552,28 +560,83 @@ 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) { + if (numNames > 0) { + ckfree(names); + } + } 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; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoObjectMethodTypeCmd -- + * + * Implements [info object methodtype $objName $methodName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectMethodTypeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + Tcl_HashEntry *hPtr; + Method *mPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "objName methodName"); + return TCL_ERROR; + } + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + + if (!oPtr->methodsPtr) { + goto unknownMethod; + } + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); + if (hPtr == NULL) { + unknownMethod: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } + mPtr = Tcl_GetHashValue(hPtr); + if (mPtr->typePtr == NULL) { + /* + * Special entry for visibility control: pretend the method doesnt + * exist. + */ + + goto unknownMethod; + } + + Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, -1)); return TCL_OK; } @@ -596,10 +659,11 @@ InfoObjectMixinsCmd( { Class *mixinPtr; Object *oPtr; + Tcl_Obj *resultObj; int i; if (objc != 2) { - Tcl_WrongNumArgs(interp, 3, objv, "objName"); + Tcl_WrongNumArgs(interp, 1, objv, "objName"); return TCL_ERROR; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); @@ -607,10 +671,83 @@ 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; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoObjectNsCmd -- + * + * Implements [info object namespace $objName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectNsCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "objName"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, + Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1)); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoObjectVariablesCmd -- + * + * Implements [info object variables $objName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectVariablesCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + Tcl_Obj *variableObj, *resultObj; + int i; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "objName"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + + resultObj = Tcl_NewObj(); + FOREACH(variableObj, oPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } + Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -694,36 +831,29 @@ 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) { + 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 (clsPtr->constructorPtr == NULL) { return TCL_OK; } procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr); if (procPtr == NULL) { - Tcl_AppendResult(interp, - "definition not available for this kind of method", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "definition not available for this kind of method", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL); return TCL_ERROR; } - argsObj = Tcl_NewObj(); + resultObjs[0] = Tcl_NewObj(); for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { @@ -735,16 +865,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); - if (procPtr->bodyPtr->bytes == NULL) { - (void) Tcl_GetString(procPtr->bodyPtr); - } - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), - Tcl_NewStringObj(procPtr->bodyPtr->bytes, - procPtr->bodyPtr->length)); + resultObjs[1] = TclOOGetMethodBody(clsPtr->constructorPtr); + Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs)); return TCL_OK; } @@ -768,39 +893,35 @@ 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) { - 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]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[2]), NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); if (procPtr == NULL) { - Tcl_AppendResult(interp, - "definition not available for this kind of method", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "definition not available for this kind of method", -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[2]), NULL); return TCL_ERROR; } - argsObj = Tcl_NewObj(); + resultObjs[0] = Tcl_NewObj(); for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { @@ -812,16 +933,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); - if (procPtr->bodyPtr->bytes == NULL) { - (void) Tcl_GetString(procPtr->bodyPtr); - } - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), - Tcl_NewStringObj(procPtr->bodyPtr->bytes, - procPtr->bodyPtr->length)); + resultObjs[1] = TclOOGetMethodBody(Tcl_GetHashValue(hPtr)); + Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs)); return TCL_OK; } @@ -843,40 +959,29 @@ 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); + clsPtr = GetClassFromObj(interp, objv[1]); + if (clsPtr == NULL) { return TCL_ERROR; } - clsPtr = oPtr->classPtr; if (clsPtr->destructorPtr == NULL) { return TCL_OK; } procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr); if (procPtr == NULL) { - Tcl_AppendResult(interp, - "definition not available for this kind of method", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "definition not available for this kind of method", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL); return TCL_ERROR; } - if (procPtr->bodyPtr->bytes == NULL) { - (void) Tcl_GetString(procPtr->bodyPtr); - } - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), - Tcl_NewStringObj(procPtr->bodyPtr->bytes, - procPtr->bodyPtr->length)); + Tcl_SetObjResult(interp, TclOOGetMethodBody(clsPtr->destructorPtr)); return TCL_OK; } @@ -898,28 +1003,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) { + 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(filterObj, clsPtr->filters) { - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj); + Tcl_ListObjAppendElement(NULL, resultObj, filterObj); } + Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -942,35 +1042,31 @@ 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]), - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[2]), NULL); return TCL_ERROR; } prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr)); if (prefixObj == NULL) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "prefix argument list not available for this kind of method", - NULL); + -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[2]), NULL); return TCL_ERROR; } @@ -999,33 +1095,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; } @@ -1047,12 +1140,10 @@ 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[] = { + static const char *const options[] = { "-all", "-localprivate", "-private", NULL }; enum Options { @@ -1060,19 +1151,13 @@ InfoClassMethodsCmd( }; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "className ?options...?"); + Tcl_WrongNumArgs(interp, 1, objv, "className ?-option value ...?"); 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 != 2) { int i, idx; @@ -1095,25 +1180,80 @@ 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; - } + if (numNames > 0) { + ckfree(names); + } + } 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; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoClassMethodTypeCmd -- + * + * Implements [info class methodtype $clsName $methodName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassMethodTypeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_HashEntry *hPtr; + Method *mPtr; + Class *clsPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); + return TCL_ERROR; + } + clsPtr = GetClassFromObj(interp, objv[1]); + if (clsPtr == NULL) { + return TCL_ERROR; + } + + hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); + if (hPtr == NULL) { + unknownMethod: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } + mPtr = Tcl_GetHashValue(hPtr); + if (mPtr->typePtr == NULL) { + /* + * Special entry for visibility control: pretend the method doesnt + * exist. + */ + + goto unknownMethod; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, -1)); return TCL_OK; } @@ -1134,29 +1274,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) { - 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(mixinPtr, clsPtr->mixins) { - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + Tcl_ListObjAppendElement(NULL, resultObj, TclOOObjectName(interp, mixinPtr->thisPtr)); } + Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -1177,8 +1313,8 @@ InfoClassSubsCmd( int objc, Tcl_Obj *const objv[]) { - Object *oPtr; Class *clsPtr, *subclassPtr; + Tcl_Obj *resultObj; int i; const char *pattern = NULL; @@ -1186,27 +1322,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); @@ -1214,8 +1345,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; } @@ -1236,29 +1368,152 @@ 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; + } + clsPtr = GetClassFromObj(interp, objv[1]); + if (clsPtr == NULL) { + return TCL_ERROR; + } + + resultObj = Tcl_NewObj(); + FOREACH(superPtr, clsPtr->superclasses) { + Tcl_ListObjAppendElement(NULL, resultObj, + TclOOObjectName(interp, superPtr->thisPtr)); + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoClassVariablesCmd -- + * + * Implements [info class variables $clsName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassVariablesCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Class *clsPtr; + Tcl_Obj *variableObj, *resultObj; int i; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "className"); return TCL_ERROR; } + clsPtr = GetClassFromObj(interp, objv[1]); + if (clsPtr == NULL) { + return TCL_ERROR; + } + + resultObj = Tcl_NewObj(); + FOREACH(variableObj, clsPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoObjectCallCmd -- + * + * Implements [info object call $objName $methodName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectCallCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + CallContext *contextPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "objName 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); + + /* + * Get the call context and render its call chain. + */ + + contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL); + if (contextPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot construct any call chain", -1)); return TCL_ERROR; } - clsPtr = oPtr->classPtr; + Tcl_SetObjResult(interp, + TclOORenderCallChain(interp, contextPtr->callPtr)); + TclOODeleteContext(contextPtr); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoClassCallCmd -- + * + * Implements [info class call $clsName $methodName] + * + * ---------------------------------------------------------------------- + */ - FOREACH(superPtr, clsPtr->superclasses) { - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), - TclOOObjectName(interp, superPtr->thisPtr)); +static int +InfoClassCallCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Class *clsPtr; + CallChain *callPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); + return TCL_ERROR; + } + clsPtr = GetClassFromObj(interp, objv[1]); + if (clsPtr == NULL) { + return TCL_ERROR; + } + + /* + * Get an render the stereotypical call chain. + */ + + callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD); + if (callPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot construct any call chain", -1)); + return TCL_ERROR; } + Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr)); + TclOODeleteChain(callPtr); return TCL_OK; } |