Posted to tcl by emiliano at Thu Oct 31 16:11:33 GMT 2024view raw

  1. #include <tcl.h>
  2. #include <tk.h>
  3.  
  4. typedef int (HashSubCmd)(ClientData, Tcl_Interp *, int, Tcl_Obj *const []);
  5. static HashSubCmd GetOp;
  6. static HashSubCmd SetOp;
  7. static HashSubCmd DeleteOp;
  8.  
  9. static int
  10. Hash_Cmd(ClientData clientdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
  11. {
  12. static const struct HashCmds {
  13. char *name;
  14. HashSubCmd *subCmd;
  15. } hashCmds[] = {
  16. {"delete", DeleteOp},
  17. {"get", GetOp},
  18. {"set", SetOp},
  19. {NULL, NULL}
  20. };
  21. int index;
  22.  
  23. if (objc < 2) {
  24. Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
  25. return TCL_ERROR;
  26. }
  27.  
  28. if (Tcl_GetIndexFromObjStruct(interp, objv[1], hashCmds,
  29. sizeof(struct HashCmds), "subcommand", 0, &index) != TCL_OK) {
  30. return TCL_ERROR;
  31. }
  32.  
  33. return hashCmds[index].subCmd(clientdata, interp, objc, objv);
  34. }
  35.  
  36. static int
  37. SetOp(ClientData clientdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
  38. {
  39. Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientdata;
  40. Tk_Window tkwin;
  41. int isNew;
  42. Tcl_Size size;
  43. Tcl_HashEntry *entryPtr;
  44.  
  45. if (objc != 4) {
  46. Tcl_WrongNumArgs(interp, 2, objv, "window dict");
  47. return TCL_ERROR;
  48. }
  49.  
  50. tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), Tk_MainWindow(interp));
  51. if (! tkwin) {
  52. return TCL_ERROR;
  53. }
  54.  
  55. if ( Tcl_DictObjSize(interp, objv[3], &size) != TCL_OK) {
  56. return TCL_ERROR;
  57. }
  58.  
  59. entryPtr = Tcl_CreateHashEntry(tablePtr, tkwin, &isNew);
  60. if (! isNew) {
  61. Tcl_DecrRefCount(Tcl_GetHashValue(entryPtr));
  62. }
  63.  
  64. Tcl_IncrRefCount(objv[3]);
  65. Tcl_SetHashValue(entryPtr, objv[3]);
  66. Tcl_SetObjResult(interp, objv[3]);
  67. return TCL_OK;
  68. }
  69.  
  70. static int
  71. GetOp(ClientData clientdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
  72. {
  73. Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientdata;
  74. Tk_Window tkwin;
  75. Tcl_HashEntry *entryPtr;
  76.  
  77. if (objc != 3) {
  78. Tcl_WrongNumArgs(interp, 2, objv, "window");
  79. return TCL_ERROR;
  80. }
  81.  
  82. tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), Tk_MainWindow(interp));
  83. if (! tkwin) {
  84. return TCL_ERROR;
  85. }
  86.  
  87. entryPtr = Tcl_FindHashEntry(tablePtr, tkwin);
  88. if (! entryPtr) {
  89. Tcl_SetObjResult(interp, Tcl_ObjPrintf("can't find entry for window %s",
  90. Tcl_GetString(objv[2])));
  91. return TCL_ERROR;
  92. }
  93.  
  94. Tcl_SetObjResult(interp, Tcl_GetHashValue(entryPtr));
  95. return TCL_OK;
  96. }
  97.  
  98. static int
  99. DeleteOp(ClientData clientdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
  100. {
  101. Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientdata;
  102. Tk_Window tkwin;
  103. Tcl_HashEntry *entryPtr;
  104.  
  105. if (objc != 3) {
  106. Tcl_WrongNumArgs(interp, 2, objv, "window");
  107. return TCL_ERROR;
  108. }
  109.  
  110. tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), Tk_MainWindow(interp));
  111. if (! tkwin) {
  112. return TCL_ERROR;
  113. }
  114.  
  115. entryPtr = Tcl_FindHashEntry(tablePtr, tkwin);
  116. if (! entryPtr) {
  117. Tcl_SetObjResult(interp, Tcl_ObjPrintf("can't find entry for window %s",
  118. Tcl_GetString(objv[2])));
  119. return TCL_ERROR;
  120. }
  121.  
  122. Tcl_DecrRefCount(Tcl_GetHashValue(entryPtr));
  123. Tcl_DeleteHashEntry(entryPtr);
  124. return TCL_OK;
  125. }
  126.  
  127. void
  128. Hash_DeleteProc(ClientData clientData)
  129. {
  130. Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData;
  131. Tcl_HashSearch search;
  132. Tcl_HashEntry *entryPtr;
  133.  
  134. for (entryPtr = Tcl_FirstHashEntry(tablePtr, &search); entryPtr != NULL;
  135. entryPtr = Tcl_NextHashEntry(&search)) {
  136. Tcl_DecrRefCount(Tcl_GetHashValue(entryPtr));
  137. Tcl_DeleteHashEntry(entryPtr);
  138. }
  139.  
  140. Tcl_DeleteHashTable(tablePtr);
  141. ckfree(tablePtr);
  142. return;
  143. }
  144.  
  145. /*
  146. * Hashsample_Init -- Called when Tcl loads your extension.
  147. */
  148. int DLLEXPORT
  149. Hashsample_Init(Tcl_Interp *interp)
  150. {
  151. Tcl_HashTable *tablePtr;
  152.  
  153. if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
  154. return TCL_ERROR;
  155. }
  156. if (Tk_InitStubs(interp, TCL_VERSION, 0) == NULL) {
  157. return TCL_ERROR;
  158. }
  159. if (Tcl_PkgProvide(interp, "Hashsample", "1.0") == TCL_ERROR) {
  160. return TCL_ERROR;
  161. }
  162.  
  163. tablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
  164. Tcl_InitHashTable(tablePtr, TCL_ONE_WORD_KEYS);
  165.  
  166. Tcl_CreateObjCommand(interp, "hash", Hash_Cmd, tablePtr, Hash_DeleteProc);
  167. return TCL_OK;
  168. }
  169.  
  170. /*
  171.  
  172. emiliano@LE-PB01:~$ gcc -shared -fPIC -o libhashsample.so -DUSE_TCL_STUBS -DUSE_TK_STUBS -I/home/emiliano/tcl9/include hash_sample.c -L/home/emiliano/tcl9/lib -ltclstub -ltkstub
  173.  
  174. emiliano@LE-PB01:~$ /home/emiliano/tcl9/bin/tclsh9.0
  175. % load ./libhashsample.so
  176. % hash get .
  177. can't find entry for window .
  178. % hash set . foo
  179. missing value to go with key
  180. % hash set . "this is a test"
  181. this is a test
  182. % hash get .
  183. this is a test
  184. % hash delete .
  185. % hash get .
  186. can't find entry for window .
  187.  
  188. */
  189.