[elephant-cvs] CVS elephant/src/db-bdb
ieslick
ieslick at common-lisp.net
Sat Nov 11 18:43:31 UTC 2006
Update of /project/elephant/cvsroot/elephant/src/db-bdb
In directory clnet:/tmp/cvs-serv20735
Added Files:
berkeley-db.lisp
Log Message:
Added a missing file from sleepycat rename
--- /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2006/11/11 18:43:31 NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2006/11/11 18:43:31 1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; berkeley-db.lisp -- FFI interface to Berkeley DB
;;;
;;; Initial version 9/10/2004 by Ben Lee
;;; <blee at common-lisp.net>
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; <ablumberg at common-lisp.net> <blee at common-lisp.net>
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;
(in-package :db-bdb)
(declaim (inline %db-get-key-buffered db-get-key-buffered
%db-get-buffered db-get-buffered db-get
%db-put-buffered db-put-buffered
%db-put db-put
%db-delete db-delete-buffered db-delete
%db-delete-kv db-delete-kv-buffered
%db-cursor db-cursor %db-cursor-close db-cursor-close
%db-cursor-duplicate db-cursor-duplicate
%db-cursor-get-key-buffered
db-cursor-move-buffered
db-cursor-set-buffered
db-cursor-get-both-buffered
%db-cursor-pget-key-buffered
db-cursor-pmove-buffered
db-cursor-pset-buffered
db-cursor-pget-both-buffered
%db-cursor-put-buffered db-cursor-put-buffered
%db-cursor-delete db-cursor-delete
%db-txn-begin db-transaction-begin
%db-txn-abort db-transaction-abort
%db-txn-commit db-transaction-commit
%db-transaction-id
%db-sequence-get db-sequence-get
%db-sequence-get-lower db-sequence-get-fixnum
))
;;
;; EXTERNAL LIBRARY DEPENDENCIES - LOAD DURING LOAD/COMPILATION
;;
(eval-when (:compile-toplevel :load-toplevel)
(def-function ("db_strerr" %db-strerror)
((error :int))
:returning :cstring)
(defun db-strerror (errno)
"Get the string error associated with an error number."
(convert-from-cstring (%db-strerror errno)))
(define-condition db-error (error)
((errno :type fixnum :initarg :errno :reader db-error-errno))
(:report
(lambda (condition stream)
(declare (type db-error condition) (type stream stream))
(format stream "Berkeley DB error: ~A"
(db-strerror (db-error-errno condition)))))
(:documentation "Berkeley DB errors."))
)
;;
;; Constants and Flags
;; eventually write a macro which generates a custom flag function.
;;
;I don't like the UFFI syntax for enumerations
(defconstant DB-BTREE 1)
(defconstant DB-HASH 2)
(defconstant DB-RECNO 3)
(defconstant DB-QUEUE 4)
(defconstant DB-UNKNOWN 5)
(defconstant DB_CREATE #x00000001)
(defconstant DB_LOCK_NOWAIT #x00000002)
(defconstant DB_FORCE #x00000004)
(defconstant DB_NOMMAP #x00000008)
(defconstant DB_RDONLY #x00000010)
(defconstant DB_RECOVER #x00000020)
(defconstant DB_THREAD #x00000040)
(defconstant DB_TRUNCATE #x00000080)
(defconstant DB_TXN_NOSYNC #x00000100)
(defconstant DB_EXCL #x00002000)
(defconstant DB_TXN_NOWAIT #x00002000)
(defconstant DB_TXN_SYNC #x00004000)
(defconstant DB_DUP #x00004000)
(defconstant DB_DUPSORT #x00008000)
(defconstant DB_JOINENV #x00000000)
(defconstant DB_INIT_CDB #x00002000)
(defconstant DB_INIT_LOCK #x00004000)
(defconstant DB_INIT_LOG #x00008000)
(defconstant DB_INIT_MPOOL #x00010000)
(defconstant DB_INIT_REP #x00020000)
(defconstant DB_INIT_TXN #x00040000)
(defconstant DB_LOCKDOWN #x00080000)
(defconstant DB_PRIVATE #x00100000)
(defconstant DB_RECOVER_FATAL #x00200000)
(defconstant DB_SYSTEM_MEM #x00800000)
(defconstant DB_AUTO_COMMIT #x01000000)
(defconstant DB_READ_COMMITTED #x02000000)
(defconstant DB_DEGREE_2 #x02000000) ;; DEPRECATED, now called DB_READ_COMMITTED
(defconstant DB_READ_UNCOMMITTED #x04000000)
(defconstant DB_DIRTY_READ #x04000000) ;; DEPRECATED, now called DB_READ_UNCOMMITTED
(defconstant DB_CURRENT 7)
(defconstant DB_FIRST 9)
(defconstant DB_GET_BOTH 10)
(defconstant DB_GET_BOTH_RANGE 12)
(defconstant DB_LAST 17)
(defconstant DB_NEXT 18)
(defconstant DB_NEXT_DUP 19)
(defconstant DB_NEXT_NODUP 20)
(defconstant DB_PREV 25)
(defconstant DB_PREV_NODUP 26)
(defconstant DB_SET 28)
(defconstant DB_SET_RANGE 30)
(defconstant DB_AFTER 1)
(defconstant DB_BEFORE 3)
(defconstant DB_KEYFIRST 15)
(defconstant DB_KEYLAST 16)
(defconstant DB_NODUPDATA 21)
(defconstant DB_NOOVERWRITE 22)
(defconstant DB_NOSYNC 23)
(defconstant DB_POSITION 24)
(defconstant DB_SEQ_DEC #x00000001)
(defconstant DB_SEQ_INC #x00000002)
(defconstant DB_SEQ_WRAP #x00000008)
(defconstant DB_SET_LOCK_TIMEOUT 29)
(defconstant DB_SET_TXN_TIMEOUT 33)
(defconstant DB_FREELIST_ONLY #x00002000)
(defconstant DB_FREE_SPACE #x00004000)
(defconstant DB_KEYEMPTY -30997)
(defconstant DB_KEYEXIST -30996)
(defconstant DB_LOCK_DEADLOCK -30995)
(defconstant DB_LOCK_NOTGRANTED -30994)
(defconstant DB_NOTFOUND -30989)
(defconstant DB_LOCK_DEFAULT 1)
(defconstant DB_LOCK_EXPIRE 2)
(defconstant DB_LOCK_MAXLOCKS 3)
(defconstant DB_LOCK_MAXWRITE 4)
(defconstant DB_LOCK_MINLOCKS 5)
(defconstant DB_LOCK_MINWRITE 6)
(defconstant DB_LOCK_OLDEST 7)
(defconstant DB_LOCK_RANDOM 8)
(defconstant DB_LOCK_YOUNGEST 9)
(def-enum DB-LOCKOP ((:DUMP 0) :GET :GET-TIMEOUT :INHERIT
:PUT :PUT-ALL :PUT-OBJ :PUT-READ
:TIMEOUT :TRADE :UPGRADE-WRITE))
(def-enum DB-LOCKMODE ((:NG 0) :READ :WRITE :WAIT
:IWRITE :IREAD :IWR :DIRTY :WWRITE))
(def-struct DB-LOCK
(off :unsigned-int)
(ndx :unsigned-int)
(gen :unsigned-int)
(mode DB-LOCKMODE))
#+openmcl
(ccl:def-foreign-type DB-LOCK (:struct DB-LOCK))
(def-struct DB-LOCKREQ
(op DB-LOCKOP)
(mode DB-LOCKMODE)
(timeout :unsigned-int)
(obj (:array :char))
(lock (* DB-LOCK)))
#+openmcl
(ccl:def-foreign-type DB-LOCKREQ (:struct DB-LOCKREQ))
(defconstant +2^32+ 4294967296)
(defconstant +2^64+ 18446744073709551616)
(defconstant +2^32-1+ (1- +2^32+))
(defmacro make-64-bit-integer (high32 low32)
`(+ ,low32 (ash ,high32 32)))
(defmacro high32 (int64)
`(ash ,int64 -32))
(defmacro low32 (int64)
`(logand ,int64 +2^32-1+))
(defmacro split-64-bit-integer (int64)
`(values (ash ,int64 -32) (logand ,int64 +2^32-1+)))
;; Wrapper macro -- handles errno return values
;; makes flags into keywords
;; makes keyword args, cstring wrappers
(defvar *errno-buffer* (allocate-foreign-object :int 1))
(eval-when (:compile-toplevel)
(defun make-wrapper-args (args flags keys)
(if (or flags keys)
(append (remove-keys (remove 'flags args) keys)
`(&key , at flags , at keys))
(remove 'flags args)))
(defun remove-keys (args keys)
(if keys
(loop for key in keys
for kw = (if (atom key) key (first key))
for wrapper-args = (remove kw args) then (remove kw wrapper-args)
finally (return wrapper-args))
args))
(defun make-fun-args (args flags)
(if flags
(substitute (cons 'flags (symbols-to-kw-pairs flags)) 'flags args)
(substitute 0 'flags args)))
(defun make-out-args (count)
(loop for i from 1 to count
collect (gensym)))
(defun symbols-to-kw-pairs (symbols)
(loop for symbol in symbols
append (list (intern (symbol-name symbol) "KEYWORD")
symbol)))
(defun symbols-to-pairs (symbols)
(loop for symbol in symbols
collect (list symbol symbol)))
)
(defmacro wrap-errno (names args &key (keys nil) (flags nil)
(cstrings nil) (outs 1) (declarations nil)
(documentation nil)
(transaction nil))
(let ((wname (if (listp names) (first names) names))
(fname (if (listp names) (second names)
(intern (concatenate 'string "%" (symbol-name names)))))
(wrapper-args (make-wrapper-args args flags keys))
(fun-args (make-fun-args args flags))
(errno (gensym)))
(if (> outs 1)
(let ((out-args (make-out-args outs)))
`(defun ,wname ,wrapper-args
,@(if documentation (list documentation) (values))
,@(if declarations (list declarations) (values))
(with-cstrings ,(symbols-to-pairs cstrings)
(multiple-value-bind ,out-args
(,fname , at fun-args)
(let ((,errno ,(first out-args)))
(declare (type fixnum ,errno))
(cond
((= ,errno 0) (values ,@(rest out-args)))
,@(if transaction
(list `((or (= ,errno DB_LOCK_DEADLOCK)
(= ,errno DB_LOCK_NOTGRANTED))
(throw 'transaction ,transaction)))
(values))
(t (error 'db-error :errno ,errno))))))))
`(defun ,wname ,wrapper-args
,@(if documentation (list documentation) (values))
,@(if declarations (list declarations) (values))
(with-cstrings ,(symbols-to-pairs cstrings)
(let ((,errno (,fname , at fun-args)))
(declare (type fixnum ,errno))
(cond
((= ,errno 0) nil)
,@(if transaction
(list `((or (= ,errno DB_LOCK_DEADLOCK)
(= ,errno DB_LOCK_NOTGRANTED))
(throw 'transaction ,transaction)))
(values))
(t (error 'db-error :errno ,errno)))))))))
(defmacro flags (&key auto-commit joinenv init-cdb init-lock init-log
init-mpool init-rep init-txn recover recover-fatal lockdown
private system-mem thread force create excl nommap
degree-2 read-committed dirty-read read-uncommitted
rdonly truncate txn-nosync txn-nowait txn-sync lock-nowait
dup dup-sort current first get-both get-both-range last next
next-dup next-nodup prev prev-nodup set set-range
after before keyfirst keylast freelist-only free-space
no-dup-data no-overwrite nosync position
seq-dec seq-inc seq-wrap set-lock-timeout
set-transaction-timeout)
(let ((flags (gensym)))
`(let ((,flags 0))
(declare (type fixnum ,flags))
,@(when auto-commit `((when ,auto-commit (setq ,flags (logior ,flags DB_AUTO_COMMIT)))))
,@(when joinenv `((when ,joinenv (setq ,flags (logior ,flags DB_JOINENV)))))
,@(when init-cdb `((when ,init-cdb (setq ,flags (logior ,flags DB_INIT_CDB)))))
,@(when init-lock `((when ,init-lock (setq ,flags (logior ,flags DB_INIT_LOCK)))))
,@(when init-log `((when ,init-log (setq ,flags (logior ,flags DB_INIT_LOG)))))
,@(when init-mpool `((when ,init-mpool (setq ,flags (logior ,flags DB_INIT_MPOOL)))))
,@(when init-rep `((when ,init-rep (setq ,flags (logior ,flags DB_INIT_REP)))))
,@(when init-txn `((when ,init-txn (setq ,flags (logior ,flags DB_INIT_TXN)))))
,@(when recover `((when ,recover (setq ,flags (logior ,flags DB_RECOVER)))))
,@(when recover-fatal `((when ,recover-fatal (setq ,flags (logior ,flags DB_RECOVER_FATAL)))))
,@(when lockdown `((when ,lockdown (setq ,flags (logior ,flags DB_LOCKDOWN)))))
,@(when private `((when ,private (setq ,flags (logior ,flags DB_PRIVATE)))))
,@(when system-mem `((when ,system-mem (setq ,flags (logior ,flags DB_SYSTEM_MEM)))))
,@(when thread `((when ,thread (setq ,flags (logior ,flags DB_THREAD)))))
,@(when force `((when ,force (setq ,flags (logior ,flags DB_FORCE)))))
,@(when degree-2 `((when ,degree-2 (setq ,flags (logior ,flags DB_DEGREE_2)))))
,@(when read-committed `((when ,read-committed (setq ,flags (logior ,flags DB_READ_COMMITTED)))))
,@(when dirty-read `((when ,dirty-read (setq ,flags (logior ,flags DB_DIRTY_READ)))))
,@(when read-uncommitted `((when ,read-uncommitted (setq ,flags (logior ,flags DB_READ_UNCOMMITTED)))))
,@(when create `((when ,create (setq ,flags (logior ,flags DB_CREATE)))))
,@(when excl `((when ,excl (setq ,flags (logior ,flags DB_EXCL)))))
,@(when nommap `((when ,nommap (setq ,flags (logior ,flags DB_NOMMAP)))))
,@(when rdonly `((when ,rdonly (setq ,flags (logior ,flags DB_RDONLY)))))
,@(when truncate `((when ,truncate (setq ,flags (logior ,flags DB_TRUNCATE)))))
,@(when txn-nosync `((when ,txn-nosync (setq ,flags (logior ,flags DB_TXN_NOSYNC)))))
,@(when txn-nowait `((when ,txn-nowait (setq ,flags (logior ,flags DB_TXN_NOWAIT)))))
,@(when txn-sync `((when ,txn-sync (setq ,flags (logior ,flags DB_TXN_SYNC)))))
,@(when freelist-only `((when ,freelist-only (setq ,flags (logior ,flags DB_FREELIST_ONLY)))))
,@(when free-space `((when ,free-space (setq ,flags (logior ,flags DB_FREE_SPACE)))))
,@(when lock-nowait `((when ,lock-nowait (setq ,flags (logior ,flags DB_LOCK_NOWAIT)))))
,@(when dup `((when ,dup (setq ,flags (logior ,flags DB_DUP)))))
,@(when dup-sort `((when ,dup-sort (setq ,flags (logior ,flags DB_DUPSORT)))))
,@(when current `((when ,current (setq ,flags (logior ,flags DB_CURRENT)))))
,@(when first `((when ,first (setq ,flags (logior ,flags DB_FIRST)))))
,@(when get-both `((when ,get-both (setq ,flags (logior ,flags DB_GET_BOTH)))))
,@(when get-both-range `((when ,get-both-range (setq ,flags (logior ,flags DB_GET_BOTH_RANGE)))))
,@(when last `((when ,last (setq ,flags (logior ,flags DB_LAST)))))
,@(when next `((when ,next (setq ,flags (logior ,flags DB_NEXT)))))
,@(when next-dup `((when ,next-dup (setq ,flags (logior ,flags DB_NEXT_DUP)))))
,@(when next-nodup `((when ,next-nodup (setq ,flags (logior ,flags DB_NEXT_NODUP)))))
,@(when prev `((when ,prev (setq ,flags (logior ,flags DB_PREV)))))
,@(when prev-nodup `((when ,prev-nodup (setq ,flags (logior ,flags DB_PREV_NODUP)))))
,@(when set `((when ,set (setq ,flags (logior ,flags DB_SET)))))
,@(when set-range `((when ,set-range (setq ,flags (logior ,flags DB_SET_RANGE)))))
,@(when after `((when ,after (setq ,flags (logior ,flags DB_AFTER)))))
,@(when before `((when ,before (setq ,flags (logior ,flags DB_BEFORE)))))
,@(when keyfirst `((when ,keyfirst (setq ,flags (logior ,flags DB_KEYFIRST)))))
,@(when keylast `((when ,keylast (setq ,flags (logior ,flags DB_KEYLAST)))))
,@(when no-dup-data `((when ,no-dup-data (setq ,flags (logior ,flags DB_NODUPDATA)))))
,@(when no-overwrite `((when ,no-overwrite (setq ,flags (logior ,flags DB_NOOVERWRITE)))))
,@(when nosync `((when ,nosync (setq ,flags (logior ,flags DB_NOSYNC)))))
,@(when position `((when ,position (setq ,flags (logior ,flags DB_POSITION)))))
,@(when seq-dec `((when ,seq-dec (setq ,flags (logior ,flags DB_SEQ_DEC)))))
,@(when seq-inc `((when ,seq-inc (setq ,flags (logior ,flags DB_SEQ_INC)))))
,@(when seq-wrap `((when ,seq-wrap (setq ,flags (logior ,flags DB_SEQ_WRAP)))))
,@(when set-lock-timeout `((when ,set-lock-timeout (setq ,flags (logior ,flags DB_SET_LOCK_TIMEOUT)))))
,@(when set-transaction-timeout `((when ,set-transaction-timeout (setq ,flags (logior ,flags DB_SET_TXN_TIMEOUT)))))
,flags)))
;; Environment
(def-function ("db_env_cr" %db-env-create)
((flags :unsigned-int)
(errno :int :out))
:returning :pointer-void)
(defun db-env-create ()
"Create an environment handle."
(multiple-value-bind (env errno)
(%db-env-create 0)
(declare (type fixnum errno))
(if (= errno 0)
env
(error 'db-error :errno errno))))
(def-function ("db_env_close" %db-env-close)
((dbenvp :pointer-void)
(flags :unsigned-int))
:returning :int)
(wrap-errno db-env-close (dbenvp flags)
:documentation "Close an environment handle.")
(def-function ("db_env_open" %db-env-open)
((dbenvp :pointer-void)
(home :cstring)
(flags :unsigned-int)
(mode :int))
:returning :int)
(wrap-errno db-env-open (dbenvp home flags mode)
:flags (init-cdb init-lock init-log
[1502 lines skipped]
More information about the Elephant-cvs
mailing list