1/* 2 * xotclgdbm.c 3 * 4 * based on Tclndbm 0.5 by John Ellson (ellson@lucent.com) 5 */ 6 7#include <stdio.h> 8#include <tcl.h> 9#include <gdbm.h> 10#include <fcntl.h> 11#include <stdlib.h> 12#include <xotcl.h> 13 14#if (TCL_MAJOR_VERSION==8 && TCL_MINOR_VERSION<1) 15# define TclObjStr(obj) Tcl_GetStringFromObj(obj, ((int*)NULL)) 16#else 17# define TclObjStr(obj) Tcl_GetString(obj) 18#endif 19 20typedef struct db_s { 21 datum* lastSearchKey; 22 GDBM_FILE db; 23} db_t; 24 25void 26gdbmFatalFunc(char* message) { 27 fprintf(stderr, "GDBM FATAL:\n%s\n", message); 28 exit(1); 29} 30 31static int 32XOTclGdbmOpenMethod(ClientData cd, Tcl_Interp* in, int objc, Tcl_Obj* CONST objv[]) { 33 db_t *db; 34 XOTcl_Object* obj = (XOTcl_Object*) cd; 35 int flags, block_size, mode; 36 37 if (!obj) return XOTclObjErrType(in, obj->cmdName, "Object"); 38 if (objc != 2) 39 return XOTclObjErrArgCnt(in, obj->cmdName, "open filename"); 40 41 /* name not in hashtab - create new db */ 42 if (XOTclGetObjClientData(obj)) 43 return XOTclVarErrMsg(in, "Called open on '", TclObjStr(obj->cmdName), 44 "', but open database was not closed before.", 0); 45 46 db = (db_t*) ckalloc (sizeof(db_t)); 47 db->lastSearchKey = NULL; 48 49 flags = GDBM_WRCREAT; 50 block_size = 0; 51 mode = 0644; 52 53 db->db = gdbm_open(TclObjStr(objv[1]), block_size, flags, mode, gdbmFatalFunc); 54 55 if (db->db == NULL) { 56 ckfree ((char*) db); 57 db = (db_t*) NULL ; 58 return XOTclVarErrMsg(in, "Open on '", TclObjStr(obj->cmdName), 59 "' failed with '", TclObjStr(objv[1]),"': ", 60 gdbm_strerror(gdbm_errno), 0); 61 } 62 /* 63 * success 64 */ 65 XOTclSetObjClientData(obj, (ClientData) db); 66 return TCL_OK; 67} 68 69static int 70XOTclGdbmCloseMethod(ClientData cd, Tcl_Interp* in, int objc, Tcl_Obj* CONST objv[]) { 71 db_t *db; 72 XOTcl_Object* obj = (XOTcl_Object *) cd; 73 74 if (!obj) return XOTclObjErrType(in, obj->cmdName, "Object"); 75 if (objc != 1) 76 return XOTclObjErrArgCnt(in, obj->cmdName, "close"); 77 78 db = (db_t*) XOTclGetObjClientData(obj); 79 if (!db) 80 return XOTclVarErrMsg(in, "Called close on '", TclObjStr(obj->cmdName), 81 "', but database was not opened yet.", 0); 82 gdbm_close(db->db); 83 ckfree ((char*)db); 84 XOTclSetObjClientData(obj, 0); 85 86 return TCL_OK; 87} 88 89static int 90XOTclGdbmNamesMethod(ClientData cd, Tcl_Interp* in, int objc, Tcl_Obj* CONST objv[]) { 91 XOTcl_Object* obj = (XOTcl_Object *) cd; 92 Tcl_Obj *list; 93 db_t *db; 94 Tcl_DString result; 95 datum del, key; 96 97 if (!obj) return XOTclObjErrType(in, obj->cmdName, "Object"); 98 if (objc != 1) 99 return XOTclObjErrArgCnt(in, obj->cmdName, "names"); 100 101 db = (db_t*) XOTclGetObjClientData(obj); 102 if (!db) 103 return XOTclVarErrMsg(in, "Called names on '", TclObjStr(obj->cmdName), 104 "', but database was not opened yet.", 0); 105 Tcl_DStringInit(&result); 106 107 key = gdbm_firstkey(db->db); 108 if (!key.dptr) { 109 /* empty db */ 110 return TCL_OK ; 111 } 112 113 /* 114 * copy key to result and go to next key 115 */ 116 list = Tcl_NewListObj(0, NULL); 117 do { 118 Tcl_ListObjAppendElement(in,list,Tcl_NewStringObj(key.dptr,key.dsize-1)); 119 del.dptr = key.dptr; 120 key = gdbm_nextkey(db->db, key); 121 free(del.dptr); 122 } while (key.dptr); 123 Tcl_SetObjResult(in, list); 124 125 return TCL_OK; 126} 127 128static int 129XOTclGdbmSetMethod(ClientData cd, Tcl_Interp* in, int objc, Tcl_Obj* CONST objv[]) { 130 XOTcl_Object* obj = (XOTcl_Object *)cd; 131 db_t *db; 132 datum key, content; 133 134 if (!obj) return XOTclObjErrType(in, obj->cmdName, "Object"); 135 if (objc <2 || objc > 3) 136 return XOTclObjErrArgCnt(in, obj->cmdName, "set key ?value?"); 137 138 db = (db_t*) XOTclGetObjClientData(obj); 139 if (!db) 140 return XOTclVarErrMsg(in, "Called set on '", TclObjStr(obj->cmdName), 141 "', but database was not opened yet.", 0); 142 143 key.dptr = TclObjStr(objv[1]); 144 key.dsize = objv[1]->length + 1; 145 146 if (objc == 2) { 147 /* get value */ 148 content = gdbm_fetch(db->db, key); 149 if (content.dptr) { 150 /* found */ 151 Tcl_Obj *r = Tcl_NewStringObj(content.dptr, content.dsize-1); 152 Tcl_SetObjResult(in, r); 153 free(content.dptr); 154 } else { 155 /* key not found */ 156 return XOTclVarErrMsg(in, "no such variable '", key.dptr, 157 "'", 0); 158 } 159 } else { 160 /* set value */ 161 content.dptr = TclObjStr(objv[2]); 162 content.dsize = objv[2]->length + 1; 163 if (gdbm_store(db->db, key, content, GDBM_REPLACE) == 0) { 164 /*fprintf(stderr,"setting %s to '%s'\n",key.dptr,content.dptr);*/ 165 Tcl_SetObjResult(in, objv[2]); 166 } else { 167 return XOTclVarErrMsg(in, "set of variable '", TclObjStr(obj->cmdName), 168 "' failed.", 0); 169 } 170 } 171 return TCL_OK; 172} 173 174static int 175XOTclGdbmExistsMethod(ClientData cd, Tcl_Interp* in, int objc, Tcl_Obj* CONST objv[]) { 176 XOTcl_Object* obj = (XOTcl_Object *) cd; 177 db_t *db; 178 datum key; 179 180 if (!obj) return XOTclObjErrType(in, obj->cmdName, "Object"); 181 if (objc != 2) 182 return XOTclObjErrArgCnt(in, obj->cmdName, "exists variable"); 183 184 db = (db_t*) XOTclGetObjClientData(obj); 185 if (!db) 186 return XOTclVarErrMsg(in, "Called exists on '", TclObjStr(obj->cmdName), 187 "', but database was not opened yet.", 0); 188 189 key.dptr = TclObjStr(objv[1]); 190 key.dsize = objv[1]->length + 1; 191 192 if (gdbm_exists(db->db, key)) 193 Tcl_SetIntObj(Tcl_GetObjResult(in), 1); 194 else 195 Tcl_SetIntObj(Tcl_GetObjResult(in), 0); 196 197 return TCL_OK; 198} 199 200static int 201XOTclGdbmUnsetMethod(ClientData cd, Tcl_Interp* in, int objc, Tcl_Obj* CONST objv[]) { 202 XOTcl_Object* obj = (XOTcl_Object *) cd; 203 db_t *db; 204 datum key; 205 int ret; 206 207 if (!obj) return XOTclObjErrType(in, obj->cmdName, "Object"); 208 if (objc != 2) 209 return XOTclObjErrArgCnt(in, obj->cmdName, "unset key"); 210 211 db = (db_t*) XOTclGetObjClientData(obj); 212 if (!db) 213 return XOTclVarErrMsg(in, "Called unset on '", TclObjStr(obj->cmdName), 214 "', but database was not opened yet.", 0); 215 216 key.dptr = TclObjStr(objv[1]); 217 key.dsize = objv[1]->length + 1; 218 219 ret = gdbm_delete(db->db, key); 220 221 if (ret == 0) { 222 return TCL_OK; 223 } else { 224 return XOTclVarErrMsg(in, "Tried to unset '", TclObjStr(objv[1]), 225 "' but key does not exist.", 0); 226 } 227} 228 229static int 230XOTclGdbmFirstKeyMethod(ClientData cd, Tcl_Interp* in, int objc, Tcl_Obj* CONST objv[]) { 231 XOTcl_Object* obj = (XOTcl_Object *) cd; 232 db_t *db; 233 datum key; 234 235 if (!obj) return XOTclObjErrType(in, obj->cmdName, "Object"); 236 if (objc != 1) 237 return XOTclObjErrArgCnt(in, obj->cmdName, "firstkey"); 238 239 db = (db_t*) XOTclGetObjClientData(obj); 240 if (!db) 241 return XOTclVarErrMsg(in, "Called unset on '", TclObjStr(obj->cmdName), 242 "', but database was not opened yet.", 0); 243 244 if (db->lastSearchKey != 0) { 245 ckfree((char*) db->lastSearchKey->dptr); 246 ckfree((char*) db->lastSearchKey); 247 db->lastSearchKey = 0; 248 } 249 250 key = gdbm_firstkey(db->db); 251 if (!key.dptr) { 252 /* 253 * empty db 254 */ 255 return TCL_OK; 256 } 257 258 Tcl_AppendResult (in, key.dptr, (char*)0); 259 260 db->lastSearchKey = (datum*) ckalloc(sizeof(datum)); 261 db->lastSearchKey->dptr = key.dptr; 262 db->lastSearchKey->dsize = key.dsize; 263 264 return TCL_OK; 265} 266 267static int 268XOTclGdbmNextKeyMethod(ClientData cd, Tcl_Interp* in, int objc, Tcl_Obj* CONST objv[]) { 269 XOTcl_Object* obj = (XOTcl_Object *) cd; 270 db_t *db; 271 datum newkey; 272 273 if (!obj) return XOTclObjErrType(in, obj->cmdName, "Object"); 274 if (objc != 1) 275 return XOTclObjErrArgCnt(in, obj->cmdName, "nextkey"); 276 277 db = (db_t*) XOTclGetObjClientData(obj); 278 if (!db) 279 return XOTclVarErrMsg(in, "Called unset on '", TclObjStr(obj->cmdName), 280 "', but database was not opened yet.", 0); 281 if (db->lastSearchKey == 0) 282 return XOTclVarErrMsg(in, 283 "nextkey invoked, but no search was started on '", 284 TclObjStr(obj->cmdName), "'", 0); 285 286 newkey = gdbm_nextkey(db->db, *db->lastSearchKey); 287 288 if (!newkey.dptr) { 289 /* 290 * end of search 291 */ 292 if (db->lastSearchKey != 0) { 293 free((char*) db->lastSearchKey->dptr); 294 ckfree((char*) db->lastSearchKey); 295 db->lastSearchKey = 0; 296 } 297 return TCL_OK ; 298 } 299 300 Tcl_AppendResult (in, newkey.dptr, (char*)0); 301 if (db->lastSearchKey != 0) { 302 free((char*) db->lastSearchKey->dptr); 303 } 304 db->lastSearchKey->dptr = newkey.dptr; 305 db->lastSearchKey->dsize = newkey.dsize; 306 return TCL_OK; 307} 308 309 310/* 311 * Xotclgdbm_Init 312 * register commands, init data structures 313 */ 314 315extern int 316Xotclgdbm_Init(Tcl_Interp * in) { 317 XOTcl_Class* cl; 318 int result; 319 320#ifdef USE_TCL_STUBS 321 if (Tcl_InitStubs(in, TCL_VERSION, 0) == NULL) { 322 return TCL_ERROR; 323 } 324# ifdef USE_XOTCL_STUBS 325 if (Xotcl_InitStubs(in, "1.1", 0) == NULL) { 326 return TCL_ERROR; 327 } 328# endif 329#else 330 if (Tcl_PkgRequire(in, "Tcl", TCL_VERSION, 0) == NULL) { 331 return TCL_ERROR; 332 } 333#endif 334 Tcl_PkgProvide(in, "xotcl::store::gdbm", PACKAGE_VERSION); 335 336#ifdef PACKAGE_REQUIRE_XOTL_FROM_SLAVE_INTERP_WORKS_NOW 337 if (Tcl_PkgRequire(in, "XOTcl", XOTCLVERSION, 0) == NULL) { 338 return TCL_ERROR; 339 } 340#endif 341 if (Tcl_PkgRequire(in, "xotcl::store", 0, 0) == NULL) { 342 return TCL_ERROR; 343 } 344 result = Tcl_VarEval (in, 345 "::xotcl::Class Storage=Gdbm -superclass Storage", 346 (char *) NULL); 347 if (result != TCL_OK) 348 return result; 349 350 cl = XOTclGetClass(in, "Storage=Gdbm"); 351 XOTclAddIMethod(in, cl, "open", XOTclGdbmOpenMethod, 0, 0); 352 XOTclAddIMethod(in, cl, "close", XOTclGdbmCloseMethod, 0, 0); 353 XOTclAddIMethod(in, cl, "set", XOTclGdbmSetMethod, 0, 0); 354 XOTclAddIMethod(in, cl, "exists", XOTclGdbmExistsMethod, 0, 0); 355 XOTclAddIMethod(in, cl, "names", XOTclGdbmNamesMethod, 0, 0); 356 XOTclAddIMethod(in, cl, "unset", XOTclGdbmUnsetMethod, 0, 0); 357 XOTclAddIMethod(in, cl, "firstkey", XOTclGdbmFirstKeyMethod, 0, 0); 358 XOTclAddIMethod(in, cl, "nextkey", XOTclGdbmNextKeyMethod, 0, 0); 359 360 Tcl_SetIntObj(Tcl_GetObjResult(in), 1); 361 return TCL_OK; 362} 363 364extern int 365Xotclgdbm_SafeInit(interp) 366 Tcl_Interp *interp; 367{ 368 return Xotclgdbm_Init(interp); 369} 370