Posted to tcl by emiliano at Thu Oct 31 16:11:33 GMT 2024view raw
- #include <tcl.h>
- #include <tk.h>
- typedef int (HashSubCmd)(ClientData, Tcl_Interp *, int, Tcl_Obj *const []);
- static HashSubCmd GetOp;
- static HashSubCmd SetOp;
- static HashSubCmd DeleteOp;
- static int
- Hash_Cmd(ClientData clientdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
- {
- static const struct HashCmds {
- char *name;
- HashSubCmd *subCmd;
- } hashCmds[] = {
- {"delete", DeleteOp},
- {"get", GetOp},
- {"set", SetOp},
- {NULL, NULL}
- };
- int index;
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
- return TCL_ERROR;
- }
- if (Tcl_GetIndexFromObjStruct(interp, objv[1], hashCmds,
- sizeof(struct HashCmds), "subcommand", 0, &index) != TCL_OK) {
- return TCL_ERROR;
- }
- return hashCmds[index].subCmd(clientdata, interp, objc, objv);
- }
- static int
- SetOp(ClientData clientdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
- {
- Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientdata;
- Tk_Window tkwin;
- int isNew;
- Tcl_Size size;
- Tcl_HashEntry *entryPtr;
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "window dict");
- return TCL_ERROR;
- }
- tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), Tk_MainWindow(interp));
- if (! tkwin) {
- return TCL_ERROR;
- }
- if ( Tcl_DictObjSize(interp, objv[3], &size) != TCL_OK) {
- return TCL_ERROR;
- }
- entryPtr = Tcl_CreateHashEntry(tablePtr, tkwin, &isNew);
- if (! isNew) {
- Tcl_DecrRefCount(Tcl_GetHashValue(entryPtr));
- }
- Tcl_IncrRefCount(objv[3]);
- Tcl_SetHashValue(entryPtr, objv[3]);
- Tcl_SetObjResult(interp, objv[3]);
- return TCL_OK;
- }
- static int
- GetOp(ClientData clientdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
- {
- Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientdata;
- Tk_Window tkwin;
- Tcl_HashEntry *entryPtr;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "window");
- return TCL_ERROR;
- }
- tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), Tk_MainWindow(interp));
- if (! tkwin) {
- return TCL_ERROR;
- }
- entryPtr = Tcl_FindHashEntry(tablePtr, tkwin);
- if (! entryPtr) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf("can't find entry for window %s",
- Tcl_GetString(objv[2])));
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, Tcl_GetHashValue(entryPtr));
- return TCL_OK;
- }
- static int
- DeleteOp(ClientData clientdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
- {
- Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientdata;
- Tk_Window tkwin;
- Tcl_HashEntry *entryPtr;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "window");
- return TCL_ERROR;
- }
- tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), Tk_MainWindow(interp));
- if (! tkwin) {
- return TCL_ERROR;
- }
- entryPtr = Tcl_FindHashEntry(tablePtr, tkwin);
- if (! entryPtr) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf("can't find entry for window %s",
- Tcl_GetString(objv[2])));
- return TCL_ERROR;
- }
- Tcl_DecrRefCount(Tcl_GetHashValue(entryPtr));
- Tcl_DeleteHashEntry(entryPtr);
- return TCL_OK;
- }
- void
- Hash_DeleteProc(ClientData clientData)
- {
- Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData;
- Tcl_HashSearch search;
- Tcl_HashEntry *entryPtr;
- for (entryPtr = Tcl_FirstHashEntry(tablePtr, &search); entryPtr != NULL;
- entryPtr = Tcl_NextHashEntry(&search)) {
- Tcl_DecrRefCount(Tcl_GetHashValue(entryPtr));
- Tcl_DeleteHashEntry(entryPtr);
- }
- Tcl_DeleteHashTable(tablePtr);
- ckfree(tablePtr);
- return;
- }
- /*
- * Hashsample_Init -- Called when Tcl loads your extension.
- */
- int DLLEXPORT
- Hashsample_Init(Tcl_Interp *interp)
- {
- Tcl_HashTable *tablePtr;
- if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
- return TCL_ERROR;
- }
- if (Tk_InitStubs(interp, TCL_VERSION, 0) == NULL) {
- return TCL_ERROR;
- }
- if (Tcl_PkgProvide(interp, "Hashsample", "1.0") == TCL_ERROR) {
- return TCL_ERROR;
- }
- tablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
- Tcl_InitHashTable(tablePtr, TCL_ONE_WORD_KEYS);
- Tcl_CreateObjCommand(interp, "hash", Hash_Cmd, tablePtr, Hash_DeleteProc);
- return TCL_OK;
- }
- /*
- 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
- emiliano@LE-PB01:~$ /home/emiliano/tcl9/bin/tclsh9.0
- % load ./libhashsample.so
- % hash get .
- can't find entry for window .
- % hash set . foo
- missing value to go with key
- % hash set . "this is a test"
- this is a test
- % hash get .
- this is a test
- % hash delete .
- % hash get .
- can't find entry for window .
- */