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