2004-02-09
VII 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
