Posted to tcl by apw at Sun Sep 09 19:43:09 GMT 2007view raw
- Index: tclOO.c
- ===================================================================
- RCS file: /cvsroot/tcl/oocore/generic/tclOO.c,v
- retrieving revision 1.25
- diff -b -u -r1.25 tclOO.c
- --- tclOO.c 3 Sep 2007 09:49:40 -0000 1.25
- +++ tclOO.c 9 Sep 2007 19:38:38 -0000
- @@ -442,6 +442,7 @@
- oPtr->flags = 0;
- oPtr->creationEpoch = creationEpoch;
- oPtr->metadataPtr = NULL;
- + oPtr->mapCmdNameProc = NULL;
- /*
- * Initialize the traces.
- @@ -1752,21 +1753,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;
- }
- @@ -1803,6 +1815,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.
- @@ -1829,6 +1844,7 @@
- */
- Tcl_Release(oPtr);
- +
- return result;
- }
- ^L
- @@ -2991,6 +3007,13 @@
- {
- return (Tcl_Object) ((Class *)clazz)->thisPtr;
- }
- +void
- +Tcl_ObjectSetMapCmdNameProc(
- + Tcl_Object oPtr,
- + TclOO_MapCmdName mapCmdNameProc)
- +{
- + ((Object *)oPtr)->mapCmdNameProc = mapCmdNameProc;
- +}
- ^L
- /*
- * Local Variables:
- Index: tclOOInt.h
- ===================================================================
- RCS file: /cvsroot/tcl/oocore/generic/tclOOInt.h,v
- retrieving revision 1.12
- diff -b -u -r1.12 tclOOInt.h
- --- tclOOInt.h 8 Aug 2007 12:21:21 -0000 1.12
- +++ tclOOInt.h 9 Sep 2007 19:38:56 -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