[elephant-cvs] CVS update: elephant/src/sleepycat.lisp
blee at common-lisp.net
blee at common-lisp.net
Fri Aug 27 02:54:40 UTC 2004
Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp.net:/tmp/cvs-serv23640/src
Modified Files:
sleepycat.lisp
Log Message:
beginning of lock and cursor support
Date: Thu Aug 26 19:54:39 2004
Author: blee
Index: elephant/src/sleepycat.lisp
diff -u elephant/src/sleepycat.lisp:1.1.1.1 elephant/src/sleepycat.lisp:1.2
--- elephant/src/sleepycat.lisp:1.1.1.1 Thu Aug 19 10:05:14 2004
+++ elephant/src/sleepycat.lisp Thu Aug 26 19:54:38 2004
@@ -12,44 +12,83 @@
(defpackage sleepycat
(:use common-lisp uffi)
- (:export write-int write-unsigned-int write-double
- read-int read-unsigned-int read-double copy-str-to-buf
- *current-transaction*
+ (:export read-int read-uint read-float read-double
+ write-int write-uint write-float write-double
+ offset-char-pointer copy-str-to-buf copy-bufs byte-length
pointer-int pointer-void array-or-pointer-char
db-env-create db-env-close db-env-open db-env-dbremove
- db-env-dbrename db-env-remove db-create db-close db-open
+ db-env-dbrename db-env-remove db-env-set-flags
+ db-env-get-flags
+ db-create db-close db-open
db-remove db-rename db-sync db-truncate
db-get-key-buffered db-get-buffered db-get db-put-buffered db-put
db-delete-buffered db-delete
+ *current-transaction*
db-transaction-begin db-transaction-abort db-transaction-commit
with-transaction with-transaction-retry
- db-error
- DBTYPE#BTREE DBTYPE#HASH DBTYPE#QUEUE DBTYPE#RECNO
- DBTYPE#UNKNOWN +NULL-VOID+ +NULL-CHAR+))
+ db-transaction-id db-env-lock-id db-env-lock-id-free
+ db-env-set-timeout db-env-get-timeout
+ db-env-set-lock-detect db-env-get-lock-detect
+ DB-BTREE DB-HASH DB-QUEUE DB-RECNO DB-UNKNOWN
+ +NULL-VOID+ +NULL-CHAR+
+ db-error db-error-errno
+ DB_KEYEMPTY DB_LOCK_DEADLOCK DB_LOCK_NOTGRANTED DB_NOTFOUND
+ ))
(in-package "SLEEPYCAT")
(eval-when (:compile-toplevel :load-toplevel)
(def-type pointer-int (* :int))
(def-type pointer-void :pointer-void)
- (def-foreign-type array-or-pointer-char
+ (def-foreign-type array-or-pointer-char
#+allegro (:array :char)
- #-allegro (* :char))
+ #+(or cmu sbcl scl) (* :char))
(def-type array-or-pointer-char array-or-pointer-char)
+ (def-enum DBTYPE ((:BTREE 1) :HASH :QUEUE :RECNO :UNKNOWN))
)
-(declaim (inline write-int write-unsigned-int write-double
- read-int read-unsigned-int read-double copy-buf
- %db-get-raw db-get-key-buffered db-get-buffered db-get
- %db-put-raw db-put-buffered db-put
+(declaim (inline read-int read-uint read-float read-double
+ write-int write-uint write-float write-double
+ offset-char-pointer copy-str-to-buf copy-bufs
+ %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-env-txn-begin db-transaction-begin
- %db-env-txn-begin2 db-transaction-begin2
+ %db-txn-begin db-transaction-begin
%db-txn-abort db-transaction-abort
%db-txn-commit db-transaction-commit
flags))
-;; Pointer arithmetic utility functions
+;; Buffer management / pointer arithmetic
+
+;; Notes: on CMUCL and Allegro: with-cast-pointer +
+;; deref-array is faster than FFI + C pointer arithmetic.
+;; however pointer arithmetic is usually consing. OpenMCL
+;; supports non-consing pointer arithmentic though.
+
+
+;; TODO: #+openmcl versions which do macptr arith.
+
+(def-function ("read_int" read-int)
+ ((buf array-or-pointer-char)
+ (offset :int))
+ :returning :int)
+
+(def-function ("read_uint" read-uint)
+ ((buf array-or-pointer-char)
+ (offset :int))
+ :returning :unsigned-int)
+
+(def-function ("read_float" read-float)
+ ((buf array-or-pointer-char)
+ (offset :int))
+ :returning :float)
+
+(def-function ("read_double" read-double)
+ ((buf array-or-pointer-char)
+ (offset :int))
+ :returning :double)
(def-function ("write_int" write-int)
((buf array-or-pointer-char)
@@ -57,33 +96,50 @@
(offset :int))
:returning :void)
-(def-function ("write_uint" write-unsigned-int)
+(def-function ("write_uint" write-uint)
((buf array-or-pointer-char)
(num :unsigned-int)
(offset :int))
:returning :void)
-(def-function ("write_double" write-double)
+(def-function ("write_float" write-float)
((buf array-or-pointer-char)
- (num :double)
+ (num :float)
(offset :int))
:returning :void)
-(def-function ("read_int" read-int)
+(def-function ("write_double" write-double)
((buf array-or-pointer-char)
+ (num :double)
(offset :int))
- :returning :int)
+ :returning :void)
-(def-function ("read_uint" read-uint)
- ((buf array-or-pointer-char)
+(def-function ("offset_charp" offset-char-pointer)
+ ((p array-or-pointer-char)
(offset :int))
- :returning :unsigned-int)
+ :returning array-or-pointer-char)
-(def-function ("read_double" read-double)
- ((buf array-or-pointer-char)
- (offset :int))
- :returning :double)
+;; Allegro and Lispworks use 16-bit unicode characters
+(defmacro byte-length (s)
+ #+(or lispworks (and allegro ics))
+ `(let ((l (length ,s))) (+ l l))
+ #-(or lispworks (and allegro ics))
+ `(length ,s))
+
+;; for copying the bytes of a string to a foreign buffer
+;; memcpy is faster than looping! For Lispworks this causes
+;; a string to array conversion, but I don't know how to do
+;; any better (fli:replace-foreign-array is promising?)
+#-(or cmu sbcl scl openmcl)
+(def-function ("copy_buf" copy-str-to-buf)
+ ((dest array-or-pointer-char)
+ (dest-offset :int)
+ (src array-or-pointer-char)
+ (src-offset :int)
+ (length :int))
+ :returning :void)
+#+(or cmu sbcl scl)
(def-function ("copy_buf" copy-str-to-buf)
((dest array-or-pointer-char)
(dest-offset :int)
@@ -92,6 +148,48 @@
(length :int))
:returning :void)
+;; but OpenMCL can't directly pass string bytes.
+#+openmcl
+(defun copy-str-to-buf (dest dest-offset src src-offset length)
+ (declare (optimize (speed 3) (safety 0))
+ (type string src)
+ (type array-or-pointer-char dest)
+ (type fixnum length src-offset dest-offset)
+ (dynamic-extent src dest length))
+ (multiple-value-bind (ivector disp)
+ (ccl::array-data-and-offset src)
+ (ccl::%copy-ivector-to-ptr src (+ disp src-offset)
+ dest dest-offset length)))
+
+;; Lisp version, for kicks. this assumes 8-bit chars!
+#+(not (or cmu sbcl scl allegro openmcl lispworks))
+(defun copy-str-to-buf (dest dest-offset src src-offset length)
+ (declare (optimize (speed 3) (safety 0))
+ (type string src)
+ (type array-or-pointer-char dest)
+ (type fixnum length src-offset dest-offset)
+ (dynamic-extent src dest length))
+ (typecase src
+ (simple-string
+ (loop for i fixnum from 0 below length
+ do
+ (setf (deref-array dest 'array-or-pointer-char (+ i dest-offset))
+ (char-code (schar src (+ i src-offset))))))
+ (string
+ (loop for i fixnum from 0 below length
+ do
+ (setf (deref-array dest 'array-or-pointer-char (+ i dest-offset))
+ (char-code (char src (+ i src-offset))))))))
+
+;; For copying two foreign buffers
+(def-function ("copy_buf" copy-bufs)
+ ((dest array-or-pointer-char)
+ (dest-offset :int)
+ (src array-or-pointer-char)
+ (src-offset :int)
+ (length :int))
+ :returning :void)
+
;; Thread local storage (special variables)
(defconstant +NULL-VOID+ (make-null-pointer :void))
@@ -101,16 +199,14 @@
(defvar *errno-buffer* (allocate-foreign-object :int 1))
-(declaim (type array-or-pointer-char *get-buffer* *key-buffer*)
- (type fixnum *get-buffer-length* *key-buffer-length*))
+(declaim (type array-or-pointer-char *get-buffer*)
+ (type fixnum *get-buffer-length*))
-(defvar *get-buffer*)
-(setq *get-buffer* (allocate-foreign-object :char 1))
+(defvar *get-buffer* (allocate-foreign-object :char 1))
(defvar *get-buffer-length* 0)
-(defun resize-get-buffer (buf length)
+(defun resize-get-buffer (length)
(declare (optimize (speed 3) (safety 0) (space 0))
- (ignore buf)
(type fixnum length))
(if (< length *get-buffer-length*)
(values *get-buffer* *get-buffer-length*)
@@ -121,32 +217,6 @@
(setq *get-buffer* (allocate-foreign-object :char newlen))
(values *get-buffer* *get-buffer-length*))))
-(defvar *key-buffer*)
-(setq *key-buffer* (allocate-foreign-object :char 1))
-(defvar *key-buffer-length* 0)
-
-(defun resize-key-buffer (buf length)
- (declare (optimize (speed 3) (safety 0) (space 0))
- (ignore buf)
- (type fixnum length))
- (if (< length *key-buffer-length*)
- (values *key-buffer* *key-buffer-length*)
- (let ((newlen (max length (* *key-buffer-length* 2))))
- (declare (type fixnum newlen))
- (setq *key-buffer-length* newlen)
- (free-foreign-object *key-buffer*)
- (setq *key-buffer* (allocate-foreign-object :char newlen))
- (values *key-buffer* *key-buffer-length*))))
-
-(defun fill-key-buffer (key &key (key-length (length key)))
- (declare (optimize (speed 3) (safety 0) (space 0))
- (type string key)
- (type fixnum key-length)
- (dynamic-extent key-length))
- (when (< *key-buffer-length* key-length) (resize-key-buffer nil key-length))
- (with-cstring (k key)
- (copy-str-to-buf *key-buffer* 0 k 0 key-length)))
-
;; Wrapper macro -- handles errno return values
;; makes flags into keywords
;; makes keyword args, cstring wrappers
@@ -245,10 +315,10 @@
:returning :int)
(wrap-errno db-env-open (dbenvp home flags mode)
- :flags (db-joinenv db-init-cdb db-init-lock db-init-log
- db-init-mpool db-init-rep db-init-txn
- db-recover db-recover-fatal db-create
- db-lockdown db-private db-system-mem db-thread)
+ :flags (joinenv init-cdb init-lock init-log
+ init-mpool init-rep init-txn
+ recover recover-fatal create
+ lockdown private system-mem thread)
:keys ((mode #o640))
:cstrings (home))
@@ -287,9 +357,26 @@
(flags :unsigned-int))
:returning :int)
-(wrap-errno db-env-remove (env home flags) :flags (db-force)
+(wrap-errno db-env-remove (env home flags) :flags (force)
:cstrings (home))
+(def-function ("db_env_set_flags" %db-env-set-flags)
+ ((env :pointer-void)
+ (flags :unsigned-int)
+ (onoff :int))
+ :returning :int)
+
+(wrap-errno db-env-set-flags (env flags onoff)
+ :flags (auto-commit nommap txn-nosync))
+
+(def-function ("db_env_get_flags" %db-env-get-flags)
+ ((env :pointer-void)
+ (flags :unsigned-int :out))
+ :returning :int)
+
+(wrap-errno db-env-get-flags (env) :outs 2)
+
+
;; Database
(def-function ("db_cr" %db-create)
@@ -313,8 +400,6 @@
(wrap-errno db-close (db flags))
-(def-enum DBTYPE ((:BTREE 1) :HASH :QUEUE :RECNO :UNKNOWN))
-
(def-function ("db_open" %db-open)
((db :pointer-void)
(txn :pointer-void)
@@ -326,12 +411,12 @@
:returning :int)
(wrap-errno db-open (db transaction file database type flags mode)
- :flags (auto-commit db-create db-dirty-read db-excl db-nommap
- db-rdonly db-thread db-truncate)
+ :flags (auto-commit create dirty-read excl nommap
+ rdonly thread truncate)
:keys ((transaction *current-transaction*)
(file +NULL-CHAR+)
(database +NULL-CHAR+)
- (type DBTYPE#UNKNOWN)
+ (type DB-UNKNOWN)
(mode #o640))
:cstrings (file database))
@@ -388,36 +473,30 @@
(result-length :unsigned-int :out))
:returning :int)
-(defun db-get-key-buffered (db &key
- (key-buffer *key-buffer*)
- (key-length *key-buffer-length*)
- (buffer *get-buffer*)
- (buffer-length *get-buffer-length*)
- (resize-function #'resize-get-buffer)
- (transaction *current-transaction*)
- auto-commit db-get-both db-dirty-read)
+(defun db-get-key-buffered (db key-buffer key-length &key
+ (transaction *current-transaction*)
+ auto-commit get-both dirty-read)
(declare (optimize (speed 3) (safety 0) (space 0))
(type pointer-void db transaction)
- (type array-or-pointer-char key-buffer buffer)
- (type fixnum key-length buffer-length)
- (type boolean auto-commit db-get-both db-dirty-read))
+ (type array-or-pointer-char key-buffer)
+ (type fixnum key-length)
+ (type boolean auto-commit get-both dirty-read))
(loop
do
(multiple-value-bind (errno result-length)
(%db-get-key-buffered db transaction key-buffer key-length
- buffer buffer-length
+ *get-buffer* *get-buffer-length*
(flags :auto-commit auto-commit
- :db-get-both db-get-both
- :db-dirty-read db-dirty-read))
+ :get-both get-both
+ :dirty-read dirty-read))
(declare (type fixnum result-length errno))
- (if (<= result-length buffer-length)
+ (if (<= result-length *get-buffer-length*)
(if (= errno 0)
(return-from db-get-key-buffered
(the (values array-or-pointer-char fixnum)
- (values buffer result-length)))
+ (values *get-buffer* result-length)))
(error 'db-error :errno errno))
- (multiple-value-setq (buffer buffer-length)
- (funcall resize-function buffer result-length))))))
+ (resize-get-buffer result-length)))))
(def-function ("db_get_raw" %db-get-buffered)
((db :pointer-void)
@@ -432,66 +511,57 @@
(defun db-get-buffered (db key &key
(key-length (length key))
- (buffer *get-buffer*)
- (buffer-length *get-buffer-length*)
- (resize-function #'resize-get-buffer)
(transaction *current-transaction*)
- auto-commit db-get-both db-dirty-read)
+ auto-commit get-both dirty-read)
(declare (optimize (speed 3) (safety 0) (space 0))
(type pointer-void db transaction)
(type string key)
- (type array-or-pointer-char buffer)
- (type fixnum key-length buffer-length)
- (type boolean auto-commit db-get-both db-dirty-read))
+ (type fixnum key-length)
+ (type boolean auto-commit get-both dirty-read))
(with-cstring (k key)
(loop
do
(multiple-value-bind (errno result-length)
(%db-get-buffered db transaction k key-length
- buffer buffer-length
+ *get-buffer* *get-buffer-length*
(flags :auto-commit auto-commit
- :db-get-both db-get-both
- :db-dirty-read db-dirty-read))
+ :get-both get-both
+ :dirty-read dirty-read))
(declare (type fixnum result-length errno))
- (if (<= result-length buffer-length)
+ (if (<= result-length *get-buffer-length*)
(if (= errno 0)
(return-from db-get-buffered
(the (values array-or-pointer-char fixnum)
- (values buffer result-length)))
+ (values *get-buffer* result-length)))
(error 'db-error :errno errno))
- (multiple-value-setq (buffer buffer-length)
- (funcall resize-function buffer result-length)))))))
+ (resize-get-buffer result-length))))))
(defun db-get (db key &key (key-length (length key))
- (buffer *get-buffer*)
- (buffer-length *get-buffer-length*)
- (resize-function #'resize-get-buffer)
(transaction *current-transaction*)
- auto-commit db-get-both db-dirty-read)
+ auto-commit get-both dirty-read)
(declare (optimize (speed 3) (safety 0) (space 0))
(type pointer-void db transaction)
(type string key)
- (type array-or-pointer-char buffer)
- (type fixnum key-length buffer-length)
- (type boolean auto-commit db-get-both db-dirty-read))
+ (type fixnum key-length)
+ (type boolean auto-commit get-both dirty-read))
(with-cstring (k key)
(loop
do
(multiple-value-bind (errno result-length)
(%db-get-buffered db transaction k key-length
- buffer buffer-length
+ *get-buffer* *get-buffer-length*
(flags :auto-commit auto-commit
- :db-get-both db-get-both
- :db-dirty-read db-dirty-read))
+ :get-both get-both
+ :dirty-read dirty-read))
(declare (type fixnum result-length errno))
- (if (<= result-length buffer-length)
+ (if (<= result-length *get-buffer-length*)
(if (= errno 0)
(return-from db-get
- (convert-from-foreign-string buffer :length result-length
+ (convert-from-foreign-string *get-buffer*
+ :length result-length
:null-terminated-p nil))
(error 'db-error :errno errno))
- (multiple-value-setq (buffer buffer-length)
- (funcall resize-function buffer result-length)))))))
+ (resize-get-buffer result-length))))))
(def-function ("db_put_raw" %db-put-buffered)
((db :pointer-void)
@@ -573,7 +643,7 @@
;; Transactions
-(def-function ("db_env_txn_begin" %db-env-txn-begin)
+(def-function ("db_txn_begin" %db-txn-begin)
((env :pointer-void)
(parent :pointer-void)
(flags :unsigned-int)
@@ -581,20 +651,20 @@
:returning :pointer-void)
(defun db-transaction-begin (env &key (parent *current-transaction*)
- db-dirty-read db-txn-nosync db-txn-nowait
- db-txn-sync)
+ dirty-read txn-nosync txn-nowait
+ txn-sync)
(declare (optimize (speed 3) (safety 0) (space 0))
(type pointer-void env parent)
- (type boolean db-dirty-read db-txn-nosync db-txn-nowait
- db-txn-sync)
+ (type boolean dirty-read txn-nosync txn-nowait
+ txn-sync)
(type pointer-int *errno-buffer*))
(let* ((txn
- (%db-env-txn-begin env parent
- (flags :db-dirty-read db-dirty-read
- :db-txn-nosync db-txn-nosync
- :db-txn-nowait db-txn-nowait
- :db-txn-sync db-txn-sync)
- *errno-buffer*))
+ (%db-txn-begin env parent
+ (flags :dirty-read dirty-read
+ :txn-nosync txn-nosync
+ :txn-nowait txn-nowait
+ :txn-sync txn-sync)
+ *errno-buffer*))
(errno (deref-array *errno-buffer* '(:array :int) 0)))
(declare (type pointer-void txn)
(type fixnum errno))
@@ -618,51 +688,71 @@
(wrap-errno (db-transaction-commit %db-txn-commit) (transaction flags)
:keys ((transaction *current-transaction*))
- :flags (db-txn-nosync db-txn-sync)
+ :flags (txn-nosync txn-sync)
:declarations (declare (optimize (speed 3) (safety 0) (space 0))
(type pointer-void transaction)
- (type boolean db-txn-nosync db-txn-sync)))
+ (type boolean txn-nosync txn-sync)))
(defmacro with-transaction ((&key transaction environment
(globally t)
(parent *current-transaction*)
- db-dirty-read db-txn-nosync
- db-txn-nowait db-txn-sync)
+ dirty-read txn-nosync
+ txn-nowait txn-sync)
&body body)
- (let ((last-transaction (gensym))
- (txn (if transaction transaction (gensym)))
+ (let ((txn (if transaction transaction (gensym)))
(success (gensym)))
- `(let (,@(if globally `(,last-transaction *current-transaction*)
- (values))
- (,txn (db-transaction-begin ,environment
- :parent ,parent
- :db-dirty-read ,db-dirty-read
- :db-txn-nosync ,db-txn-nosync
- :db-txn-nowait ,db-txn-nowait
- :db-txn-sync ,db-txn-sync))
- (,success nil))
+ `(let* ((,txn (db-transaction-begin ,environment
+ :parent ,parent
+ :dirty-read ,dirty-read
+ :txn-nosync ,txn-nosync
+ :txn-nowait ,txn-nowait
+ :txn-sync ,txn-sync))
+ (,success nil)
+ ,@(if globally `((*current-transaction* ,txn))
+ (values)))
+ (declare (dynamic-extent ,txn ,success)
+ (type pointer-void ,txn)
+ (type boolean ,success))
(unwind-protect
- (progn
- ,@(if globally `((setq *current-transaction* ,txn))
- (values))
- (prog1
- (progn , at body)
- (setq ,success t)
- (db-transaction-commit :transaction ,txn
- :db-txn-nosync ,db-txn-nosync
- :db-txn-sync ,db-txn-sync)))
- (progn
- ,@(if globally
- `((setq *current-transaction* ,last-transaction))
- (values))
- (unless ,success (db-transaction-abort :transaction ,txn)))))))
+ (prog1
+ (progn , at body)
+ (setq ,success t)
+ (db-transaction-commit :transaction ,txn
+ :txn-nosync ,txn-nosync
+ :txn-sync ,txn-sync))
+ (unless ,success (db-transaction-abort :transaction ,txn))))))
+
+;; this is code for a non-consing with-transaction. which
+;; doesn't work in the (globally t) case (e.g. setting
+;; *current-transaction*.)
+
+; #+cmu
+; `(alien:with-alien ((,txn (* t)
+; (%db-txn-begin
+; ,environment ,parent
+; (flags :dirty-read ,dirty-read
+; :txn-nosync ,txn-nosync
+; :txn-nowait ,txn-nowait
+; :txn-sync ,txn-sync)
+; *errno-buffer*)))
+; (let ((,success nil)
+; ,@(if globally `((*current-transaction* ,txn)) (values)))
+; (declare (type pointer-void *current-transaction*)
+; (dynamic-extent *current-transaction*))
+; (unwind-protect
+; (prog1 (progn , at body)
+; (setq ,success t)
+; (%db-txn-commit ,txn
+; (flags :txn-nosync ,txn-nosync
+; :txn-sync ,txn-sync)))
+; (unless ,success (%db-txn-abort ,txn)))))))
(defmacro with-transaction-retry ((&key transaction environment
(globally t)
(parent *current-transaction*)
(retries 100)
- db-dirty-read db-txn-nosync
- db-txn-nowait db-txn-sync)
+ dirty-read txn-nosync
+ txn-nowait txn-sync)
&body body)
(let ((ret-tag (gensym))
(retry-count (gensym)))
@@ -673,17 +763,112 @@
:environment ,environment
:globally ,globally
:parent ,parent
- :db-dirty-read ,db-dirty-read
- :db-txn-nosync ,db-txn-nosync
- :db-txn-nowait ,db-txn-nowait
- :db-txn-sync ,db-txn-sync)
+ :dirty-read ,dirty-read
+ :txn-nosync ,txn-nosync
+ :txn-nowait ,txn-nowait
+ :txn-sync ,txn-sync)
,body)
(db-error (err)
(if (< (incf ,retry-count) ,retries)
(go ,ret-tag)
(error err))))))))
+;; Locks and timeouts
+
+(def-enum lockop ((:DUMP 0) :GET :GET-TIMEOUT :INHERIT
+ :PUT :PUT-ALL :PUT-OBJ :PUT-READ
+ :TIMEOUT :TRADE :UPGRADE-WRITE))
+
+(def-enum lockmode ((:NG 0) :READ :WRITE :WAIT
+ :IWRITE :IREAD :IWR :DIRTY :WWRITE))
+
+(def-struct db-lockreq
+ (op lockop)
+ (mode lockmode)
+ (timeout :unsigned-int)
+ (obj (:array :char))
+ (lock :pointer-void))
+
+
+(def-function ("db_txn_id" db-transaction-id)
+ ((transaction :pointer-void))
+ :returning :unsigned-int)
+
+
+(def-function ("db_env_lock_id" %db-env-lock-id)
+ ((env :pointer-void)
+ (id :unsigned-int :out))
+ :returning :int)
+
+(wrap-errno db-env-lock-id (env) :outs 2)
+
+
+(def-function ("db_env_lock_id_free" %db-env-lock-id-free)
+ ((env :pointer-void)
+ (id :unsigned-int))
+ :returning :int)
+
+(wrap-errno db-env-lock-id-free (env id))
+
+(def-function ("db_env_set_timeout" %db-env-set-timeout)
+ ((env :pointer-void)
+ (timeout :unsigned-int)
+ (flags :unsigned-int))
+ :returning :int)
+
+(wrap-errno db-env-set-timeout (env timeout flags)
+ :flags (set-lock-timeout set-transaction-timeout))
+
+(def-function ("db_env_get_timeout" %db-env-get-timeout)
+ ((env :pointer-void)
+ (timeout :unsigned-int :out)
+ (flags :unsigned-int))
+ :returning :int)
+
+(wrap-errno db-env-get-timeout (env flags) :outs 2
+ :flags (set-lock-timeout set-transaction-timeout))
+
+(defconstant DB_LOCK_DEFAULT 1)
+(defconstant DB_LOCK_EXPIRE 2)
+(defconstant DB_LOCK_MAXLOCKS 3)
+(defconstant DB_LOCK_MINLOCKS 4)
+(defconstant DB_LOCK_MINWRITE 5)
+(defconstant DB_LOCK_OLDEST 6)
+(defconstant DB_LOCK_RANDOM 7)
+(defconstant DB_LOCK_YOUNGEST 8)
+
+(def-function ("db_env_set_lk_detect" %db-env-set-lock-detect)
+ ((env :pointer-void)
+ (detect :unsigned-int))
+ :returning :int)
+
+(wrap-errno db-env-set-lock-detect (env detect))
+
+(def-function ("db_env_get_lk_detect" %db-env-get-lock-detect)
+ ((env :pointer-void)
+ (detect :unsigned-int :out))
+ :returning :int)
+
+(wrap-errno db-env-get-lock-detect (env) :outs 2)
+
+(def-function ("db_env_lock_detect" %db-env-lock-detect)
+ ((env :pointer-void)
+ (flags :unsigned-int)
+ (atype :unsigned-int)
+ (aborted :int :out))
+ :returning :int)
+
+(wrap-errno db-env-lock-detect (env flags atype) :outs 2)
+
;; 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-QUEUE 3)
+(defconstant DB-RECNO 4)
+(defconstant DB-UNKNOWN 5)
(defconstant DB_AUTO_COMMIT #x1000000)
(defconstant DB_JOINENV #x0040000)
@@ -700,7 +885,6 @@
(defconstant DB_SYSTEM_MEM #x0400000)
(defconstant DB_THREAD #x0000040)
(defconstant DB_FORCE #x0000004)
-(defconstant DB_GET_BOTH 10)
(defconstant DB_DIRTY_READ #x2000000)
(defconstant DB_CREATE #x0000001)
(defconstant DB_EXCL #x0001000)
@@ -711,69 +895,84 @@
(defconstant DB_TXN_NOWAIT #x0001000)
(defconstant DB_TXN_SYNC #x0002000)
+(defconstant DB_GET_BOTH 10)
+(defconstant DB_SET_LOCK_TIMEOUT 29)
+(defconstant DB_SET_TXN_TIMEOUT 33)
+
(defun flags (&key
auto-commit
- db-joinenv
- db-init-cdb
- db-init-lock
- db-init-log
- db-init-mpool
- db-init-rep
- db-init-txn
- db-recover
- db-recover-fatal
- db-lockdown
- db-private
- db-system-mem
- db-thread
- db-force
- db-get-both
- db-dirty-read
- db-create
- db-excl
- db-nommap
- db-rdonly
- db-truncate
- db-txn-nosync
- db-txn-nowait
- db-txn-sync)
+ joinenv
+ init-cdb
+ init-lock
+ init-log
+ init-mpool
+ init-rep
+ init-txn
+ recover
+ recover-fatal
+ lockdown
+ private
+ system-mem
+ thread
+ force
+ get-both
+ dirty-read
+ create
+ excl
+ nommap
+ rdonly
+ truncate
+ txn-nosync
+ txn-nowait
+ txn-sync
+ set-lock-timeout
+ set-transaction-timeout)
(let ((flags 0))
(declare (optimize (speed 3) (safety 0) (space 0))
(type (unsigned-byte 32) flags)
- (type boolean auto-commit db-joinenv db-init-cdb db-init-lock
- db-init-log db-init-mpool db-init-rep db-init-txn
- db-recover db-recover-fatal db-lockdown db-private
- db-system-mem db-thread db-force db-get-both
- db-dirty-read db-create db-excl db-nommap db-rdonly
- db-truncate db-txn-nosync db-txn-nowait))
+ (type boolean auto-commit joinenv init-cdb init-lock
+ init-log init-mpool init-rep init-txn
+ recover recover-fatal lockdown private
+ system-mem thread force get-both
+ dirty-read create excl nommap rdonly
+ truncate txn-nosync txn-nowait
+ set-lock-timeout set-transaction-timeout))
(when auto-commit (setq flags (logior flags DB_AUTO_COMMIT)))
- (when db-joinenv (setq flags (logior flags DB_JOINENV)))
- (when db-init-cdb (setq flags (logior flags DB_INIT_CDB)))
- (when db-init-lock (setq flags (logior flags DB_INIT_LOCK)))
- (when db-init-log (setq flags (logior flags DB_INIT_LOG)))
- (when db-init-mpool (setq flags (logior flags DB_INIT_MPOOL)))
- (when db-init-rep (setq flags (logior flags DB_INIT_REP)))
- (when db-init-txn (setq flags (logior flags DB_INIT_TXN)))
- (when db-recover (setq flags (logior flags DB_RECOVER)))
- (when db-recover-fatal (setq flags (logior flags DB_RECOVER_FATAL)))
- (when db-lockdown (setq flags (logior flags DB_LOCKDOWN)))
- (when db-private (setq flags (logior flags DB_PRIVATE)))
- (when db-system-mem (setq flags (logior flags DB_SYSTEM_MEM)))
- (when db-thread (setq flags (logior flags DB_THREAD)))
- (when db-force (setq flags (logior flags DB_FORCE)))
- (when db-get-both (setq flags (logior flags DB_GET_BOTH)))
- (when db-dirty-read (setq flags (logior flags DB_DIRTY_READ)))
- (when db-create (setq flags (logior flags DB_CREATE)))
- (when db-excl (setq flags (logior flags DB_EXCL)))
- (when db-nommap (setq flags (logior flags DB_NOMMAP)))
- (when db-rdonly (setq flags (logior flags DB_RDONLY)))
- (when db-truncate (setq flags (logior flags DB_TRUNCATE)))
- (when db-txn-nosync (setq flags (logior flags DB_TXN_NOSYNC)))
- (when db-txn-nowait (setq flags (logior flags DB_TXN_NOWAIT)))
- (when db-txn-sync (setq flags (logior flags DB_TXN_SYNC)))
+ (when joinenv (setq flags (logior flags DB_JOINENV)))
+ (when init-cdb (setq flags (logior flags DB_INIT_CDB)))
+ (when init-lock (setq flags (logior flags DB_INIT_LOCK)))
+ (when init-log (setq flags (logior flags DB_INIT_LOG)))
+ (when init-mpool (setq flags (logior flags DB_INIT_MPOOL)))
+ (when init-rep (setq flags (logior flags DB_INIT_REP)))
+ (when init-txn (setq flags (logior flags DB_INIT_TXN)))
+ (when recover (setq flags (logior flags DB_RECOVER)))
+ (when recover-fatal (setq flags (logior flags DB_RECOVER_FATAL)))
+ (when lockdown (setq flags (logior flags DB_LOCKDOWN)))
+ (when private (setq flags (logior flags DB_PRIVATE)))
+ (when system-mem (setq flags (logior flags DB_SYSTEM_MEM)))
+ (when thread (setq flags (logior flags DB_THREAD)))
+ (when force (setq flags (logior flags DB_FORCE)))
+ (when get-both (setq flags (logior flags DB_GET_BOTH)))
+ (when dirty-read (setq flags (logior flags DB_DIRTY_READ)))
+ (when create (setq flags (logior flags DB_CREATE)))
+ (when excl (setq flags (logior flags DB_EXCL)))
+ (when nommap (setq flags (logior flags DB_NOMMAP)))
+ (when rdonly (setq flags (logior flags DB_RDONLY)))
+ (when truncate (setq flags (logior flags DB_TRUNCATE)))
+ (when txn-nosync (setq flags (logior flags DB_TXN_NOSYNC)))
+ (when txn-nowait (setq flags (logior flags DB_TXN_NOWAIT)))
+ (when txn-sync (setq flags (logior flags DB_TXN_SYNC)))
+ (when set-lock-timeout (setq flags (logior flags DB_SET_LOCK_TIMEOUT)))
+ (when set-transaction-timeout (setq flags (logior flags DB_SET_TXN_TIMEOUT)))
flags))
;; Errors
+
+(defconstant DB_KEYEMPTY -30997)
+(defconstant DB_LOCK_DEADLOCK -30995)
+(defconstant DB_LOCK_NOTGRANTED -30994)
+(defconstant DB_NOTFOUND -30990)
+
(def-function ("db_strerr" %db-strerror)
((error :int))
:returning :cstring)
@@ -788,11 +987,3 @@
(declare (type db-error condition) (type stream stream))
(format stream "Berkeley DB error: ~A"
(db-strerror (db-error-errno condition))))))
-
-(define-condition buffer-too-small-error (error)
- ((length-needed :initarg :length :reader length-needed))
- (:report
- (lambda (condition stream)
- (declare (type buffer-too-small-error condition) (type stream stream))
- (format stream "buffer-too-small-error: needed ~D bytes!"
- (length-needed condition)))))
\ No newline at end of file
More information about the Elephant-cvs
mailing list