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 /* * 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] <> Application | Database