[elephant-cvs] CVS update: elephant/src/sleepycat.lisp

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 ,@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 ,@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 ,@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