Posted to tcl by apw at Sun Aug 19 16:50:08 GMT 2007view raw

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