391 lines
13 KiB
Scheme
391 lines
13 KiB
Scheme
;;; DBM processing code
|
|
|
|
;;; Copyright (c) 1995 by David Albertz (dalbertz@clark.lcs.mit.edu).
|
|
|
|
;;; This code is freely available for use by anyone for any purpose,
|
|
;;; so long as you don't charge money for it, remove this notice, or
|
|
;;; hold us liable for any results of its use. --enjoy.
|
|
|
|
;;; Usage: (dbm-open name flags mode . access_method access_info)
|
|
;;; name := name of database file (no extension)
|
|
;;; flags := file access flags (open/create etc.)
|
|
;;; mode := file access modes (privileges)
|
|
;;; access_method := *if* you have Berkeley dbm, then
|
|
;;; you can specify btree, hash, or
|
|
;;; recno access methods (0, 1, or 2)
|
|
;;; access_info := *if* you have Berkeley dbm, then
|
|
;;; you can specify an access information
|
|
;;; record, which must correspond to the
|
|
;;; correct access method.
|
|
;;; *Note*: If you do *not* have Berkeley dbm, then specifying
|
|
;;; access_method and/or access_info will generate an
|
|
;;; error. If access_method is omitted and you *do*
|
|
;;; have Berkeley dbm, the default is btree.
|
|
|
|
;;; Return: dbm-record which contains the Alien value pointer
|
|
;;; to the open DBM structure and an open
|
|
;;; status flag set to #t.
|
|
|
|
|
|
;;; Usage: (dbm-close db)
|
|
;;; db := The dbm-record returned by dbm-open
|
|
|
|
;;; Return: Return value is undefined
|
|
|
|
|
|
;;; Usage: (dbm-fetch db key)
|
|
;;; db := The dbm-record returnd by dbm-open
|
|
;;; key := The key value of data to be retrieved
|
|
|
|
;;; Return: String containing data associated with key
|
|
|
|
|
|
;;; Usage: (dbm-insert db key data)
|
|
;;; db := The dbm-record returned by dbm-open
|
|
;;; key := The key value to be associated with data
|
|
;;; data := The data to be stored with the key
|
|
;;; Note: Insert will return an error if you try to
|
|
;;; insert a duplicate key into the database
|
|
|
|
;;; Return: Return value is undefined
|
|
|
|
;;; Usage: (dbm-replace db key data)
|
|
;;; db := The dbm-record returned by dbm-open
|
|
;;; key := The key value whose data is to be changed
|
|
;;; data := The data to be stored with the key
|
|
;;; Note: If you try to replace the data for a non-existent
|
|
;;; key, dbm-replace will act like dbm-insert
|
|
|
|
;;; Return: Return value is undefined
|
|
|
|
|
|
;;; Usage: (dbm-delete db key)
|
|
;;; db := The dbm-record returned by dbm-open
|
|
;;; key := The key value of data to be deleted
|
|
|
|
;;; Return: Integer returned by UNIX dbm_delete routine
|
|
|
|
|
|
;;; Usage: (dbm-firstkey db)
|
|
;;; db := The dbm-record returned by dbm-open
|
|
|
|
;;; Return: First key value stored in database hash table.
|
|
|
|
|
|
;;; Usage: (dbm-nextkey db)
|
|
;;; db := The dbm-record returned by dbm-open
|
|
|
|
;;; Return: Next key value stored in database hash table.
|
|
;;; Returns the null string when there are no more keys.
|
|
|
|
|
|
;;; If a database error is detected during any read or write operation,
|
|
;;; the error number returned by the UNIX dbm_error routine is passed
|
|
;;; back as an error condition.
|
|
|
|
;;; ***NOTE: All key and data elements must be strings
|
|
|
|
;;; Scheme48 implementation.
|
|
|
|
(foreign-source
|
|
"#include <sys/types.h>"
|
|
"#include <limits.h>"
|
|
"#include <ndbm.h>"
|
|
"#include <db.h>"
|
|
""
|
|
"extern int errno;"
|
|
""
|
|
"#define errno_or_false(x) (((x) == -1) ? s48_enter_fixnum(errno) : S48_FALSE)"
|
|
"" "")
|
|
|
|
;;; This record will hold the pointer the the dbm structure plus
|
|
;;; a boolean flag with open status information
|
|
(define-record dbm-record
|
|
open?
|
|
dbm)
|
|
|
|
;;; Use this record to pass btree access method specific data to dbm-open
|
|
(define-record btree-info
|
|
flags
|
|
cachesize
|
|
maxkeypage
|
|
minkeypage
|
|
psize
|
|
lorder)
|
|
|
|
;;; Use this record to pass hash access method specific data to dbm-open
|
|
(define-record hash-info
|
|
bsize
|
|
ffactor
|
|
nelem
|
|
cachesize
|
|
lorder)
|
|
|
|
;;; Use this record to pass recno access method specific data to dbm-open
|
|
(define-record recno-info
|
|
flags
|
|
cachesize
|
|
psize
|
|
lorder
|
|
reclen
|
|
bval
|
|
bfname)
|
|
|
|
;;; Internal routine returns true if Berkeley dbm code is available
|
|
(define-foreign %db-check (db_check)
|
|
bool)
|
|
|
|
;;; If you don't specifiy an access method, this is the default
|
|
;;; internal routine that will be called. The only one you can
|
|
;;; use if you don't have Berkely dbm.
|
|
(define-foreign %dbm-open (db_open_default (string file)
|
|
(integer flags)
|
|
(integer mode))
|
|
(to-scheme integer errno_or_false) ; error flag
|
|
(C DB**)) ; DB structure
|
|
|
|
;;; Internal routine to open btree database
|
|
(define-foreign %dbm-open-btree (db_open_btree (string file)
|
|
(integer flags)
|
|
(integer mode)
|
|
(integer pass-info?)
|
|
(integer access-flags)
|
|
(integer cachesize)
|
|
(integer maxkeypage)
|
|
(integer minkeypage)
|
|
(integer psize)
|
|
(integer lorder))
|
|
(to-scheme integer errno_or_false) ; error flag
|
|
(C DB**)) ; DB structure
|
|
|
|
;;; Internal routine to open hash database
|
|
(define-foreign %dbm-open-hash (db_open_hash (string file)
|
|
(integer flags)
|
|
(integer mode)
|
|
(integer pass-info?)
|
|
(integer bsize)
|
|
(integer ffactor)
|
|
(integer nelem)
|
|
(integer cachesize)
|
|
(integer lorder))
|
|
(to-scheme integer errno_or_false) ; error flag
|
|
(C DB**)) ; DB structure
|
|
|
|
;;; Internal routine to open recno database
|
|
(define-foreign %dbm-open-recno (db_open_recno (string file)
|
|
(integer flags)
|
|
(integer mode)
|
|
(integer pass-info?)
|
|
(integer access-flags)
|
|
(integer cachesize)
|
|
(integer psize)
|
|
(integer lorder)
|
|
(integer reclen)
|
|
(char bval)
|
|
(string bfname))
|
|
(to-scheme integer errno_or_false) ; error flag
|
|
(C DB**)) ; DB structure
|
|
|
|
;;; Convenient names for the access methods - these are exported
|
|
(define btree/method 0)
|
|
(define hash/method 1)
|
|
(define recno/method 2)
|
|
|
|
|
|
;;; Several utility routines to help parse optional parameters
|
|
(define (maybe-car lst)
|
|
(if (pair? lst)
|
|
(car lst)
|
|
#f))
|
|
|
|
(define (maybe-cdr lst)
|
|
(if (pair? lst)
|
|
(cdr lst)
|
|
#f))
|
|
|
|
(define (maybe-cadr lst)
|
|
(maybe-car (maybe-cdr lst)))
|
|
|
|
;;; This routine returns to correct internal %dbm-open-foo routine
|
|
;;; based on the specified access method. If Berkeley dbm is not
|
|
;;; present on the system it will return an error condition if
|
|
;;; any access method is specified.
|
|
(define (get-access-method access-parms)
|
|
(let ((Berkeley? (%db-check))
|
|
(access-method (maybe-car access-parms)))
|
|
(if (and (not Berkeley?) access-method)
|
|
(error "You need the Berkeley dbm library - it's free!")
|
|
(cond ((equal? access-method btree/method) %dbm-open-btree)
|
|
((equal? access-method hash/method) %dbm-open-hash)
|
|
((equal? access-method recno/method) %dbm-open-recno)
|
|
((not access-method) %dbm-open)
|
|
(else (error "Invalid access method specified"))))))
|
|
|
|
;;; This routine checks for an optional access method specific information
|
|
;;; record (btree-info, hash-info, or recno-info). It returns an error
|
|
;;; condition of the record type does not match the access method.
|
|
;;; Case 1: no access method or access info record provided
|
|
;;; Return the empty list
|
|
;;; Case 2: Access method provided but not the info record
|
|
;;; Return a list with 0 as the first element
|
|
;;; and the correct number of remaining
|
|
;;; elements for the specified access method.
|
|
;;; The values in these elements are arbitrary.
|
|
;;; Case 3: Both access method and access info record provided
|
|
;;; Return a list with 1 as the first element and
|
|
;;; the individual fields within the info record as
|
|
;;; the remaining elements in the list.
|
|
;;;
|
|
;;; The resulting list will be used for application of the %dbm-open-foo
|
|
(define (get-access-data access-parms)
|
|
(let ((access-method (maybe-car access-parms))
|
|
(access-info (maybe-cadr access-parms)))
|
|
(cond ((btree-info? access-info)
|
|
(if (eqv? access-method btree/method)
|
|
(list 1
|
|
(btree-info:flags access-info)
|
|
(btree-info:cachesize access-info)
|
|
(btree-info:maxkeypage access-info)
|
|
(btree-info:minkeypage access-info)
|
|
(btree-info:psize access-info)
|
|
(btree-info:lorder access-info))
|
|
(error "Invalid access method for btree information")))
|
|
((hash-info? access-info)
|
|
(if (eqv? access-method hash/method)
|
|
(list 1
|
|
(hash-info:bsize access-info)
|
|
(hash-info:ffactor access-info)
|
|
(hash-info:nelem access-info)
|
|
(hash-info:cachesize access-info)
|
|
(hash-info:lorder access-info))
|
|
(error "Invalid access method for hash information")))
|
|
((recno-info? access-info)
|
|
(if (eqv? access-method recno/method)
|
|
(list 1
|
|
(recno-info:flags access-info)
|
|
(recno-info:cachesize access-info)
|
|
(recno-info:psize access-info)
|
|
(recno-info:lorder access-info)
|
|
(recno-info:reclen access-info)
|
|
(recno-info:bval access-info)
|
|
(recno-info:bfname access-info))
|
|
(error "Invalid access method for recno information")))
|
|
((not access-info)
|
|
(cond ((eqv? access-method btree/method)
|
|
(list 0 0 0 0 0 0 0))
|
|
((equal? access-method hash/method)
|
|
(list 0 0 0 0 0 0))
|
|
((eqv? access-method recno/method)
|
|
(list 0 0 0 0 0 0 #\0 ""))
|
|
((not access-method)
|
|
'())
|
|
(else (error "Invalid access method specified"))))
|
|
(else (error "Invalid access information specified")))))
|
|
|
|
;;; The visible version of the dbm-open routine
|
|
;;; Returns error or a cons cell with the tag "dbm" in car
|
|
;;; and the alien value from %dbm-open-foo in cdr
|
|
(define (dbm-open file flags mode . maybe-access)
|
|
(let ((access-method (get-access-method maybe-access))
|
|
(access-data (append (list file flags mode)
|
|
(get-access-data maybe-access))))
|
|
(receive (err dbm) (apply access-method access-data)
|
|
(if err
|
|
(errno-error err dbm-open)
|
|
(make-dbm-record #t dbm)))))
|
|
|
|
;;; Common utility routine that makes sure dbm is an open database
|
|
(define (check-dbm dbm)
|
|
(check-arg dbm-record? dbm "Not a database")
|
|
(check-arg dbm-record:open? dbm "Database not open"))
|
|
|
|
;;; Common utility routine to check for database errors
|
|
;;; result should be the result of applying the routine that might cause
|
|
;;; the error, e.g. (dbm-error dbm (%dbm-delete dbm key)) would
|
|
;;; give back the result of the delete, or an error if it occurred
|
|
(define (dbm-error dbm result)
|
|
(let ((err (%dbm-error (dbm-record:dbm dbm))))
|
|
(if (= err 0)
|
|
result
|
|
(begin
|
|
(%dbm-clearerr (dbm-record:dbm dbm))
|
|
(error "Database error" err)))))
|
|
|
|
;;; Close routines. Note that the cdr of a dbm cons cell is set to #f
|
|
;;; to prevent someone from issuing subsequent calls to that database
|
|
;;; without re-opening it.
|
|
(define-foreign %dbm-close (dbm_close ((C DBM*) dbm))
|
|
integer);
|
|
|
|
(define (dbm-close dbm)
|
|
(%dbm-close (dbm-record:dbm (check-dbm dbm)))
|
|
(set-dbm-record:open? dbm #f))
|
|
|
|
;;; Database error return. Straight forward implementation of UNIX call
|
|
;;; If this returns zero, you can be confident that the previous call
|
|
;;; to the database worked correctly.
|
|
(define-foreign %dbm-error (dbm_error ((C DBM*) dbm))
|
|
integer)
|
|
|
|
;;; Clear database errors. Straight forward implementation of UNIX call
|
|
;;; Resets database so dbm-error returns zero again.
|
|
(define-foreign %dbm-clearerr (dbm_clearerr ((C DBM*) dbm))
|
|
integer)
|
|
|
|
;;; Delete key from database if it exists
|
|
(define-foreign %dbm-delete (database_delete ((C DBM*) dbm)
|
|
(string-desc key))
|
|
integer)
|
|
|
|
(define (dbm-delete dbm key)
|
|
(dbm-error dbm (%dbm-delete (dbm-record:dbm (check-dbm dbm)) key)))
|
|
|
|
;;; Return the data associated with key if it exists, otherwise
|
|
;;; it returns a null string
|
|
(define-foreign %dbm-fetch (database_fetch ((C DBM*) dbm)
|
|
(string-desc key))
|
|
string)
|
|
|
|
(define (dbm-fetch dbm key)
|
|
(dbm-error dbm (%dbm-fetch (dbm-record:dbm (check-dbm dbm)) key)))
|
|
|
|
;;; Store a new occurance of the associated <key,data> pair in the database
|
|
;;; if flags is zero, otherwise replace old data for key with new data
|
|
(define-foreign %dbm-store (database_store ((C DBM*) dbm)
|
|
(string-desc key)
|
|
(string-desc data)
|
|
(integer flags))
|
|
integer)
|
|
|
|
;;; Insert a new occurance of <key,data> into database
|
|
(define (dbm-insert dbm key data)
|
|
(let ((insret (dbm-error dbm
|
|
(%dbm-store (dbm-record:dbm (check-dbm dbm))
|
|
key
|
|
data
|
|
0))))
|
|
(if (not (= insret 0))
|
|
(error "Attempt to insert duplicate key")
|
|
insret)))
|
|
|
|
;;; Replace old data for key with new data
|
|
(define (dbm-replace dbm key data)
|
|
(dbm-error dbm (%dbm-store (dbm-record:dbm (check-dbm dbm)) key data 1)))
|
|
|
|
|
|
;;; Returns a string containing the key of first record in database
|
|
(define-foreign %dbm-firstkey (database_first ((C DBM*) dbm))
|
|
string)
|
|
|
|
(define (dbm-firstkey dbm)
|
|
(dbm-error dbm (%dbm-firstkey (dbm-record:dbm (check-dbm dbm)))))
|
|
|
|
;;; Returns a string containing the key of the next sequential
|
|
;;; record on the database since the last firstkey or nextkey
|
|
;;; operation. Records are returned in some arbitrary sequence.
|
|
(define-foreign %dbm-nextkey (database_next ((C DBM*) dbm))
|
|
string)
|
|
|
|
(define (dbm-nextkey dbm)
|
|
(dbm-error dbm (%dbm-nextkey (dbm-record:dbm (check-dbm dbm)))))
|