diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | doc/info.n | 20 | ||||
| -rw-r--r-- | generic/tclOOInfo.c | 135 | ||||
| -rw-r--r-- | generic/tclOOMethod.c | 4 | ||||
| -rw-r--r-- | tests/oo.test | 16 |
5 files changed, 171 insertions, 11 deletions
@@ -1,5 +1,12 @@ 2010-03-24 Donal K. Fellows <dkf@users.sf.net> + * generic/tclOOInfo.c (InfoObjectMethodTypeCmd) + (InfoClassMethodTypeCmd): Added introspection of method types so that + it is possible to find this info out without using errors. + * generic/tclOOMethod.c (procMethodType): Now that introspection can + reveal the name of method types, regularize the name of normal methods + to be the name of the definition type used to create them. + * tests/async.test (async-4.*): Reduce obscurity of these tests by putting the bulk of the code for them inside the test body with the help of [apply]. @@ -8,7 +8,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: info.n,v 1.35 2009/11/16 18:00:11 dgp Exp $ +'\" RCS: @(#) $Id: info.n,v 1.36 2010/03/24 13:21:11 dkf Exp $ '\" .so man.macros .TH info n 8.4 Tcl "Tcl Built-In Commands" @@ -443,6 +443,15 @@ mixins, if \fB\-all\fR is also given). .RE .VE 8.6 .TP +\fBinfo class methodtype\fI class method\fR +.VS 8.6 +This subcommand returns a description of the type of implementation used for +the method named \fImethod\fR of class \fIclass\fR. When the result is +\fBmethod\fR, further information can be discovered with \fBinfo class +definition\fR, and when the result is \fBforward\fR, further information can +be discovered with \fBinfo class forward\fR. +.VE 8.6 +.TP \fBinfo class mixins\fI class\fR .VS 8.6 This subcommand returns a list of all classes that have been mixed into the @@ -561,6 +570,15 @@ the private (i.e. non-exported) methods of the object (and classes, if .RE .VE 8.6 .TP +\fBinfo object methodtype\fI object method\fR +.VS 8.6 +This subcommand returns a description of the type of implementation used for +the method named \fImethod\fR of object \fIobject\fR. When the result is +\fBmethod\fR, further information can be discovered with \fBinfo object +definition\fR, and when the result is \fBforward\fR, further information can +be discovered with \fBinfo object forward\fR. +.VE 8.6 +.TP \fBinfo object mixins\fI object\fR .VS 8.6 This subcommand returns a list of all classes that have been mixed into the diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 9874864..b8679b3 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.13 2009/05/15 10:08:02 dkf Exp $ + * RCS: @(#) $Id: tclOOInfo.c,v 1.14 2010/03/24 13:21:11 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -25,6 +25,7 @@ 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; @@ -36,6 +37,7 @@ 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; @@ -54,6 +56,7 @@ static const struct NameProcMap infoObjectCmds[] = { {"::oo::InfoObject::forward", InfoObjectForwardCmd}, {"::oo::InfoObject::isa", InfoObjectIsACmd}, {"::oo::InfoObject::methods", InfoObjectMethodsCmd}, + {"::oo::InfoObject::methodtype", InfoObjectMethodTypeCmd}, {"::oo::InfoObject::mixins", InfoObjectMixinsCmd}, {"::oo::InfoObject::namespace", InfoObjectNsCmd}, {"::oo::InfoObject::variables", InfoObjectVariablesCmd}, @@ -73,6 +76,7 @@ static const struct NameProcMap infoClassCmds[] = { {"::oo::InfoClass::forward", InfoClassForwardCmd}, {"::oo::InfoClass::instances", InfoClassInstancesCmd}, {"::oo::InfoClass::methods", InfoClassMethodsCmd}, + {"::oo::InfoClass::methodtype", InfoClassMethodTypeCmd}, {"::oo::InfoClass::mixins", InfoClassMixinsCmd}, {"::oo::InfoClass::subclasses", InfoClassSubsCmd}, {"::oo::InfoClass::superclasses", InfoClassSupersCmd}, @@ -173,6 +177,8 @@ GetClassFromObj( if (oPtr->classPtr == NULL) { Tcl_AppendResult(interp, "\"", TclGetString(objPtr), "\" is not a class", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(objPtr), NULL); return NULL; } return oPtr->classPtr; @@ -223,6 +229,8 @@ InfoObjectClassCmd( if (o2Ptr->classPtr == NULL) { Tcl_AppendResult(interp, "object \"", TclGetString(objv[2]), "\" is not a class", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(objv[2]), NULL); return TCL_ERROR; } @@ -279,12 +287,16 @@ InfoObjectDefnCmd( unknownMethod: Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), "\"", NULL); + 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_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[2]), NULL); return TCL_ERROR; } @@ -386,6 +398,8 @@ InfoObjectForwardCmd( unknownMethod: Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[2]), NULL); return TCL_ERROR; } prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr)); @@ -393,6 +407,8 @@ InfoObjectForwardCmd( Tcl_AppendResult(interp, "prefix argument list not available for this kind of method", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[2]), NULL); return TCL_ERROR; } @@ -605,6 +621,63 @@ InfoObjectMethodsCmd( /* * ---------------------------------------------------------------------- * + * 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_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), + "\"", NULL); + 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; +} + +/* + * ---------------------------------------------------------------------- + * * InfoObjectMixinsCmd -- * * Implements [info object mixins $objName] @@ -869,12 +942,16 @@ InfoClassDefnCmd( if (hPtr == NULL) { Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), "\"", NULL); + 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_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[2]), NULL); return TCL_ERROR; } @@ -1012,6 +1089,8 @@ InfoClassForwardCmd( if (hPtr == NULL) { Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[2]), NULL); return TCL_ERROR; } prefixObj = TclOOGetFwdFromMethod(Tcl_GetHashValue(hPtr)); @@ -1019,6 +1098,8 @@ InfoClassForwardCmd( Tcl_AppendResult(interp, "prefix argument list not available for this kind of method", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[2]), NULL); return TCL_ERROR; } @@ -1160,6 +1241,58 @@ InfoClassMethodsCmd( /* * ---------------------------------------------------------------------- * + * 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_AppendResult(interp, "unknown method \"", TclGetString(objv[2]), + "\"", NULL); + 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; +} + +/* + * ---------------------------------------------------------------------- + * * InfoClassMixinsCmd -- * * Implements [info class mixins $clsName] diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 6c13116..9f5be6b 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclOOMethod.c,v 1.25 2010/03/07 14:39:26 nijtmans Exp $ + * RCS: @(#) $Id: tclOOMethod.c,v 1.26 2010/03/24 13:21:11 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -108,7 +108,7 @@ static int ProcedureMethodCompiledVarResolver(Tcl_Interp *interp, */ static const Tcl_MethodType procMethodType = { - TCL_OO_METHOD_VERSION_CURRENT, "procedural method", + TCL_OO_METHOD_VERSION_CURRENT, "method", InvokeProcedureMethod, DeleteProcedureMethod, CloneProcedureMethod }; static const Tcl_MethodType fwdMethodType = { diff --git a/tests/oo.test b/tests/oo.test index adcab4b..50edb11 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: oo.test,v 1.38 2010/03/04 23:42:54 dkf Exp $ +# RCS: @(#) $Id: oo.test,v 1.39 2010/03/24 13:21:11 dkf Exp $ package require -exact TclOO 0.6.2 ;# Must match value in generic/tclOO.h if {[lsearch [namespace children] ::tcltest] == -1} { @@ -1514,7 +1514,7 @@ test oo-16.2 {OO: object introspection} -body { } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} test oo-16.3 {OO: object introspection} -body { info object gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be class, definition, filters, forward, isa, methods, mixins, namespace, variables, or vars} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars} test oo-16.4 {OO: object introspection} -setup { oo::class create meta { superclass oo::class } [meta create instance1] create instance2 @@ -1555,10 +1555,11 @@ test oo-16.7 {OO: object introspection} -setup { } -body { oo::objdefine foo method bar {a {b c} args} {the body} set result [info object methods foo] - lappend result [info object definition foo bar] + lappend result [info object methodtype foo bar] \ + [info object definition foo bar] } -cleanup { foo destroy -} -result {bar {{a {b c} args} {the body}}} +} -result {bar method {{a {b c} args} {the body}}} test oo-16.8 {OO: object introspection} { oo::object create foo oo::class create bar @@ -1635,7 +1636,7 @@ test oo-17.3 {OO: class introspection} -setup { } -result {"foo" is not a class} test oo-17.4 {OO: class introspection} -body { info class gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be constructor, definition, destructor, filters, forward, instances, methods, mixins, subclasses, superclasses, or variables} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be constructor, definition, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables} test oo-17.5 {OO: class introspection} -setup { oo::class create testClass } -body { @@ -1651,10 +1652,11 @@ test oo-17.6 {OO: class introspection} -setup { } -body { oo::define foo method bar {a {b c} args} {the body} set result [info class methods foo] - lappend result [info class definition foo bar] + lappend result [info class methodtype foo bar] \ + [info class definition foo bar] } -cleanup { foo destroy -} -result {bar {{a {b c} args} {the body}}} +} -result {bar method {{a {b c} args} {the body}}} test oo-17.7 {OO: class introspection} { info class superclasses oo::class } ::oo::object |