Posted to tcl by de at Tue Feb 27 22:03:32 GMT 2018view raw

  1. testcb.c:
  2.  
  3. #include <tcl.h>
  4. #include <string.h>
  5.  
  6. typedef struct
  7. {
  8. Tcl_Obj *callback;
  9. Tcl_ObjCmdProc *callbackObjProc;
  10. ClientData callbackClientData;
  11. } testcbCmdData;
  12.  
  13. static int
  14. testcbInstanceCmd (
  15. ClientData clientData,
  16. Tcl_Interp *interp,
  17. int objc,
  18. Tcl_Obj *const objv[]
  19. ) {
  20. testcbCmdData *cmdData = clientData;
  21. int methodIndex, calls, call, rc, result;
  22. Tcl_Obj *vector[2], *cmdPtr;
  23. Tcl_CmdInfo cmdInfo;
  24.  
  25. static const char *methods[] = {
  26. "configure", "run", NULL
  27. };
  28. enum method {
  29. m_configure, m_run
  30. };
  31.  
  32. if (objc != 3) {
  33. Tcl_SetResult (interp, "wrong # args: should be \"testcbcmd configure <callback>\""
  34. " or \"testcbcmd run <nrOfCallbackCalls>\"", NULL);
  35. return TCL_ERROR;
  36. }
  37. if (Tcl_GetIndexFromObj(interp, objv[1], methods, "method", 0,
  38. &methodIndex) != TCL_OK) {
  39. return TCL_ERROR;
  40. }
  41. switch ((enum method) methodIndex) {
  42. case m_configure:
  43. if (cmdData->callback) {
  44. Tcl_DecrRefCount (cmdData->callback);
  45. }
  46. cmdData->callback = objv[2];
  47. Tcl_IncrRefCount (cmdData->callback);
  48. rc = Tcl_GetCommandInfo(interp, Tcl_GetString(objv[2]), &cmdInfo);
  49. if (rc && cmdInfo.isNativeObjectProc) {
  50. cmdData->callbackObjProc = cmdInfo.objProc;
  51. cmdData->callbackClientData = cmdInfo.objClientData;
  52. } else {
  53. cmdData->callbackObjProc = NULL;
  54. cmdData->callbackClientData = NULL;
  55. }
  56. break;
  57. case m_run:
  58. if (Tcl_GetIntFromObj(interp, objv[2], &calls) != TCL_OK) {
  59. Tcl_SetResult(interp, "Second arg must be an integer", NULL);
  60. return TCL_ERROR;
  61. }
  62. for (call = 1; call <= calls; call++) {
  63. if (cmdData->callbackObjProc != NULL) {
  64. vector[0] = cmdData->callback;
  65. vector[1] = Tcl_NewIntObj(call);
  66. Tcl_IncrRefCount(vector[1]);
  67. result = cmdData->callbackObjProc(
  68. cmdData->callbackClientData, interp, 2, vector
  69. );
  70. Tcl_DecrRefCount(vector[1]);
  71. } else {
  72. if (cmdData->callback != NULL) {
  73. cmdPtr = Tcl_DuplicateObj(cmdData->callback);
  74. Tcl_IncrRefCount(cmdPtr);
  75. Tcl_ListObjAppendElement(interp, cmdPtr,
  76. Tcl_NewIntObj(call));
  77. result = Tcl_EvalObjEx(interp, cmdPtr,
  78. TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
  79. Tcl_DecrRefCount(cmdPtr);
  80. }
  81. }
  82. if (result != TCL_OK) {
  83. Tcl_SetResult(interp, "Callback didn't returned TCL_OK", NULL);
  84. return TCL_ERROR;
  85. }
  86. }
  87. Tcl_ResetResult(interp);
  88. return TCL_OK;
  89. break;
  90. }
  91. return TCL_OK;
  92. }
  93.  
  94. static void
  95. testcbDeleteCmd (
  96. ClientData clientData
  97. ) {
  98. testcbCmdData *cmdData = clientData;
  99.  
  100. }
  101.  
  102. static int
  103. testcbObjCmd (
  104. ClientData dummy,
  105. Tcl_Interp *interp,
  106. int objc,
  107. Tcl_Obj *const objv[]
  108. ) {
  109. testcbCmdData *cmdData;
  110.  
  111. if (objc != 2) {
  112. Tcl_SetResult(interp, "wrong # of args, call it: testcb <cmdName>", NULL);
  113. return TCL_ERROR;
  114. }
  115. cmdData = (testcbCmdData *) Tcl_Alloc (sizeof (testcbCmdData));
  116. memset (cmdData, 0, sizeof (testcbCmdData));
  117. Tcl_CreateObjCommand(interp, Tcl_GetString(objv[1]), testcbInstanceCmd,
  118. (ClientData) cmdData, testcbDeleteCmd);
  119. return TCL_OK;
  120. }
  121.  
  122. int
  123. Testcb_Init (interp)
  124. Tcl_Interp *interp; /* Interpreter to initialize. */
  125. {
  126. Tcl_InitStubs(interp, "8", 0);
  127. Tcl_CreateObjCommand(interp, "testcb", testcbObjCmd, NULL, NULL );
  128. Tcl_PkgProvide(interp, "testcb", "1.0");
  129. return TCL_OK;
  130. }
  131.  
  132.  
  133. build.sh
  134.  
  135. #!/bin/bash
  136.  
  137. rm -f testcb.o testcb.so
  138. gcc -DUSE_TCL_STUBS=1 -fPIC -o testcb.o -c testcb.c
  139. #gcc -shared -o testcb.so testcb.o -ltclstub8.6
  140. gcc -shared -o testcb.so testcb.o -ltclstub8.5
  141.  
  142.  
  143. test.tcl:
  144.  
  145. load ./testcb.so
  146.  
  147. testcb cmd1
  148. cmd1 configure callback
  149.  
  150. proc callback {nr} {
  151. global count
  152. incr count $nr
  153. }
  154.  
  155. puts [info patchlevel]
  156. testcb cmd2
  157. cmd2 configure callback
  158.  
  159. set count 0
  160. puts "Canonical:"
  161. puts [time {cmd1 run 1000000}]
  162. puts $count
  163.  
  164. puts ""
  165.  
  166. puts "Tricky:"
  167. set count 0
  168. puts [time {cmd2 run 1000000}]
  169. puts $count
  170.  
  171.  
  172. Results:
  173. 8.6.8
  174. Canonical:
  175. 1262410 microseconds per iteration
  176. 500000500000
  177.  
  178. Tricky:
  179. 385482 microseconds per iteration
  180. 500000500000
  181.  
  182. 8.5.19
  183. Canonical:
  184. 1084528 microseconds per iteration
  185. 500000500000
  186.  
  187. Tricky:
  188. 337282 microseconds per iteration
  189. 500000500000
  190.  
  191.  
  192.  
  193.  
  194.