Posted to tcl by apw at Sun Sep 09 19:43:09 GMT 2007view raw

  1. Index: tclOO.c
  2. ===================================================================
  3. RCS file: /cvsroot/tcl/oocore/generic/tclOO.c,v
  4. retrieving revision 1.25
  5. diff -b -u -r1.25 tclOO.c
  6. --- tclOO.c 3 Sep 2007 09:49:40 -0000 1.25
  7. +++ tclOO.c 9 Sep 2007 19:38:38 -0000
  8. @@ -442,6 +442,7 @@
  9. oPtr->flags = 0;
  10. oPtr->creationEpoch = creationEpoch;
  11. oPtr->metadataPtr = NULL;
  12. + oPtr->mapCmdNameProc = NULL;
  13.  
  14. /*
  15. * Initialize the traces.
  16. @@ -1752,21 +1753,32 @@
  17. {
  18. CallContext *contextPtr;
  19. int result;
  20. + Tcl_Obj *cmdNamePtr;
  21.  
  22. if (objc < 2) {
  23. Tcl_WrongNumArgs(interp, 1, objv, "method ?arg ...?");
  24. return TCL_ERROR;
  25. }
  26. + cmdNamePtr = objv[1];
  27. + if (oPtr->mapCmdNameProc != NULL) {
  28. + int res;
  29. + Class **stClsPtr = &startCls;
  30. + Tcl_Class *startClsPtr = (Tcl_Class *)stClsPtr;
  31. + cmdNamePtr = Tcl_NewStringObj(Tcl_GetString(objv[1]), -1);
  32. + Tcl_IncrRefCount(cmdNamePtr);
  33. + res = oPtr->mapCmdNameProc(oPtr, interp, cmdNamePtr, startClsPtr);
  34. +
  35. + }
  36.  
  37. /*
  38. * Get the call chain.
  39. */
  40.  
  41. contextPtr = TclOOGetCallContext(TclOOGetFoundation(interp), oPtr,
  42. - objv[1], flags | (oPtr->flags & FILTER_HANDLING), cachePtr);
  43. + cmdNamePtr, flags | (oPtr->flags & FILTER_HANDLING), cachePtr);
  44. if (contextPtr == NULL) {
  45. Tcl_AppendResult(interp, "impossible to invoke method \"",
  46. - TclGetString(objv[1]),
  47. + cmdNamePtr,
  48. "\": no defined method or unknown method", NULL);
  49. return TCL_ERROR;
  50. }
  51. @@ -1803,6 +1815,9 @@
  52. Tcl_Preserve(oPtr);
  53. result = TclOOInvokeContext(interp, contextPtr, objc, objv);
  54.  
  55. + if (oPtr->mapCmdNameProc != NULL) {
  56. + Tcl_DecrRefCount(cmdNamePtr);
  57. + }
  58. /*
  59. * Dispose of the call chain, either back into the ether or into the
  60. * chain cache.
  61. @@ -1829,6 +1844,7 @@
  62. */
  63.  
  64. Tcl_Release(oPtr);
  65. +
  66. return result;
  67. }
  68. ^L
  69. @@ -2991,6 +3007,13 @@
  70. {
  71. return (Tcl_Object) ((Class *)clazz)->thisPtr;
  72. }
  73. +void
  74. +Tcl_ObjectSetMapCmdNameProc(
  75. + Tcl_Object oPtr,
  76. + TclOO_MapCmdName mapCmdNameProc)
  77. +{
  78. + ((Object *)oPtr)->mapCmdNameProc = mapCmdNameProc;
  79. +}
  80. ^L
  81. /*
  82. * Local Variables:
  83. Index: tclOOInt.h
  84. ===================================================================
  85. RCS file: /cvsroot/tcl/oocore/generic/tclOOInt.h,v
  86. retrieving revision 1.12
  87. diff -b -u -r1.12 tclOOInt.h
  88. --- tclOOInt.h 8 Aug 2007 12:21:21 -0000 1.12
  89. +++ tclOOInt.h 9 Sep 2007 19:38:56 -0000
  90. @@ -57,6 +57,8 @@
  91. Tcl_ObjectContext context, Tcl_Namespace *namespacePtr, int result);
  92. typedef void (*TclOO_PmCDDeleteProc)(ClientData clientData);
  93. typedef ClientData (*TclOO_PmCDCloneProc)(ClientData clientData);
  94. +typedef int (*TclOO_MapCmdName)(ClientData clientData, Tcl_Interp *interp,
  95. + Tcl_Obj *mappedCmd, Tcl_Class *clsPtr);
  96.  
  97. /*
  98. * Procedure-like methods have the following extra information. It is a
  99. @@ -162,6 +164,7 @@
  100. Tcl_Obj *cachedNameObj; /* Cache of the name of the object. */
  101. Tcl_HashTable publicContextCache; /* Place to keep unused contexts. */
  102. Tcl_HashTable privateContextCache; /* Place to keep unused contexts. */
  103. + TclOO_MapCmdName mapCmdNameProc;
  104. } Object;
  105.  
  106. #define OBJECT_DELETED 1 /* Flag to say that an object has been
  107.