diff options
Diffstat (limited to 'generic/tclOOInfo.c')
| -rw-r--r-- | generic/tclOOInfo.c | 901 |
1 files changed, 0 insertions, 901 deletions
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c deleted file mode 100644 index 859aae4..0000000 --- a/generic/tclOOInfo.c +++ /dev/null @@ -1,901 +0,0 @@ -/* - * tclOODefineCmds.c -- - * - * This file contains the implementation of the ::oo-related [info] - * subcommands. - * - * Copyright (c) 2006 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.2 2006/10/20 14:04:01 dkf Exp $ - */ - -#include "tclInt.h" -#include "tclOO.h" - -static int InfoObjectClassCmd(Object *oPtr, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int InfoObjectDefnCmd(Object *oPtr, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int InfoObjectFiltersCmd(Object *oPtr, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int InfoObjectForwardCmd(Object *oPtr, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int InfoObjectIsACmd(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int InfoObjectMethodsCmd(Object *oPtr, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int InfoObjectMixinsCmd(Object *oPtr, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int InfoObjectVarsCmd(Object *oPtr, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int InfoClassConstrCmd(Class *clsPtr, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int InfoClassDefnCmd(Class *clsPtr, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int InfoClassDestrCmd(Class *clsPtr, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int InfoClassFiltersCmd(Class *clsPtr, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int InfoClassForwardCmd(Class *clsPtr, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int InfoClassInstancesCmd(Class *clsPtr, - Tcl_Interp*interp, int objc, Tcl_Obj*const objv[]); -static int InfoClassMethodsCmd(Class *clsPtr, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int InfoClassMixinsCmd(Class *clsPtr, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -#ifdef SUPPORT_OO_PARAMETERS -static int InfoClassParametersCmd(Class *clsPtr, - Tcl_Interp*interp, int objc, Tcl_Obj*const objv[]); -#endif -static int InfoClassSubsCmd(Class *clsPtr, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int InfoClassSupersCmd(Class *clsPtr, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); - -int -TclInfoObjectCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - static const char *subcommands[] = { - "class", "definition", "filters", "forward", "isa", "methods", - "mixins", "vars", NULL - }; - enum IOSubCmds { - IOClass, IODefinition, IOFilters, IOForward, IOIsA, IOMethods, - IOMixins, IOVars - }; - int idx; - Object *oPtr; - - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "objName subcommand ?arg ...?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[3], subcommands, "subcommand", 0, - &idx) != TCL_OK) { - return TCL_ERROR; - } - if (idx == IOIsA) { - return InfoObjectIsACmd(interp, objc, objv); - } - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - switch ((enum IOSubCmds) idx) { - case IOClass: - return InfoObjectClassCmd(oPtr, interp, objc, objv); - case IODefinition: - return InfoObjectDefnCmd(oPtr, interp, objc, objv); - case IOFilters: - return InfoObjectFiltersCmd(oPtr, interp, objc, objv); - case IOForward: - return InfoObjectForwardCmd(oPtr, interp, objc, objv); - case IOMethods: - return InfoObjectMethodsCmd(oPtr, interp, objc, objv); - case IOMixins: - return InfoObjectMixinsCmd(oPtr, interp, objc, objv); - case IOVars: - return InfoObjectVarsCmd(oPtr, interp, objc, objv); - case IOIsA: - Tcl_Panic("unexpected fallthrough"); - } - return TCL_ERROR; /* NOTREACHED */ -} - -int -TclInfoClassCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - static const char *subcommands[] = { - "constructor", "definition", "destructor", "filters", "forward", - "instances", "methods", "mixins", -#ifdef SUPPORT_OO_PARAMETERS - "parameters", -#endif - "subclasses", "superclasses", NULL - }; - enum ICSubCmds { - ICConstructor, ICDefinition, ICDestructor, ICFilters, ICForward, - ICInstances, ICMethods, ICMixins, -#ifdef SUPPORT_OO_PARAMETERS - ICParameters, -#endif - ICSubs, ICSupers - }; - int idx; - Object *oPtr; - - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "className subcommand ?arg ...?"); - return TCL_ERROR; - } - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->classPtr == NULL) { - Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), - "\" is not a class", NULL); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[3], subcommands, "subcommand", 0, - &idx) != TCL_OK) { - return TCL_ERROR; - } - - switch((enum ICSubCmds) idx) { - case ICConstructor: - return InfoClassConstrCmd(oPtr->classPtr, interp, objc, objv); - case ICDefinition: - return InfoClassDefnCmd(oPtr->classPtr, interp, objc, objv); - case ICDestructor: - return InfoClassDestrCmd(oPtr->classPtr, interp, objc, objv); - case ICFilters: - return InfoClassFiltersCmd(oPtr->classPtr, interp, objc, objv); - case ICForward: - return InfoClassForwardCmd(oPtr->classPtr, interp, objc, objv); - case ICInstances: - return InfoClassInstancesCmd(oPtr->classPtr, interp, objc, objv); - case ICMethods: - return InfoClassMethodsCmd(oPtr->classPtr, interp, objc, objv); - case ICMixins: - return InfoClassMixinsCmd(oPtr->classPtr, interp, objc, objv); -#ifdef SUPPORT_OO_PARAMETERS - case ICParameters: - return InfoClassParametersCmd(oPtr->classPtr, interp, objc, objv); -#endif - case ICSubs: - return InfoClassSubsCmd(oPtr->classPtr, interp, objc, objv); - case ICSupers: - return InfoClassSupersCmd(oPtr->classPtr, interp, objc, objv); - } - Tcl_Panic("unexpected fallthrough"); - return TCL_ERROR; /* NOTREACHED */ -} - -static int -InfoObjectClassCmd( - Object *oPtr, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - if (objc == 4) { - Tcl_GetCommandFullName(interp, oPtr->selfCls->thisPtr->command, - Tcl_GetObjResult(interp)); - return TCL_OK; - } else if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "objName class ?className?"); - return TCL_ERROR; - } else { - Object *o2Ptr; - Class *mixinPtr; - int i; - - o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[4]); - if (o2Ptr == NULL) { - return TCL_ERROR; - } - if (o2Ptr->classPtr == NULL) { - Tcl_AppendResult(interp, "object \"", TclGetString(objv[4]), - "\" is not a class", NULL); - return TCL_ERROR; - } - - FOREACH(mixinPtr, oPtr->mixins) { - if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); - return TCL_OK; - } - } - Tcl_SetObjResult(interp, Tcl_NewIntObj( - TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls))); - return TCL_OK; - } -} - -static int -InfoObjectDefnCmd( - Object *oPtr, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_HashEntry *hPtr; - Proc *procPtr; - CompiledLocal *localPtr; - Tcl_Obj *argsObj; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "objName definition methodName"); - return TCL_ERROR; - } - - hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) objv[4]); - if (hPtr == NULL) { - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[4]), - "\"", NULL); - return TCL_ERROR; - } - procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); - if (procPtr == NULL) { - Tcl_AppendResult(interp, - "definition not available for this kind of method", NULL); - return TCL_ERROR; - } - - TclNewObj(argsObj); - for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; - localPtr=localPtr->nextPtr) { - if (TclIsVarArgument(localPtr)) { - Tcl_Obj *argObj; - - TclNewObj(argObj); - Tcl_ListObjAppendElement(NULL, argObj, - Tcl_NewStringObj(localPtr->name, -1)); - if (localPtr->defValuePtr != NULL) { - Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); - } - Tcl_ListObjAppendElement(NULL, argsObj, 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)); - return TCL_OK; -} - -static int -InfoObjectFiltersCmd( - Object *oPtr, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int i; - Tcl_Obj *filterObj; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "objName filters"); - return TCL_ERROR; - } - FOREACH(filterObj, oPtr->filters) { - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj); - } - return TCL_OK; -} - -static int -InfoObjectForwardCmd( - Object *oPtr, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_HashEntry *hPtr; - Tcl_Obj *prefixObj; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "objName forward methodName"); - return TCL_ERROR; - } - - hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *) objv[4]); - if (hPtr == NULL) { - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[4]), - "\"", NULL); - return TCL_ERROR; - } - prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr)); - if (prefixObj == NULL) { - Tcl_AppendResult(interp, - "prefix argument list not available for this kind of method", - NULL); - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, prefixObj); - return TCL_OK; -} - -static int -InfoObjectIsACmd( - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - static const char *categories[] = { - "class", "metaclass", "mixin", "object", "typeof", NULL - }; - enum IsACats { - IsClass, IsMetaclass, IsMixin, IsObject, IsType - }; - Object *oPtr, *o2Ptr; - int idx, i; - - if (objc < 5) { - Tcl_WrongNumArgs(interp, 2, objv, "objName isa category ?arg ...?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[4], categories, "category", 0, - &idx) != TCL_OK) { - return TCL_ERROR; - } - - if (idx == IsObject) { - int ok = (Tcl_GetObjectFromObj(interp, objv[2]) != NULL); - - if (!ok) { - Tcl_ResetResult(interp); - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(ok ? 1 : 0)); - return TCL_OK; - } - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - - switch ((enum IsACats) idx) { - case IsClass: - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "objName isa class"); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->classPtr ? 1 : 0)); - return TCL_OK; - case IsMetaclass: - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "objName isa metaclass"); - return TCL_ERROR; - } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); - } else { - Foundation *fPtr = ((Interp *)interp)->ooFoundation; - - Tcl_SetObjResult(interp, Tcl_NewIntObj( - TclOOIsReachable(fPtr->classCls, oPtr->classPtr) ? 1 : 0)); - } - return TCL_OK; - case IsMixin: - if (objc != 6) { - Tcl_WrongNumArgs(interp, 2, objv, "objName isa mixin className"); - return TCL_ERROR; - } - o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[5]); - if (o2Ptr == NULL) { - return TCL_ERROR; - } - if (o2Ptr->classPtr == NULL) { - Tcl_AppendResult(interp, "non-classes cannot be mixins", NULL); - return TCL_ERROR; - } else { - Class *mixinPtr; - - FOREACH(mixinPtr, oPtr->mixins) { - if (mixinPtr == o2Ptr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); - return TCL_OK; - } - } - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); - return TCL_OK; - case IsType: - if (objc != 6) { - Tcl_WrongNumArgs(interp, 2, objv, "objName isa typeof className"); - return TCL_ERROR; - } - o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[5]); - if (o2Ptr == NULL) { - return TCL_ERROR; - } - if (o2Ptr->classPtr == NULL) { - Tcl_AppendResult(interp, "non-classes cannot be types", NULL); - return TCL_ERROR; - } - if (TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); - } - return TCL_OK; - case IsObject: - Tcl_Panic("unexpected fallthrough"); - } - return TCL_ERROR; -} - -static int -InfoObjectMethodsCmd( - Object *oPtr, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int flag = PUBLIC_METHOD; - FOREACH_HASH_DECLS; - Tcl_Obj *namePtr; - Method *mPtr; - - if (objc != 4 && objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "objName methods ?-private?"); - return TCL_ERROR; - } - if (objc == 5) { - int len; - const char *str = Tcl_GetStringFromObj(objv[4], &len); - - if (len < 2 || strncmp("-private", str, (unsigned)len)) { - Tcl_AppendResult(interp, "unknown switch \"", str, - "\": must be -private", NULL); - return TCL_ERROR; - } - flag = 0; - } - FOREACH_HASH(namePtr, mPtr, &oPtr->methods) { - if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) { - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), namePtr); - } - } - return TCL_OK; -} - -static int -InfoObjectMixinsCmd( - Object *oPtr, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Class *mixinPtr; - int i; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "objName mixins"); - return TCL_ERROR; - } - FOREACH(mixinPtr, oPtr->mixins) { - Tcl_Obj *tmpObj; - - TclNewObj(tmpObj); - Tcl_GetCommandFullName(interp, mixinPtr->thisPtr->command, tmpObj); - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj); - } - return TCL_OK; -} - -static int -InfoObjectVarsCmd( - Object *oPtr, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - const char *pattern = NULL, *name; - FOREACH_HASH_DECLS; - Var *varPtr; - - if (objc != 4 && objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "objName vars ?pattern?"); - return TCL_ERROR; - } - if (objc == 5) { - pattern = TclGetString(objv[4]); - } - - FOREACH_HASH(name, varPtr, &((Namespace *) oPtr->namespacePtr)->varTable) { - if (varPtr->flags & VAR_UNDEFINED) { - continue; - } - if (pattern != NULL && !Tcl_StringMatch(name, pattern)) { - continue; - } - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), - Tcl_NewStringObj(name, -1)); - } - - return TCL_OK; -} - -static int -InfoClassConstrCmd( - Class *clsPtr, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Proc *procPtr; - CompiledLocal *localPtr; - Tcl_Obj *argsObj; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "className constructor"); - return TCL_ERROR; - } - - 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); - return TCL_ERROR; - } - - TclNewObj(argsObj); - for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; - localPtr=localPtr->nextPtr) { - if (TclIsVarArgument(localPtr)) { - Tcl_Obj *argObj; - - TclNewObj(argObj); - Tcl_ListObjAppendElement(NULL, argObj, - Tcl_NewStringObj(localPtr->name, -1)); - if (localPtr->defValuePtr != NULL) { - Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); - } - Tcl_ListObjAppendElement(NULL, argsObj, 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)); - return TCL_OK; -} - -static int -InfoClassDefnCmd( - Class *clsPtr, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_HashEntry *hPtr; - Proc *procPtr; - CompiledLocal *localPtr; - Tcl_Obj *argsObj; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "className definition methodName"); - return TCL_ERROR; - } - - hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[4]); - if (hPtr == NULL) { - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[4]), - "\"", NULL); - return TCL_ERROR; - } - procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); - if (procPtr == NULL) { - Tcl_AppendResult(interp, - "definition not available for this kind of method", NULL); - return TCL_ERROR; - } - - TclNewObj(argsObj); - for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; - localPtr=localPtr->nextPtr) { - if (TclIsVarArgument(localPtr)) { - Tcl_Obj *argObj; - - TclNewObj(argObj); - Tcl_ListObjAppendElement(NULL, argObj, - Tcl_NewStringObj(localPtr->name, -1)); - if (localPtr->defValuePtr != NULL) { - Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); - } - Tcl_ListObjAppendElement(NULL, argsObj, 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)); - return TCL_OK; -} - -static int -InfoClassDestrCmd( - Class *clsPtr, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Proc *procPtr; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "className destructor"); - return TCL_ERROR; - } - - 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); - 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)); - return TCL_OK; -} - -static int -InfoClassFiltersCmd( - Class *clsPtr, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int i; - Tcl_Obj *filterObj; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "className filters"); - return TCL_ERROR; - } - FOREACH(filterObj, clsPtr->filters) { - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), filterObj); - } - return TCL_OK; -} - -static int -InfoClassForwardCmd( - Class *clsPtr, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_HashEntry *hPtr; - Tcl_Obj *prefixObj; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "className forward methodName"); - return TCL_ERROR; - } - - hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[4]); - if (hPtr == NULL) { - Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[4]), - "\"", NULL); - return TCL_ERROR; - } - prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr)); - if (prefixObj == NULL) { - Tcl_AppendResult(interp, - "prefix argument list not available for this kind of method", - NULL); - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, prefixObj); - return TCL_OK; -} - -static int -InfoClassInstancesCmd( - Class *clsPtr, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Object *oPtr; - int i; - const char *pattern = NULL; - - if (objc != 4 && objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "className instances ?pattern?"); - return TCL_ERROR; - } - if (objc == 5) { - pattern = TclGetString(objv[4]); - } - FOREACH(oPtr, clsPtr->instances) { - Tcl_Obj *tmpObj; - - TclNewObj(tmpObj); - Tcl_GetCommandFullName(interp, oPtr->command, tmpObj); - if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) { - TclDecrRefCount(tmpObj); - continue; - } - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj); - } - return TCL_OK; -} - -static int -InfoClassMethodsCmd( - Class *clsPtr, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - int flag = PUBLIC_METHOD; - FOREACH_HASH_DECLS; - Tcl_Obj *namePtr; - Method *mPtr; - - if (objc != 4 && objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "className methods ?-private?"); - return TCL_ERROR; - } - if (objc == 5) { - int len; - const char *str = Tcl_GetStringFromObj(objv[4], &len); - - if (len < 2 || strncmp("-private", str, (unsigned) len)) { - Tcl_AppendResult(interp, "unknown switch \"", str, - "\": must be -private", NULL); - return TCL_ERROR; - } - flag = 0; - } - FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { - if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) { - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), namePtr); - } - } - return TCL_OK; -} - -static int -InfoClassMixinsCmd( - Class *clsPtr, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Class *mixinPtr; - int i; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "className mixins"); - return TCL_ERROR; - } - FOREACH(mixinPtr, clsPtr->mixins) { - Tcl_Obj *tmpObj; - - TclNewObj(tmpObj); - Tcl_GetCommandFullName(interp, mixinPtr->thisPtr->command, tmpObj); - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj); - } - return TCL_OK; -} - -#ifdef SUPPORT_OO_PARAMETERS -static int -InfoClassParametersCmd( - Class *clsPtr, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_AppendResult(interp, "TODO: not yet implemented", NULL); - return TCL_ERROR; -} -#endif - -static int -InfoClassSubsCmd( - Class *clsPtr, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Class *subclassPtr; - int i; - const char *pattern = NULL; - - if (objc != 4 && objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "className subclasses ?pattern?"); - return TCL_ERROR; - } - if (objc == 5) { - pattern = TclGetString(objv[4]); - } - FOREACH(subclassPtr, clsPtr->subclasses) { - Tcl_Obj *tmpObj; - - TclNewObj(tmpObj); - Tcl_GetCommandFullName(interp, subclassPtr->thisPtr->command, tmpObj); - if (pattern && !Tcl_StringMatch(TclGetString(tmpObj), pattern)) { - TclDecrRefCount(tmpObj); - continue; - } - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj); - } - return TCL_OK; -} - -static int -InfoClassSupersCmd( - Class *clsPtr, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Class *superPtr; - int i; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "className superclasses"); - return TCL_ERROR; - } - FOREACH(superPtr, clsPtr->superclasses) { - Tcl_Obj *tmpObj; - - TclNewObj(tmpObj); - Tcl_GetCommandFullName(interp, superPtr->thisPtr->command, tmpObj); - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), tmpObj); - } - return TCL_OK; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ |