diff options
Diffstat (limited to 'generic/tclOOInfo.c')
| -rw-r--r-- | generic/tclOOInfo.c | 499 |
1 files changed, 436 insertions, 63 deletions
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 9f1233c..e0594e5 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -4,7 +4,7 @@ * This file contains the implementation of the ::oo-related [info] * subcommands. * - * Copyright (c) 2006-2011 by Donal K. Fellows + * Copyright © 2006-2019 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -17,21 +17,25 @@ #include "tclOOInt.h" static inline Class * GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); +static void SortPropList(Tcl_Obj *list); static Tcl_ObjCmdProc InfoObjectCallCmd; static Tcl_ObjCmdProc InfoObjectClassCmd; static Tcl_ObjCmdProc InfoObjectDefnCmd; static Tcl_ObjCmdProc InfoObjectFiltersCmd; static Tcl_ObjCmdProc InfoObjectForwardCmd; +static Tcl_ObjCmdProc InfoObjectIdCmd; static Tcl_ObjCmdProc InfoObjectIsACmd; static Tcl_ObjCmdProc InfoObjectMethodsCmd; static Tcl_ObjCmdProc InfoObjectMethodTypeCmd; static Tcl_ObjCmdProc InfoObjectMixinsCmd; static Tcl_ObjCmdProc InfoObjectNsCmd; +static Tcl_ObjCmdProc InfoObjectPropCmd; static Tcl_ObjCmdProc InfoObjectVarsCmd; static Tcl_ObjCmdProc InfoObjectVariablesCmd; static Tcl_ObjCmdProc InfoClassCallCmd; static Tcl_ObjCmdProc InfoClassConstrCmd; static Tcl_ObjCmdProc InfoClassDefnCmd; +static Tcl_ObjCmdProc InfoClassDefnNsCmd; static Tcl_ObjCmdProc InfoClassDestrCmd; static Tcl_ObjCmdProc InfoClassFiltersCmd; static Tcl_ObjCmdProc InfoClassForwardCmd; @@ -39,6 +43,7 @@ static Tcl_ObjCmdProc InfoClassInstancesCmd; static Tcl_ObjCmdProc InfoClassMethodsCmd; static Tcl_ObjCmdProc InfoClassMethodTypeCmd; static Tcl_ObjCmdProc InfoClassMixinsCmd; +static Tcl_ObjCmdProc InfoClassPropCmd; static Tcl_ObjCmdProc InfoClassSubsCmd; static Tcl_ObjCmdProc InfoClassSupersCmd; static Tcl_ObjCmdProc InfoClassVariablesCmd; @@ -50,6 +55,7 @@ static Tcl_ObjCmdProc InfoClassVariablesCmd; static const EnsembleImplMap infoObjectCmds[] = { {"call", InfoObjectCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0}, + {"creationid", InfoObjectIdCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"definition", InfoObjectDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"filters", InfoObjectFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"forward", InfoObjectForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, @@ -58,7 +64,8 @@ static const EnsembleImplMap infoObjectCmds[] = { {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0}, - {"variables", InfoObjectVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"properties", InfoObjectPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, + {"variables", InfoObjectVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -71,6 +78,7 @@ static const EnsembleImplMap infoClassCmds[] = { {"call", InfoClassCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"constructor", InfoClassConstrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"definition", InfoClassDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"definitionnamespace", InfoClassDefnNsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"destructor", InfoClassDestrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"filters", InfoClassFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"forward", InfoClassForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, @@ -78,9 +86,10 @@ static const EnsembleImplMap infoClassCmds[] = { {"methods", InfoClassMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, {"methodtype", InfoClassMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"properties", InfoClassPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, {"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"variables", InfoClassVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"variables", InfoClassVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -167,7 +176,7 @@ GetClassFromObj( static int InfoObjectClassCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -202,11 +211,11 @@ InfoObjectClassCmd( continue; } if (TclOOIsReachable(o2clsPtr, mixinPtr)) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); return TCL_OK; } } - Tcl_SetObjResult(interp, Tcl_NewIntObj( + Tcl_SetObjResult(interp, Tcl_NewWideIntObj( TclOOIsReachable(o2clsPtr, oPtr->selfCls))); return TCL_OK; } @@ -224,7 +233,7 @@ InfoObjectClassCmd( static int InfoObjectDefnCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -257,7 +266,7 @@ InfoObjectDefnCmd( TclGetString(objv[2]), NULL); return TCL_ERROR; } - procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); + procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr)); if (procPtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "definition not available for this kind of method", -1)); @@ -281,7 +290,7 @@ InfoObjectDefnCmd( Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj); } } - resultObjs[1] = TclOOGetMethodBody(Tcl_GetHashValue(hPtr)); + resultObjs[1] = TclOOGetMethodBody((Method *)Tcl_GetHashValue(hPtr)); Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs)); return TCL_OK; } @@ -298,7 +307,7 @@ InfoObjectDefnCmd( static int InfoObjectFiltersCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -337,7 +346,7 @@ InfoObjectFiltersCmd( static int InfoObjectForwardCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -368,7 +377,7 @@ InfoObjectForwardCmd( TclGetString(objv[2]), NULL); return TCL_ERROR; } - prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr)); + prefixObj = TclOOGetFwdFromMethod((Method *)Tcl_GetHashValue(hPtr)); if (prefixObj == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "prefix argument list not available for this kind of method", @@ -394,7 +403,7 @@ InfoObjectForwardCmd( static int InfoObjectIsACmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -513,21 +522,28 @@ InfoObjectIsACmd( static int InfoObjectMethodsCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Object *oPtr; - int flag = PUBLIC_METHOD, recurse = 0; + int flag = PUBLIC_METHOD, recurse = 0, scope = -1; FOREACH_HASH_DECLS; Tcl_Obj *namePtr, *resultObj; Method *mPtr; static const char *const options[] = { - "-all", "-localprivate", "-private", NULL + "-all", "-localprivate", "-private", "-scope", NULL }; enum Options { - OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE + OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE + }; + static const char *const scopes[] = { + "private", "public", "unexported" + }; + enum Scopes { + SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED, + SCOPE_LOCALPRIVATE }; if (objc < 2) { @@ -556,14 +572,45 @@ InfoObjectMethodsCmd( case OPT_PRIVATE: flag = 0; break; + case OPT_SCOPE: + if (++i >= objc) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing option for -scope")); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", + NULL); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0, + &scope) != TCL_OK) { + return TCL_ERROR; + } + break; } } } + if (scope != -1) { + recurse = 0; + switch (scope) { + case SCOPE_PRIVATE: + flag = TRUE_PRIVATE_METHOD; + break; + case SCOPE_PUBLIC: + flag = PUBLIC_METHOD; + break; + case SCOPE_LOCALPRIVATE: + flag = PRIVATE_METHOD; + break; + case SCOPE_UNEXPORTED: + flag = 0; + break; + } + } TclNewObj(resultObj); if (recurse) { const char **names; - int i, numNames = TclOOGetSortedMethodList(oPtr, flag, &names); + int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag, + &names); for (i=0 ; i<numNames ; i++) { Tcl_ListObjAppendElement(NULL, resultObj, @@ -574,7 +621,7 @@ InfoObjectMethodsCmd( } } else if (oPtr->methodsPtr) { FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { - if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) { + if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) { Tcl_ListObjAppendElement(NULL, resultObj, namePtr); } } @@ -595,7 +642,7 @@ InfoObjectMethodsCmd( static int InfoObjectMethodTypeCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -626,7 +673,7 @@ InfoObjectMethodTypeCmd( TclGetString(objv[2]), NULL); return TCL_ERROR; } - mPtr = Tcl_GetHashValue(hPtr); + mPtr = (Method *)Tcl_GetHashValue(hPtr); if (mPtr->typePtr == NULL) { /* * Special entry for visibility control: pretend the method doesnt @@ -652,7 +699,7 @@ InfoObjectMethodTypeCmd( static int InfoObjectMixinsCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -686,6 +733,38 @@ InfoObjectMixinsCmd( /* * ---------------------------------------------------------------------- * + * InfoObjectIdCmd -- + * + * Implements [info object creationid $objName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectIdCmd( + TCL_UNUSED(void *), + 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_NewWideIntObj(oPtr->creationEpoch)); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * InfoObjectNsCmd -- * * Implements [info object namespace $objName] @@ -695,7 +774,7 @@ InfoObjectMixinsCmd( static int InfoObjectNsCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -721,34 +800,50 @@ InfoObjectNsCmd( * * InfoObjectVariablesCmd -- * - * Implements [info object variables $objName] + * Implements [info object variables $objName ?-private?] * * ---------------------------------------------------------------------- */ static int InfoObjectVariablesCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Object *oPtr; - Tcl_Obj *variableObj, *resultObj; - int i; + Tcl_Obj *resultObj; + int i, isPrivate = 0; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "objName"); + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?"); return TCL_ERROR; } + if (objc == 3) { + if (strcmp("-private", Tcl_GetString(objv[2])) != 0) { + return TCL_ERROR; + } + isPrivate = 1; + } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } TclNewObj(resultObj); - FOREACH(variableObj, oPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + if (isPrivate) { + PrivateVariableMapping *privatePtr; + + FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { + Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); + } + } else { + Tcl_Obj *variableObj; + + FOREACH(variableObj, oPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -766,7 +861,7 @@ InfoObjectVariablesCmd( static int InfoObjectVarsCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -827,7 +922,7 @@ InfoObjectVarsCmd( static int InfoClassConstrCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -888,7 +983,7 @@ InfoClassConstrCmd( static int InfoClassDefnCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -915,7 +1010,7 @@ InfoClassDefnCmd( TclGetString(objv[2]), NULL); return TCL_ERROR; } - procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); + procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr)); if (procPtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "definition not available for this kind of method", -1)); @@ -939,7 +1034,7 @@ InfoClassDefnCmd( Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj); } } - resultObjs[1] = TclOOGetMethodBody(Tcl_GetHashValue(hPtr)); + resultObjs[1] = TclOOGetMethodBody((Method *)Tcl_GetHashValue(hPtr)); Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs)); return TCL_OK; } @@ -947,6 +1042,56 @@ InfoClassDefnCmd( /* * ---------------------------------------------------------------------- * + * InfoClassDefnNsCmd -- + * + * Implements [info class definitionnamespace $clsName ?$kind?] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassDefnNsCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + static const char *kindList[] = { + "-class", + "-instance", + NULL + }; + int kind = 0; + Tcl_Obj *nsNamePtr; + Class *clsPtr; + + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className ?kind?"); + return TCL_ERROR; + } + clsPtr = GetClassFromObj(interp, objv[1]); + if (clsPtr == NULL) { + return TCL_ERROR; + } + if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[2], kindList, "kind", 0, + &kind) != TCL_OK) { + return TCL_ERROR; + } + + if (kind) { + nsNamePtr = clsPtr->objDefinitionNs; + } else { + nsNamePtr = clsPtr->clsDefinitionNs; + } + if (nsNamePtr) { + Tcl_SetObjResult(interp, nsNamePtr); + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * InfoClassDestrCmd -- * * Implements [info class destructor $clsName] @@ -956,7 +1101,7 @@ InfoClassDefnCmd( static int InfoClassDestrCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1000,7 +1145,7 @@ InfoClassDestrCmd( static int InfoClassFiltersCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1038,7 +1183,7 @@ InfoClassFiltersCmd( static int InfoClassForwardCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1063,7 +1208,7 @@ InfoClassForwardCmd( TclGetString(objv[2]), NULL); return TCL_ERROR; } - prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr)); + prefixObj = TclOOGetFwdFromMethod((Method *)Tcl_GetHashValue(hPtr)); if (prefixObj == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "prefix argument list not available for this kind of method", @@ -1089,7 +1234,7 @@ InfoClassForwardCmd( static int InfoClassInstancesCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1130,27 +1275,33 @@ InfoClassInstancesCmd( * * InfoClassMethodsCmd -- * - * Implements [info class methods $clsName ?-private?] + * Implements [info class methods $clsName ?options...?] * * ---------------------------------------------------------------------- */ static int InfoClassMethodsCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - int flag = PUBLIC_METHOD, recurse = 0; + int flag = PUBLIC_METHOD, recurse = 0, scope = -1; Tcl_Obj *namePtr, *resultObj; Method *mPtr; Class *clsPtr; static const char *const options[] = { - "-all", "-localprivate", "-private", NULL + "-all", "-localprivate", "-private", "-scope", NULL }; enum Options { - OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE + OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE + }; + static const char *const scopes[] = { + "private", "public", "unexported" + }; + enum Scopes { + SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED }; if (objc < 2) { @@ -1179,9 +1330,36 @@ InfoClassMethodsCmd( case OPT_PRIVATE: flag = 0; break; + case OPT_SCOPE: + if (++i >= objc) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing option for -scope")); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", + NULL); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0, + &scope) != TCL_OK) { + return TCL_ERROR; + } + break; } } } + if (scope != -1) { + recurse = 0; + switch (scope) { + case SCOPE_PRIVATE: + flag = TRUE_PRIVATE_METHOD; + break; + case SCOPE_PUBLIC: + flag = PUBLIC_METHOD; + break; + case SCOPE_UNEXPORTED: + flag = 0; + break; + } + } TclNewObj(resultObj); if (recurse) { @@ -1199,7 +1377,7 @@ InfoClassMethodsCmd( FOREACH_HASH_DECLS; FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { - if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) { + if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) { Tcl_ListObjAppendElement(NULL, resultObj, namePtr); } } @@ -1220,7 +1398,7 @@ InfoClassMethodsCmd( static int InfoClassMethodTypeCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1247,7 +1425,7 @@ InfoClassMethodTypeCmd( TclGetString(objv[2]), NULL); return TCL_ERROR; } - mPtr = Tcl_GetHashValue(hPtr); + mPtr = (Method *)Tcl_GetHashValue(hPtr); if (mPtr->typePtr == NULL) { /* * Special entry for visibility control: pretend the method doesnt @@ -1272,7 +1450,7 @@ InfoClassMethodTypeCmd( static int InfoClassMixinsCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1314,7 +1492,7 @@ InfoClassMixinsCmd( static int InfoClassSubsCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1369,7 +1547,7 @@ InfoClassSubsCmd( static int InfoClassSupersCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1401,34 +1579,50 @@ InfoClassSupersCmd( * * InfoClassVariablesCmd -- * - * Implements [info class variables $clsName] + * Implements [info class variables $clsName ?-private?] * * ---------------------------------------------------------------------- */ static int InfoClassVariablesCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Class *clsPtr; - Tcl_Obj *variableObj, *resultObj; - int i; + Tcl_Obj *resultObj; + int i, isPrivate = 0; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "className"); + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?"); return TCL_ERROR; } + if (objc == 3) { + if (strcmp("-private", Tcl_GetString(objv[2])) != 0) { + return TCL_ERROR; + } + isPrivate = 1; + } clsPtr = GetClassFromObj(interp, objv[1]); if (clsPtr == NULL) { return TCL_ERROR; } TclNewObj(resultObj); - FOREACH(variableObj, clsPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + if (isPrivate) { + PrivateVariableMapping *privatePtr; + + FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) { + Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); + } + } else { + Tcl_Obj *variableObj; + + FOREACH(variableObj, clsPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -1446,7 +1640,7 @@ InfoClassVariablesCmd( static int InfoObjectCallCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1467,7 +1661,8 @@ InfoObjectCallCmd( * Get the call context and render its call chain. */ - contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL); + contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL, + NULL); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot construct any call chain", -1)); @@ -1491,7 +1686,7 @@ InfoObjectCallCmd( static int InfoClassCallCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1524,6 +1719,184 @@ InfoClassCallCmd( } /* + * ---------------------------------------------------------------------- + * + * InfoClassPropCmd, InfoObjectPropCmd -- + * + * Implements [info class properties $clsName ?$option...?] and + * [info object properties $objName ?$option...?] + * + * ---------------------------------------------------------------------- + */ + +enum PropOpt { + PROP_ALL, PROP_READABLE, PROP_WRITABLE +}; +static const char *const propOptNames[] = { + "-all", "-readable", "-writable", + NULL +}; + +static int +InfoClassPropCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Class *clsPtr; + int i, idx, all = 0, writable = 0, allocated = 0; + Tcl_Obj *result, *propObj; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "className ?options...?"); + return TCL_ERROR; + } + clsPtr = GetClassFromObj(interp, objv[1]); + if (clsPtr == NULL) { + return TCL_ERROR; + } + for (i = 2; i < objc; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0, + &idx) != TCL_OK) { + return TCL_ERROR; + } + switch (idx) { + case PROP_ALL: + all = 1; + break; + case PROP_READABLE: + writable = 0; + break; + case PROP_WRITABLE: + writable = 1; + break; + } + } + + /* + * Get the properties. + */ + + if (all) { + result = TclOOGetAllClassProperties(clsPtr, writable, &allocated); + if (allocated) { + SortPropList(result); + } + } else { + TclNewObj(result); + if (writable) { + FOREACH(propObj, clsPtr->properties.writable) { + Tcl_ListObjAppendElement(NULL, result, propObj); + } + } else { + FOREACH(propObj, clsPtr->properties.readable) { + Tcl_ListObjAppendElement(NULL, result, propObj); + } + } + SortPropList(result); + } + Tcl_SetObjResult(interp, result); + return TCL_OK; +} + +static int +InfoObjectPropCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + int i, idx, all = 0, writable = 0, allocated = 0; + Tcl_Obj *result, *propObj; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "objName ?options...?"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + for (i = 2; i < objc; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0, + &idx) != TCL_OK) { + return TCL_ERROR; + } + switch (idx) { + case PROP_ALL: + all = 1; + break; + case PROP_READABLE: + writable = 0; + break; + case PROP_WRITABLE: + writable = 1; + break; + } + } + + /* + * Get the properties. + */ + + if (all) { + result = TclOOGetAllObjectProperties(oPtr, writable, &allocated); + if (allocated) { + SortPropList(result); + } + } else { + TclNewObj(result); + if (writable) { + FOREACH(propObj, oPtr->properties.writable) { + Tcl_ListObjAppendElement(NULL, result, propObj); + } + } else { + FOREACH(propObj, oPtr->properties.readable) { + Tcl_ListObjAppendElement(NULL, result, propObj); + } + } + SortPropList(result); + } + Tcl_SetObjResult(interp, result); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * SortPropList -- + * Sort a list of names of properties. Simple support function. Assumes + * that the list Tcl_Obj is unshared and doesn't have a string + * representation. + * + * ---------------------------------------------------------------------- + */ + +static int +PropNameCompare( + const void *a, + const void *b) +{ + Tcl_Obj *first = *(Tcl_Obj **) a; + Tcl_Obj *second = *(Tcl_Obj **) b; + + return strcmp(Tcl_GetString(first), Tcl_GetString(second)); +} + +static void +SortPropList( + Tcl_Obj *list) +{ + Tcl_Size ec; + Tcl_Obj **ev; + + Tcl_ListObjGetElements(NULL, list, &ec, &ev); + qsort(ev, ec, sizeof(Tcl_Obj *), PropNameCompare); +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 |