Posted to tcl by apw at Sun Aug 19 16:50:08 GMT 2007view raw
- This enhancement is needed for [object1 class1::method1] like calls from Itcl.
- As this directly calls PublicObjectCmd there is no way to handle that before
- calling TclOOObjectCmdCore.
- Here is the diff listing on how I have done a quick Implementation, it sets on
- return cmdName to "method1" and startCls/startClsPtr to the appropriate class.
- Index: tclOOInt.h
- ===================================================================
- RCS file: /cvsroot/tcl/oocore/generic/tclOOInt.h,v
- retrieving revision 1.12
- diff -d -u -r1.12 tclOOInt.h
- --- tclOOInt.h 8 Aug 2007 12:21:21 -0000 1.12
- +++ tclOOInt.h 19 Aug 2007 16:44:24 -0000
- @@ -57,6 +57,8 @@
- Tcl_ObjectContext context, Tcl_Namespace *namespacePtr, int result);
- typedef void (*TclOO_PmCDDeleteProc)(ClientData clientData);
- typedef ClientData (*TclOO_PmCDCloneProc)(ClientData clientData);
- +typedef int (*TclOO_MapCmdName)(ClientData clientData, Tcl_Interp *interp,
- + Tcl_Obj *mappedCmd, Tcl_Class *clsPtr);
- /*
- * Procedure-like methods have the following extra information. It is a
- @@ -162,6 +164,7 @@
- Tcl_Obj *cachedNameObj; /* Cache of the name of the object. */
- Tcl_HashTable publicContextCache; /* Place to keep unused contexts. */
- Tcl_HashTable privateContextCache; /* Place to keep unused contexts. */
- + TclOO_MapCmdName mapCmdNameProc;
- } Object;
- #define OBJECT_DELETED 1 /* Flag to say that an object has been
- Index: tclOO.c
- ===================================================================
- RCS file: /cvsroot/tcl/oocore/generic/tclOO.c,v
- retrieving revision 1.24
- diff -d -u -r1.24 tclOO.c
- --- tclOO.c 8 Aug 2007 12:21:20 -0000 1.24
- +++ tclOO.c 19 Aug 2007 16:44:29 -0000
- @@ -394,6 +394,7 @@
- oPtr->flags = 0;
- oPtr->creationEpoch = creationEpoch;
- oPtr->metadataPtr = NULL;
- + oPtr->mapCmdNameProc = NULL;
- /*
- * Initialize the traces.
- @@ -1704,21 +1705,32 @@
- {
- CallContext *contextPtr;
- int result;
- + Tcl_Obj *cmdNamePtr;
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "method ?arg ...?");
- return TCL_ERROR;
- }
- + cmdNamePtr = objv[1];
- + if (oPtr->mapCmdNameProc != NULL) {
- + int res;
- + Class **stClsPtr = &startCls;
- + Tcl_Class *startClsPtr = (Tcl_Class *)stClsPtr;
- + cmdNamePtr = Tcl_NewStringObj(Tcl_GetString(objv[1]), -1);
- + Tcl_IncrRefCount(cmdNamePtr);
- + res = oPtr->mapCmdNameProc(oPtr, interp, cmdNamePtr, startClsPtr);
- +
- + }
- /*
- * Get the call chain.
- */
- contextPtr = TclOOGetCallContext(TclOOGetFoundation(interp), oPtr,
- - objv[1], flags | (oPtr->flags & FILTER_HANDLING), cachePtr);
- + cmdNamePtr, flags | (oPtr->flags & FILTER_HANDLING), cachePtr);
- if (contextPtr == NULL) {
- Tcl_AppendResult(interp, "impossible to invoke method \"",
- - TclGetString(objv[1]),
- + cmdNamePtr,
- "\": no defined method or unknown method", NULL);
- return TCL_ERROR;
- }
- @@ -1755,6 +1767,9 @@
- Tcl_Preserve(oPtr);
- result = TclOOInvokeContext(interp, contextPtr, objc, objv);
- + if (oPtr->mapCmdNameProc != NULL) {
- + Tcl_DecrRefCount(cmdNamePtr);
- + }
- /*
- * Dispose of the call chain, either back into the ether or into the
- * chain cache.
- @@ -2943,6 +2958,13 @@
- {
- return (Tcl_Object) ((Class *)clazz)->thisPtr;
- }
- +void
- +Tcl_ObjectSetMapCmdNameProc(
- + Tcl_Object oPtr,
- + TclOO_MapCmdName mapCmdNameProc)
- +{
- + ((Object *)oPtr)->mapCmdNameProc = mapCmdNameProc;
- +}
- /*
- * Local Variables: