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