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