diff options
Diffstat (limited to 'generic/tclOOInfo.c')
| -rw-r--r-- | generic/tclOOInfo.c | 116 |
1 files changed, 88 insertions, 28 deletions
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index bc7b4fb..41d90a4 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.6 2008/08/12 23:19:15 hobbs Exp $ + * RCS: @(#) $Id: tclOOInfo.c,v 1.7 2008/09/23 05:05:54 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -26,6 +26,7 @@ static Tcl_ObjCmdProc InfoObjectIsACmd; static Tcl_ObjCmdProc InfoObjectMethodsCmd; static Tcl_ObjCmdProc InfoObjectMixinsCmd; static Tcl_ObjCmdProc InfoObjectVarsCmd; +static Tcl_ObjCmdProc InfoObjectVariablesCmd; static Tcl_ObjCmdProc InfoClassConstrCmd; static Tcl_ObjCmdProc InfoClassDefnCmd; static Tcl_ObjCmdProc InfoClassDestrCmd; @@ -36,6 +37,7 @@ static Tcl_ObjCmdProc InfoClassMethodsCmd; static Tcl_ObjCmdProc InfoClassMixinsCmd; static Tcl_ObjCmdProc InfoClassSubsCmd; static Tcl_ObjCmdProc InfoClassSupersCmd; +static Tcl_ObjCmdProc InfoClassVariablesCmd; struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; }; @@ -51,6 +53,7 @@ static const struct NameProcMap infoObjectCmds[] = { {"::oo::InfoObject::isa", InfoObjectIsACmd}, {"::oo::InfoObject::methods", InfoObjectMethodsCmd}, {"::oo::InfoObject::mixins", InfoObjectMixinsCmd}, + {"::oo::InfoObject::variables", InfoObjectVariablesCmd}, {"::oo::InfoObject::vars", InfoObjectVarsCmd}, {NULL, NULL} }; @@ -70,6 +73,7 @@ static const struct NameProcMap infoClassCmds[] = { {"::oo::InfoClass::mixins", InfoClassMixinsCmd}, {"::oo::InfoClass::subclasses", InfoClassSubsCmd}, {"::oo::InfoClass::superclasses", InfoClassSupersCmd}, + {"::oo::InfoClass::variables", InfoClassVariablesCmd}, {NULL, NULL} }; @@ -268,18 +272,8 @@ InfoObjectDefnCmd( } } 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)); + TclOOGetMethodBody(Tcl_GetHashValue(hPtr))); return TCL_OK; } @@ -617,6 +611,42 @@ InfoObjectMixinsCmd( /* * ---------------------------------------------------------------------- * + * 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; + 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; + } + + FOREACH(variableObj, oPtr->variables) { + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), variableObj); + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * InfoObjectVarsCmd -- * * Implements [info object vars $objName ?$pattern?] @@ -739,12 +769,8 @@ InfoClassConstrCmd( } } 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)); + TclOOGetMethodBody(clsPtr->constructorPtr)); return TCL_OK; } @@ -816,12 +842,8 @@ InfoClassDefnCmd( } } 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)); + TclOOGetMethodBody(Tcl_GetHashValue(hPtr))); return TCL_OK; } @@ -871,12 +893,7 @@ InfoClassDestrCmd( 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; } @@ -1263,6 +1280,49 @@ InfoClassSupersCmd( } /* + * ---------------------------------------------------------------------- + * + * InfoClassVariablesCmd -- + * + * Implements [info class variables $clsName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassVariablesCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + Class *clsPtr; + Tcl_Obj *variableObj; + 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); + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + + FOREACH(variableObj, clsPtr->variables) { + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), variableObj); + } + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 |