1/* 2 * xotclsdbm.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 "sdbm.h" 10#include <fcntl.h> 11#include <xotcl.h> 12 13#if (TCL_MAJOR_VERSION==8 && TCL_MINOR_VERSION<1) 14# define TclObjStr(obj) Tcl_GetStringFromObj(obj, ((int*)NULL)) 15#else 16# define TclObjStr(obj) Tcl_GetString(obj) 17#endif 18 19/* 20 * a database .. 21 */ 22 23typedef struct db_s { 24 int mode; 25 DBM *db; 26} db_t ; 27 28static int 29XOTclSdbmOpenMethod(ClientData cd, Tcl_Interp* in, int objc, Tcl_Obj* CONST objv[]) { 30 int mode; 31 db_t *db; 32 XOTcl_Object* obj = (XOTcl_Object *) cd; 33/* 34 int i; 35 fprintf(stderr, "Method=XOTclSdbmOpenMethod\n"); 36 for (i=0; i< objc; i++) 37 fprintf(stderr, " objv[%d]=%s\n",i,TclObjStr(objv[i])); 38*/ 39 if (!obj) return XOTclObjErrType(in, obj->cmdName, "Object"); 40 if (objc != 2) 41 return XOTclObjErrArgCnt(in, obj->cmdName, "open filename"); 42 43 /* 44 * check mode string if given 45 * 46 mode = O_RDONLY ; 47 if (argc == 3) { 48 49 if (strcmp(argv[2],"r")==0) 50 mode = O_RDONLY ; 51 else if (strcmp(argv[2],"rw")==0) 52 mode = O_RDWR | O_SYNC ; 53 else if (strcmp(argv[2],"rwc")==0) 54 mode = O_CREAT | O_RDWR | O_SYNC ; 55 else if (strcmp(argv[2],"rwn")==0) 56 mode = O_CREAT | O_EXCL | O_RDWR | O_SYNC ; 57 else { 58 sprintf(buf, BAD_MODE, argv[0], argv[2]); 59 Tcl_AppendResult (interp,buf,(char *)0); 60 return (TCL_ERROR); 61 } 62 } 63 */ 64 /* Storage interface at the moment assumes mode=rwc */ 65#ifdef O_SYNC 66 mode = O_CREAT | O_RDWR | O_SYNC; 67#else 68 mode = O_CREAT | O_RDWR; 69#endif 70 71 /* name not in hashtab - create new db */ 72 if (XOTclGetObjClientData(obj)) 73 return XOTclVarErrMsg(in, "Called open on '", TclObjStr(obj->cmdName), 74 "', but open database was not closed before.", 0); 75 76 db = (db_t*) ckalloc (sizeof(db_t)); 77 78 /* 79 * create new name and malloc space for it 80 * malloc extra space for name 81 db->name = (char *) malloc (strlen(buf)+1) ; 82 if (!db->name) { 83 perror ("malloc for name in db_open"); 84 exit (-1); 85 } 86 strcpy(db->name,buf); 87 */ 88 89 db->mode = mode; 90 db->db = sdbm_open(TclObjStr(objv[1]), mode, 0644); 91 92 if (!db->db) { 93 /* 94 * error occurred 95 * free previously allocated memory 96 */ 97 /*ckfree ((char*) db->name);*/ 98 ckfree ((char*) db); 99 db = (db_t*) NULL ; 100 101 return XOTclVarErrMsg(in, "Open on '", TclObjStr(obj->cmdName), 102 "' failed with '", TclObjStr(objv[1]),"'.", 0); 103 } else { 104 /* 105 * success 106 */ 107 XOTclSetObjClientData(obj, (ClientData) db); 108 return TCL_OK; 109 } 110} 111 112static int 113XOTclSdbmCloseMethod(ClientData cd, Tcl_Interp* in, int objc, Tcl_Obj* CONST objv[]) { 114 db_t *db; 115 XOTcl_Object* obj = (XOTcl_Object *) cd; 116 117 if (!obj) return XOTclObjErrType(in, obj->cmdName, "Object"); 118 if (objc != 1) 119 return XOTclObjErrArgCnt(in, obj->cmdName, "close"); 120 121 db = (db_t*) XOTclGetObjClientData(obj); 122 if (!db) 123 return XOTclVarErrMsg(in, "Called close on '", TclObjStr(obj->cmdName), 124 "', but database was not opened yet.", 0); 125 sdbm_close (db->db); 126 127 /*ckfree((char*)db->name);*/ 128 ckfree ((char*)db); 129 XOTclSetObjClientData(obj, 0); 130 131 return TCL_OK; 132} 133 134static int 135XOTclSdbmNamesMethod(ClientData cd, Tcl_Interp* in, int objc, Tcl_Obj* CONST objv[]) { 136 XOTcl_Object* obj = (XOTcl_Object *) cd; 137 Tcl_Obj *list; 138 db_t *db; 139 Tcl_DString result; 140 datum key; 141 142 if (!obj) return XOTclObjErrType(in, obj->cmdName, "Object"); 143 if (objc != 1) 144 return XOTclObjErrArgCnt(in, obj->cmdName, "names"); 145 146 db = (db_t*) XOTclGetObjClientData(obj); 147 if (!db) 148 return XOTclVarErrMsg(in, "Called names on '", TclObjStr(obj->cmdName), 149 "', but database was not opened yet.", 0); 150 Tcl_DStringInit(&result); 151 152 key = sdbm_firstkey(db->db); 153 if (!key.dptr) { 154 /* empty db */ 155 return TCL_OK ; 156 } 157 158 /* 159 * copy key to result and go to next key 160 */ 161 list = Tcl_NewListObj(0, NULL); 162 do { 163 Tcl_ListObjAppendElement(in,list,Tcl_NewStringObj(key.dptr,(int)(key.dsize-1))); 164 key = sdbm_nextkey(db->db); 165 } while (key.dptr); 166 Tcl_SetObjResult(in, list); 167 168 return TCL_OK; 169} 170 171static int 172XOTclSdbmSetMethod(ClientData cd, Tcl_Interp* in, int objc, Tcl_Obj* CONST objv[]) { 173 XOTcl_Object* obj = (XOTcl_Object *) cd; 174 db_t *db; 175 datum key, content; 176 177 if (!obj) return XOTclObjErrType(in, obj->cmdName, "Object"); 178 if (objc <2 || objc > 3) 179 return XOTclObjErrArgCnt(in, obj->cmdName, "set key ?value?"); 180 181 db = (db_t*) XOTclGetObjClientData(obj); 182 if (!db) 183 return XOTclVarErrMsg(in, "Called set on '", TclObjStr(obj->cmdName), 184 "', but database was not opened yet.", 0); 185 186 key.dptr = TclObjStr(objv[1]); 187 key.dsize = objv[1]->length + 1; 188 189 if (objc == 2) { 190 /* get value */ 191 content = sdbm_fetch(db->db,key); 192 if (content.dptr) { 193 /* found */ 194 Tcl_Obj *r = Tcl_NewStringObj(content.dptr, (int)(content.dsize-1)); 195 Tcl_SetObjResult(in, r); 196 } else { 197 /* key not found */ 198 return XOTclVarErrMsg(in, "no such variable '", key.dptr, 199 "'", 0); 200 } 201 } else { 202 /* set value */ 203 if (db->mode == O_RDONLY) { 204 return XOTclVarErrMsg(in, "Trying to set '", TclObjStr(obj->cmdName), 205 "', but database is in read mode.", 0); 206 } 207 content.dptr = TclObjStr(objv[2]); 208 content.dsize = objv[2]->length + 1; 209 if (sdbm_store(db->db, key, content, SDBM_REPLACE) == 0) { 210 /*fprintf(stderr,"setting %s to '%s'\n",key.dptr,content.dptr);*/ 211 Tcl_SetObjResult(in, objv[2]); 212 } else { 213 return XOTclVarErrMsg(in, "set of variable '", TclObjStr(obj->cmdName), 214 "' failed.", 0); 215 } 216 } 217 return TCL_OK; 218} 219 220static int 221XOTclSdbmExistsMethod(ClientData cd, Tcl_Interp* in, int objc, Tcl_Obj* CONST objv[]) { 222 XOTcl_Object* obj = (XOTcl_Object *) cd; 223 db_t *db; 224 datum key, content; 225 226 if (!obj) return XOTclObjErrType(in, obj->cmdName, "Object"); 227 if (objc != 2) 228 return XOTclObjErrArgCnt(in, obj->cmdName, "exists variable"); 229 230 db = (db_t*) XOTclGetObjClientData(obj); 231 if (!db) 232 return XOTclVarErrMsg(in, "Called exists on '", TclObjStr(obj->cmdName), 233 "', but database was not opened yet.", 0); 234 235 key.dptr = TclObjStr(objv[1]); 236 key.dsize = objv[1]->length + 1; 237 238 content = sdbm_fetch(db->db,key); 239 Tcl_SetIntObj(Tcl_GetObjResult(in), content.dptr != NULL); 240 241 return TCL_OK; 242} 243 244 245 246static int 247XOTclSdbmUnsetMethod(ClientData cd, Tcl_Interp* in, int objc, Tcl_Obj* CONST objv[]) { 248 XOTcl_Object* obj = (XOTcl_Object *) cd; 249 db_t *db; 250 datum key; 251 int ret; 252 253 if (!obj) return XOTclObjErrType(in, obj->cmdName, "Object"); 254 if (objc != 2) 255 return XOTclObjErrArgCnt(in, obj->cmdName, "unset key"); 256 257 db = (db_t*) XOTclGetObjClientData(obj); 258 if (!db) 259 return XOTclVarErrMsg(in, "Called unset on '", TclObjStr(obj->cmdName), 260 "', but database was not opened yet.", 0); 261 /* check for read mode */ 262 if (db->mode == O_RDONLY) { 263 return XOTclVarErrMsg(in, "Called unset on '", TclObjStr(obj->cmdName), 264 "', but database is in read mode.", 0); 265 } 266 267 key.dptr = TclObjStr(objv[1]); 268 key.dsize = objv[1]->length + 1; 269 270 ret = sdbm_delete(db->db, key); 271 272 if (ret == 0) { 273 return TCL_OK; 274 } else { 275 return XOTclVarErrMsg(in, "Tried to unset '", TclObjStr(objv[1]), 276 "' but key does not exist.", 0); 277 } 278} 279 280/* 281 * ndbm_firstkey 282 */ 283 284static int 285XOTclSdbmFirstKeyMethod(ClientData cd, Tcl_Interp* in, int objc, Tcl_Obj* CONST objv[]) { 286 XOTcl_Object* obj = (XOTcl_Object *) cd; 287 db_t *db; 288 datum key; 289 290 if (!obj) return XOTclObjErrType(in, obj->cmdName, "Object"); 291 if (objc != 1) 292 return XOTclObjErrArgCnt(in, obj->cmdName, "firstkey"); 293 294 db = (db_t*) XOTclGetObjClientData(obj); 295 if (!db) 296 return XOTclVarErrMsg(in, "Called unset on '", TclObjStr(obj->cmdName), 297 "', but database was not opened yet.", 0); 298 299 300 key = sdbm_firstkey(db->db); 301 if (!key.dptr) { 302 /* 303 * empty db 304 */ 305 return TCL_OK; 306 } 307 308 Tcl_AppendResult (in, key.dptr, (char*)0); 309 return TCL_OK; 310} 311 312static int 313XOTclSdbmNextKeyMethod(ClientData cd, Tcl_Interp* in, int objc, Tcl_Obj* CONST objv[]) { 314 XOTcl_Object* obj = (XOTcl_Object *) cd; 315 db_t *db; 316 datum newkey; 317 318 if (!obj) return XOTclObjErrType(in, obj->cmdName, "Object"); 319 if (objc != 1) 320 return XOTclObjErrArgCnt(in, obj->cmdName, "nextkey"); 321 322 db = (db_t*) XOTclGetObjClientData(obj); 323 if (!db) 324 return XOTclVarErrMsg(in, "Called unset on '", TclObjStr(obj->cmdName), 325 "', but database was not opened yet.", 0); 326 327 newkey = sdbm_nextkey(db->db); 328 329 if (!newkey.dptr) { 330 /* 331 * empty db 332 */ 333 return TCL_OK ; 334 } 335 336 Tcl_AppendResult (in, newkey.dptr, (char*)0); 337 return TCL_OK ; 338} 339 340/* 341 * Xotclsdbm_Init 342 * register commands, init data structures 343 */ 344 345/* this should be done via the stubs ... for the time being 346 simply export */ 347#ifdef VISUAL_CC 348DLLEXPORT extern int Xotclsdbm_Init(Tcl_Interp * in); 349#endif 350 351extern int 352Xotclsdbm_Init(Tcl_Interp * in) { 353 XOTcl_Class* cl; 354 int result; 355 356#ifdef USE_TCL_STUBS 357 if (Tcl_InitStubs(in, "8.1", 0) == NULL) { 358 return TCL_ERROR; 359 } 360# ifdef USE_XOTCL_STUBS 361 if (Xotcl_InitStubs(in, "1.1", 0) == NULL) { 362 return TCL_ERROR; 363 } 364# endif 365#else 366 if (Tcl_PkgRequire(in, "Tcl", TCL_VERSION, 0) == NULL) { 367 return TCL_ERROR; 368 } 369#endif 370 Tcl_PkgProvide(in, "xotcl::store::sdbm", PACKAGE_VERSION); 371 372#ifdef PACKAGE_REQUIRE_XOTCL_FROM_SLAVE_INTERP_WORKS_NOW 373 if (Tcl_PkgRequire(in, "XOTcl", XOTCLVERSION, 0) == NULL) { 374 return TCL_ERROR; 375 } 376#endif 377 if (Tcl_PkgRequire(in, "xotcl::store", 0, 0) == NULL) { 378 return TCL_ERROR; 379 } 380 result = Tcl_VarEval (in, "::xotcl::Class create Storage=Sdbm -superclass Storage", 381 (char *) NULL); 382 if (result != TCL_OK) 383 return result; 384 /*{ 385 Tcl_Obj *res = Tcl_GetObjResult(in); 386 fprintf(stderr,"res='%s'\n", TclObjStr(res)); 387 cl = XOTclGetClass(in, "Storage=Sdbm"); 388 fprintf(stderr,"cl=%p\n",cl); 389 }*/ 390 391 cl = XOTclGetClass(in, "Storage=Sdbm"); 392 if (!cl) { 393 return TCL_ERROR; 394 } 395 396 XOTclAddIMethod(in, cl, "open", XOTclSdbmOpenMethod, 0, 0); 397 XOTclAddIMethod(in, cl, "close", XOTclSdbmCloseMethod, 0, 0); 398 XOTclAddIMethod(in, cl, "set", XOTclSdbmSetMethod, 0, 0); 399 XOTclAddIMethod(in, cl, "exists", XOTclSdbmExistsMethod, 0, 0); 400 XOTclAddIMethod(in, cl, "names", XOTclSdbmNamesMethod, 0, 0); 401 XOTclAddIMethod(in, cl, "unset", XOTclSdbmUnsetMethod, 0, 0); 402 XOTclAddIMethod(in, cl, "firstkey", XOTclSdbmFirstKeyMethod, 0, 0); 403 XOTclAddIMethod(in, cl, "nextkey", XOTclSdbmNextKeyMethod, 0, 0); 404 405 Tcl_SetIntObj(Tcl_GetObjResult(in), 1); 406 return TCL_OK; 407} 408 409extern int 410Xotclsdbm_SafeInit(interp) 411 Tcl_Interp *interp; 412{ 413 return Xotclsdbm_Init(interp); 414} 415