Posted to tcl by apw at Fri Aug 17 14:07:09 GMT 2007view raw

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