Updated 2012-10-17 10:41:50 by RLE

2004-02-09 VI

I was trying to figure out how the "vacation" program stored the data in the dbm files. So I wrote up this extension called just "dbm". Note that there are many variants, esp for gdbm, ndbm, fdbm, and lots of other dbm derivatives. This is the original Berkely non-thread-safe version. For an example usage, see vacprint.
 /* dbm.c
    A file to use the old BSD style DBMs
 */

 #include "tcl.h"
 #include <dbm.h>

 /*
  * Forward declarations for procedures defined later in this file:
  */

 static int dbmCmd _ANSI_ARGS_ ((ClientData dummy,
                                 Tcl_Interp *interp, int objc,
                                 Tcl_Obj *CONST objv[]));

 /*
  *----------------------------------------------------------------------
  *
  * Dbm_Init --
  *
  *        This procedure is the main initialisation point of the Dbm
  *        extension.
  *
  * Results:
  *        Returns a standard Tcl completion code, and leaves an error
  *        message in the interp's result if an error occurs.  If the
  *      interpreter is a safe interpreter, then this fails because
  *      dbm doesn't provide a way to do a read-only access.
  *
  * Side effects:
  *        Adds a command to the Tcl interpreter.
  *
  *----------------------------------------------------------------------
  */

 int
 Dbm_Init (interp)
     Tcl_Interp *interp;                /* Interpreter for application */
 {
     if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
         return TCL_ERROR;
     }
     if (Tcl_PkgRequire(interp, "Tcl", "8.4", 0) == NULL) {
         return TCL_ERROR;
     }
     if (Tcl_IsSafe(interp)) {
         return TCL_ERROR;
     }

     if (Tcl_PkgProvide(interp, "dbm", "0.9.4") == TCL_ERROR) {
         return TCL_ERROR;
     }

     Tcl_CreateObjCommand(interp, "dbm", dbmCmd,
             (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);

     return TCL_OK;
 }

 /* An error reporting routine for varargs results */
 #define MAX_ERROR_SIZE   1024

 static int
 setTclError TCL_VARARGS_DEF (
     Tcl_Interp *,
     i)
 {
     va_list argList;
     char buf[MAX_ERROR_SIZE];
     char *format;

     Tcl_Interp *interp = TCL_VARARGS_START(Tcl_Interp *, i, argList);
     format = va_arg(argList, char *);
     vsnprintf(buf, MAX_ERROR_SIZE, format, argList);
     buf[MAX_ERROR_SIZE-1] = '\0';
     Tcl_SetResult(interp, buf, TCL_VOLATILE);
     return TCL_ERROR;
 }

 /*
  * ---------------------------------------------------------------
  * dbmCmd --
  *
  * Implmements the "dbm" command.
  *
  * Results:
  *      A standard Tcl result.
  *
  * Side effects:
  *      See the dbm man page.  All side effects are inside the
  *      the library
  */

 static int
 dbmCmd (dummy, interp, objc, objv)
     ClientData dummy;
     Tcl_Interp *interp;
     int                objc;
     Tcl_Obj        *CONST objv[];
 {
     int index;

     static CONST char *optionStrings[] = {
         "init", "close", "fetch", "store",
         "delete", "first", "next"
     };

     enum options {
         DBM_INIT, DBM_CLOSE, DBM_FETCH, DBM_STORE,
         DBM_DELETE, DBM_FIRST, DBM_NEXT
     };

     if (objc < 2) {
         Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
         return TCL_ERROR;
     }

     if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
             &index) != TCL_OK) {
         return TCL_ERROR;
     }

     switch ((enum options) index) {
     case DBM_INIT: {
         int res;
         if (objc != 3) {
             Tcl_WrongNumArgs(interp, 2, objv, "path");
             return TCL_ERROR;
         }
         res = dbminit(Tcl_GetString(objv[2]));
         if (res < 0) {
             return setTclError(interp, "dbminit failed on path %s, result is %d",
                                Tcl_GetString(objv[2]), res);
         }
         return TCL_OK;
     }
     case DBM_CLOSE: {
         int res;
         res = dbmclose();
         if (res < 0) {
             return setTclError(interp, "dbminit failed on path %s, result is %d",
                                Tcl_GetString(objv[2]), res);
         }
         return TCL_OK;
     }
     case DBM_FETCH: {
         Tcl_Obj *ro;
         unsigned char *keybytes;
         datum key, dat;

         if (objc != 3) {
             Tcl_WrongNumArgs(interp, 2, objv, "key");
             return TCL_ERROR;
         }
         keybytes = Tcl_GetByteArrayFromObj(objv[2], &key.dsize);
         key.dptr = keybytes;
         dat = fetch(key);
         if (dat.dptr == NULL) {
             return setTclError(interp, "Couldn't fetch for key %s",
                                Tcl_GetString(objv[2]));
         }
         ro = Tcl_NewByteArrayObj(dat.dptr, dat.dsize);
         Tcl_SetObjResult(interp, ro);
         return TCL_OK;
     }
     case DBM_STORE: {
         int res;
         unsigned char *keybytes, *datbytes;
         datum key, dat;

         if (objc != 4) {
             Tcl_WrongNumArgs(interp, 2, objv, "key dat");
             return TCL_ERROR;
         }
         keybytes = Tcl_GetByteArrayFromObj(objv[2], &key.dsize);
         datbytes = Tcl_GetByteArrayFromObj(objv[3], &dat.dsize);
         key.dptr = keybytes;
         dat.dptr = datbytes;
         res = store(key,dat);
         if (res < 0) {
             return setTclError(interp, "Couldn't store for key %s, "
                                "result is %d", Tcl_GetString(objv[2]),
                                res);
         }
         return TCL_OK;
     }
     case DBM_DELETE: {
         int res;
         unsigned char *keybytes;
         datum key;

         if (objc != 3) {
             Tcl_WrongNumArgs(interp, 2, objv, "key");
             return TCL_ERROR;
         }
         keybytes = Tcl_GetByteArrayFromObj(objv[2], &key.dsize);
         key.dptr = keybytes;
         res = delete(key);
         if (res < 0) {
             return setTclError(interp, "Couldn't delete for key %s, "
                                "result is %d", Tcl_GetString(objv[2]),
                                res);
         }
         return TCL_OK;
     }
     case DBM_FIRST: {
         Tcl_Obj *ro;
         datum key;

         if (objc != 2) {
             Tcl_WrongNumArgs(interp, 2, objv, "");
             return TCL_ERROR;
         }
         key = firstkey();
         if (key.dptr == NULL) {
             return setTclError(interp, "Couldn't Get first Key");
         }
         ro = Tcl_NewByteArrayObj(key.dptr, key.dsize);
         Tcl_SetObjResult(interp, ro);
         return TCL_OK;
     }
     case DBM_NEXT: {
         Tcl_Obj *ro;
         unsigned char *keybytes;
         datum key, next;

         if (objc != 3) {
             Tcl_WrongNumArgs(interp, 2, objv, "key");
             return TCL_ERROR;
         }
         keybytes = Tcl_GetByteArrayFromObj(objv[2], &key.dsize);
         key.dptr = keybytes;
         next = nextkey(key);
         if (next.dptr == NULL) {
             return setTclError(interp, "Couldn't get next for key %s",
                                Tcl_GetString(objv[2]));
         }
         ro = Tcl_NewByteArrayObj(next.dptr, next.dsize);
         Tcl_SetObjResult(interp, ro);
         return TCL_OK;
     }
     default: {
         return setTclError(interp, "Couldn't understand enum %d as "
                            "action type", index);
     }
     }
 }

I have only tested this on Solaris 5.7 (Tcl 8.4.5). To build, save the above code into dbm.c, then:
 gcc -I/usr/local/tcl/8.4.5/include -I/usr/ucbinclude -fPIC -c dbm.c -o dbm.o
 ld -r dbm.o -o dbm.so

You should be able to just load the dbm.so into tclsh. The command usage is:
  dbm init filename
  dbm fetch "key"   <- returns data
  dbm first         <- returns one key
  dbm next "key"    <- given key returns next key
  dbm close
  dbm store "key" "data"  <- stores data under key.

All keys and datas are binary strings. See man dbm for more details

For an example usage, see vacprint.

2004-02-10 VI Version 0.9.4: use vsnprintf in error reporting; change comment so formatting in wiki is not confused; Add some missing spaces in error messages.

Berkeley DB Tcl interface