Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv25936/src

Modified Files: sleepycat.lisp Log Message: split off berkeley-db doc-strings buffer-streamified cmu pointer arithmetic

Date: Thu Sep 16 06:22:41 2004 Author: blee

Index: elephant/src/sleepycat.lisp diff -u elephant/src/sleepycat.lisp:1.9 elephant/src/sleepycat.lisp:1.10 --- elephant/src/sleepycat.lisp:1.9 Thu Sep 2 16:47:09 2004 +++ elephant/src/sleepycat.lisp Thu Sep 16 06:22:41 2004 @@ -42,20 +42,54 @@

(defpackage sleepycat + (:documentation "A low-level UFFI-based interface to +Berkeley DB / Sleepycat, via the libsleepycat.c wrapper. +Partly intended to be usable outside Elephant, but with some +magic for Elephant. In general there is a 1-1 mapping from +functions here and functions in Sleepycat, so refer to their +documentation for details.") (:use common-lisp uffi) + #+cmu + (:use alien) + #+sbcl + (:use sb-alien) + #+cmu + (:import-from :sys + #:sap+) + #+sbcl + (:import-from :sb-sys + #:sap+) + #+openmcl + (:import-from :ccl + #:byte-length) (:export #:*current-transaction* - #: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 + + #:buffer-stream #:make-buffer-stream #:with-buffer-streams + #:resize-buffer-stream #:resize-buffer-stream-no-copy + #:reset-buffer-stream #:buffer-stream-buffer + #:buffer-write-byte #:buffer-write-int + #:buffer-write-uint #:buffer-write-float #:buffer-write-double + #:buffer-write-string #:buffer-read-byte #:buffer-read-fixnum + #:buffer-read-int #:buffer-read-uint #:buffer-read-float + #:buffer-read-double #:buffer-read-string #: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-env-set-flags #:db-env-get-flags #:db-create #:db-close #:db-open #:db-remove #:db-rename #:db-sync #:db-truncate + #:db-set-flags #:db-get-flags #:db-get-key-buffered #:db-get-buffered #:db-get #:db-put-buffered #:db-put #:db-delete-buffered #:db-delete + #:db-cursor #:db-cursor-close #:db-cursor-delete + #:db-cursor-duplicate + #:db-cursor-move-buffered #:db-cursor-set-buffered + #:db-cursor-get-both-buffered + #:db-cursor-pmove-buffered #:db-cursor-pset-buffered + #:db-cursor-pget-both-buffered #:db-cursor-put-buffered #:db-transaction-begin #:db-transaction-abort #:db-transaction-commit #:with-transaction #:db-transaction-id #:db-env-lock-id #:db-env-lock-id-free @@ -63,6 +97,7 @@ #:db-env-set-timeout #:db-env-get-timeout #:db-env-set-lock-detect #:db-env-get-lock-detect #:db-error #:db-error-errno + #:+NULL-VOID+ #:+NULL-CHAR+ #:DB-BTREE #:DB-HASH #:DB-QUEUE #:DB-RECNO #:DB-UNKNOWN #:DB_KEYEMPTY #:DB_LOCK_DEADLOCK #:DB_LOCK_NOTGRANTED @@ -74,6 +109,10 @@

(in-package "SLEEPYCAT")

+#+cmu +(eval-when (:compile-toplevel) + (proclaim '(optimize (ext:inhibit-warnings 3)))) + (eval-when (:compile-toplevel :load-toplevel) ;; UFFI ;;(asdf:operate 'asdf:load-op :uffi) @@ -98,14 +137,14 @@ #+(or bsd freebsd) "/usr/local/lib/db42/libdb.so" #+darwin - "/usr/local/BerkeleyDB.4.2/lib/libdb.dylib" + "/usr/local/BerkeleyDB.4.2/lib/libdb.dylib" :module "sleepycat") (error "Couldn't load libdb (Sleepycat)!"))

;; Libsleepycat.so: edit this (unless (uffi:load-foreign-library - "/usr/local/share/common-lisp/elephant-0.1/libsleepycat.so" + "/usr/local/share/common-lisp/elephant-0.2/libsleepycat.so" :module "libsleepycat") (error "Couldn't load libsleepycat!"))

@@ -123,16 +162,15 @@ (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-txn-begin db-transaction-begin - %db-txn-abort db-transaction-abort - %db-txn-commit db-transaction-commit - %db-transaction-id - flags)) + ;;resize-buffer-stream + ;;buffer-stream-buffer buffer-stream-size buffer-stream-position + ;;buffer-stream-length + reset-buffer-stream + buffer-write-byte buffer-write-int buffer-write-uint + buffer-write-float buffer-write-double buffer-write-string + buffer-read-byte buffer-read-fixnum buffer-read-int + buffer-read-uint buffer-read-float buffer-read-double + buffer-read-string))

;; Constants and Flags ;; eventually write a macro which generates a custom flag function. @@ -169,81 +207,293 @@ (defconstant DB_TXN_NOWAIT #x0001000) (defconstant DB_TXN_SYNC #x0002000) (defconstant DB_LOCK_NOWAIT #x001) +(defconstant DB_DUP #x0000002) +(defconstant DB_DUPSORT #x0000004)

-(defconstant DB_GET_BOTH 10) -(defconstant DB_SET_LOCK_TIMEOUT 29) -(defconstant DB_SET_TXN_TIMEOUT 33) - -(defconstant DB_KEYEMPTY -30997) -(defconstant DB_LOCK_DEADLOCK -30995) -(defconstant DB_LOCK_NOTGRANTED -30994) -(defconstant DB_NOTFOUND -30990) +(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_SET_LOCK_TIMEOUT 29) +(defconstant DB_SET_TXN_TIMEOUT 33) + +(defconstant DB_KEYEMPTY -30997) +(defconstant DB_KEYEXIST -30996) +(defconstant DB_LOCK_DEADLOCK -30995) +(defconstant DB_LOCK_NOTGRANTED -30994) +(defconstant DB_NOTFOUND -30990)

-(defvar +NULL-VOID+ (make-null-pointer :void)) -(defvar +NULL-CHAR+ (make-null-pointer :char)) +(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)

+(defvar +NULL-VOID+ (make-null-pointer :void) + "A null pointer to a void type.") +(defvar +NULL-CHAR+ (make-null-pointer :char) + "A null pointer to a char type.")

-;; 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. +(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))

-;; TODO: #+openmcl versions which do macptr arith. +(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)) + + +;; Thread local storage (special variables) + +(defvar *current-transaction* +NULL-VOID+ + "The transaction which is currently in effect.") + +(defvar *errno-buffer* (allocate-foreign-object :int 1) + "Resourced space for errno return values.") +(defvar *buffer-streams* (make-array 0 :adjustable t :fill-pointer t) + "Vector of buffer-streams, which you can grab / return.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; buffer-streams +;;; +;;; a stream-like interface for our buffers; methods are +;;; below. ultimately we might want a gray / simple -stream +;;; for real, for now who cares? + +(defstruct buffer-stream + "A stream-like interface to foreign (alien) char buffers." + (buffer (allocate-foreign-object :char 10) :type array-or-pointer-char) + (size 0 :type fixnum) + (position 0 :type fixnum) + (length 10 :type fixnum)) + +(defun grab-buffer-stream () + "Grab a buffer-stream from the *buffer-streams* resource pool." + (declare (optimize (speed 3))) + (if (= (length *buffer-streams*) 0) + (make-buffer-stream) + (vector-pop *buffer-streams*))) + +(defun return-buffer-stream (bs) + "Return a buffer-stream to the *buffer-streams* resource pool." + (declare (optimize (speed 3))) + (reset-buffer-stream bs) + (vector-push-extend bs *buffer-streams*)) + +(defmacro with-buffer-streams (names &body body) + "Grab a buffer-stream, executes forms, and returns the +stream to the pool on exit." + `(let ,(loop for name in names collect (list name '(grab-buffer-stream))) + (unwind-protect + (progn ,@body) + (progn + ,@(loop for name in names + collect (list 'return-buffer-stream name)))))) + +;; Buffer management / pointer arithmetic + +;; Notes: on 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. Check these +;; CMUCL / SBCL things don't cons unless necessary. + +;; TODO: #+openmcl versions which do macptr arith. + +#+(or cmu sbcl) +(defun read-int (buf offset) + "Read a 32-bit signed integer from a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type fixnum offset)) + (the (signed-byte 32) + (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* integer))))) + +#+(or cmu sbcl) +(defun read-uint (buf offset) + "Read a 32-bit unsigned integer from a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type fixnum offset)) + (the (unsigned-byte 32) + (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* (unsigned 32)))))) + +#+(or cmu sbcl) +(defun read-float (buf offset) + "Read a single-float from a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type fixnum offset)) + (the single-float + (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* single-float))))) + +#+(or cmu sbcl) +(defun read-double (buf offset) + "Read a double-float from a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type fixnum offset)) + (the double-float + (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* double-float))))) + +#+(or cmu sbcl) +(defun write-int (buf num offset) + "Write a 32-bit signed integer to a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type (signed-byte 32) num) + (type fixnum offset)) + (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* integer))) num)) + +#+(or cmu sbcl) +(defun write-uint (buf num offset) + "Write a 32-bit unsigned integer to a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type (unsigned-byte 32) num) + (type fixnum offset)) + (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* (unsigned 32)))) num)) + +#+(or cmu sbcl) +(defun write-float (buf num offset) + "Write a single-float to a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type single-float num) + (type fixnum offset)) + (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* single-float))) num)) + +#+(or cmu sbcl) +(defun write-double (buf num offset) + "Write a double-float to a foreign char buffer." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) buf) + (type double-float num) + (type fixnum offset)) + (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* double-float))) num)) + +#+(or cmu sbcl) +(defun offset-char-pointer (p offset) + "Pointer arithmetic." + (declare (optimize (speed 3) (safety 0)) + (type (alien (* char)) p) + (type fixnum offset)) + (sap-alien (sap+ (alien-sap p) offset) (* char)))

+#-(or cmu sbcl) (def-function ("read_int" read-int) ((buf array-or-pointer-char) (offset :int)) :returning :int)

+#-(or cmu sbcl) (def-function ("read_uint" read-uint) ((buf array-or-pointer-char) (offset :int)) :returning :unsigned-int)

+#-(or cmu sbcl) (def-function ("read_float" read-float) ((buf array-or-pointer-char) (offset :int)) :returning :float)

+#-(or cmu sbcl) (def-function ("read_double" read-double) ((buf array-or-pointer-char) (offset :int)) :returning :double)

+#-(or cmu sbcl) (def-function ("write_int" write-int) ((buf array-or-pointer-char) (num :int) (offset :int)) :returning :void)

+#-(or cmu sbcl) (def-function ("write_uint" write-uint) ((buf array-or-pointer-char) (num :unsigned-int) (offset :int)) :returning :void)

+#-(or cmu sbcl) (def-function ("write_float" write-float) ((buf array-or-pointer-char) (num :float) (offset :int)) :returning :void)

+#-(or cmu sbcl) (def-function ("write_double" write-double) ((buf array-or-pointer-char) (num :double) (offset :int)) :returning :void)

+#-(or cmu sbcl) (def-function ("offset_charp" offset-char-pointer) ((p array-or-pointer-char) (offset :int)) :returning array-or-pointer-char)

;; Allegro and Lispworks use 16-bit unicode characters +#+(or cmu sbcl allegro lispworks) (defmacro byte-length (s) + "Return the number of bytes of the internal representation +of a string." #+(or lispworks (and allegro ics)) `(let ((l (length ,s))) (+ l l)) #-(or lispworks (and allegro ics)) @@ -274,6 +524,7 @@ ;; but OpenMCL can't directly pass string bytes. #+openmcl (defun copy-str-to-buf (dest dest-offset src src-offset length) + "Copy a string to a foreign buffer. From Gary Byers." (declare (optimize (speed 3) (safety 0)) (type string src) (type array-or-pointer-char dest) @@ -287,6 +538,7 @@ ;; 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) + "Copy a string to a foreign buffer." (declare (optimize (speed 3) (safety 0)) (type string src) (type array-or-pointer-char dest) @@ -313,36 +565,240 @@ (length :int)) :returning :void)

-;; Thread local storage (special variables)

-(declaim (type array-or-pointer-char *get-buffer*) - (type fixnum *get-buffer-length*)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; buffer-stream functions + +(eval-when (:compile-toplevel) + (defun process-struct-slot-defs (slot-defs struct) + (loop for def in slot-defs + collect (list (first def) (list (second def) struct))))) + +(defmacro with-struct-slots (slot-defs struct &body body) + `(symbol-macrolet ,(process-struct-slot-defs slot-defs struct) + ,@body)) + +(defun resize-buffer-stream (bs length) + "Resize the underlying buffer of a buffer-stream, copying the old data." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type fixnum length)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (when (> length len) + (let ((newlen (max length (* len 2)))) + (declare (type fixnum newlen)) + (let ((newbuf (allocate-foreign-object :char newlen))) + ;; technically we just need to copy from position to size..... + (copy-bufs newbuf 0 buf 0 size) + (free-foreign-object buf) + (setf buf newbuf) + (setf len newlen) + nil))))) + +(defun resize-buffer-stream-no-copy (bs length) + "Resize the underlying buffer of a buffer-stream." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type fixnum length)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (when (> length len) + (let ((newlen (max length (* len 2)))) + (declare (type fixnum newlen)) + (let ((newbuf (allocate-foreign-object :char newlen))) + (free-foreign-object buf) + (setf buf newbuf) + (setf len newlen) + nil)))))

-(defvar *current-transaction* +NULL-VOID+) +(defun reset-buffer-stream (bs) + "'Empty' the buffer-stream." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (setf (buffer-stream-size bs) 0) + (setf (buffer-stream-position bs) 0))

-(defvar *errno-buffer* (allocate-foreign-object :int 1)) +(defun buffer-write-byte (b bs) + "Write a byte." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type (unsigned-byte 8) b)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (let ((needed (+ size 1))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (setf (deref-array buf '(:array :char) size) b) + (setf size needed))))

-(defvar *get-buffer* (allocate-foreign-object :char 1)) -(defvar *get-buffer-length* 0) +(defun buffer-write-int (i bs) + "Write a 32-bit signed integer." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type (signed-byte 32) i)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (let ((needed (+ size 4))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (write-int buf i size) + (setf size needed) + nil)))

-(defun resize-get-buffer (length) - (declare (optimize (speed 3) (safety 0) (space 0)) +(defun buffer-write-uint (u bs) + "Write a 32-bit unsigned integer." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type (unsigned-byte 32) u)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (let ((needed (+ size 4))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (write-uint buf u size) + (setf size needed) + nil))) + +(defun buffer-write-float (d bs) + "Write a single-float." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type single-float d)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (let ((needed (+ size 4))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (write-float buf d size) + (setf size needed) + nil))) + +(defun buffer-write-double (d bs) + "Write a double-float." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type double-float d)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (let ((needed (+ size 8))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (write-double buf d size) + (setf size needed) + nil))) + +(defun buffer-write-string (s bs) + "Write the underlying bytes of a string. On Unicode +Lisps, this is a 16-bit operation." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type string s)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (let* ((str-bytes (byte-length s)) + (needed (+ size str-bytes))) + (declare (type fixnum str-bytes needed) + (dynamic-extent str-bytes needed)) + (when (> needed len) + (resize-buffer-stream bs needed)) + (copy-str-to-buf buf size s 0 str-bytes) + (setf size needed) + nil))) + +(defun buffer-read-byte (bs) + "Read a byte." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((position (buffer-stream-position bs))) + (incf (buffer-stream-position bs)) + (deref-array (buffer-stream-buffer bs) '(:array :char) position))) + +(defun buffer-read-fixnum (bs) + "Read a 32-bit signed integer, which is assumed to be a fixnum." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position 4)) + (the fixnum (read-int (buffer-stream-buffer bs) position)))) + +(defun buffer-read-int (bs) + "Read a 32-bit signed integer." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position 4)) + (the (signed-byte 32) (read-int (buffer-stream-buffer bs) position)))) + +(defun buffer-read-uint (bs) + "Read a 32-bit unsigned integer." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position 4)) + (the (unsigned-byte 32)(read-uint (buffer-stream-buffer bs) position)))) + +(defun buffer-read-float (bs) + "Read a single-float." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position 4)) + (read-float (buffer-stream-buffer bs) position))) + +(defun buffer-read-double (bs) + "Read a double-float." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position 8)) + (read-double (buffer-stream-buffer bs) position))) + +(defun buffer-read-string (bs length) + "Read a string. On Unicode Lisps this is a 16-bit operation!" + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) (type fixnum length)) - (if (< length *get-buffer-length*) - (values *get-buffer* *get-buffer-length*) - (let ((newlen (max length (* *get-buffer-length* 2)))) - (declare (type fixnum newlen)) - (setq *get-buffer-length* newlen) - (free-foreign-object *get-buffer*) - (setq *get-buffer* (allocate-foreign-object :char newlen)) - (values *get-buffer* *get-buffer-length*)))) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position length)) + ;; wide!!! + #+(and allegro ics) + (excl:native-to-string + (offset-char-pointer (buffer-stream-buffer bs) position) + :length length + :external-format :unicode) + #+lispworks + (fli:convert-from-foreign-string + (offset-char-pointer (buffer-stream-buffer bs) position) + :length length :external-format :unicode :null-terminated-p nil) + #-(or lispworks (and allegro ics)) + (convert-from-foreign-string + (offset-char-pointer (buffer-stream-buffer bs) position) + :length length :null-terminated-p nil)))

;; Wrapper macro -- handles errno return values ;; makes flags into keywords ;; makes keyword args, cstring wrappers

-(eval-when (:compile-toplevel :load-toplevel) +(eval-when (:compile-toplevel) (defun make-wrapper-args (args flags keys) (if (or flags keys) (append (remove-keys (remove 'flags args) keys) @@ -378,6 +834,7 @@

(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) @@ -388,7 +845,8 @@ (if (> outs 1) (let ((out-args (make-out-args outs))) `(defun ,wname ,wrapper-args - ,@(if declarations (list declarations) (values)) + ,@(if documentation (list documentation) (values)) + ,@(if declarations (list declarations) (values)) (with-cstrings ,(symbols-to-pairs cstrings) (multiple-value-bind ,out-args (,fname ,@fun-args) @@ -399,10 +857,11 @@ ,@(if transaction (list `((or (= ,errno DB_LOCK_DEADLOCK) (= ,errno DB_LOCK_NOTGRANTED)) - (throw ,transaction ,transaction))) + (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 ,@fun-args))) @@ -412,769 +871,71 @@ ,@(if transaction (list `((or (= ,errno DB_LOCK_DEADLOCK) (= ,errno DB_LOCK_NOTGRANTED)) - (throw ,transaction ,transaction))) + (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 dirty-read create excl nommap + 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 + no-dup-data no-overwrite nosync position 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 dirty-read `((when ,dirty-read (setq ,flags (logior ,flags DB_DIRTY_READ))))) + ,@(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 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 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 () - (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)) - -(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 (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)) - -(def-function ("db_env_dbremove" %db-env-dbremove) - ((env :pointer-void) - (txn :pointer-void) - (file :cstring) - (database :cstring) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-env-dbremove (env transaction file database flags) - :flags (auto-commit) - :keys ((transaction *current-transaction*) - (database +NULL-CHAR+)) - :cstrings (file database) - :transaction transaction) - -(def-function ("db_env_dbrename" %db-env-dbrename) - ((env :pointer-void) - (txn :pointer-void) - (file :cstring) - (database :cstring) - (newname :cstring) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-env-dbrename (env transaction file database newname flags) - :flags (auto-commit) - :keys ((transaction *current-transaction*) - (database +NULL-CHAR+)) - :cstrings (file database newname) - :transaction transaction) - -(def-function ("db_env_remove" %db-env-remove) - ((env :pointer-void) - (home :cstring) - (flags :unsigned-int)) - :returning :int) - -(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) - ((dbenv :pointer-void) - (flags :unsigned-int) - (errno :int :out)) - :returning :pointer-void) - -(defun db-create (&optional (dbenv +NULL-VOID+)) - (multiple-value-bind (db errno) - (%db-create dbenv 0) - (declare (type fixnum errno)) - (if (= errno 0) - db - (error 'db-error :errno errno)))) - -(def-function ("db_close" %db-close) - ((db :pointer-void) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-close (db flags)) - -(def-function ("db_open" %db-open) - ((db :pointer-void) - (txn :pointer-void) - (file :cstring) - (database :cstring) - (type DBTYPE) - (flags :unsigned-int) - (mode :int)) - :returning :int) - -(wrap-errno db-open (db transaction file database type flags mode) - :flags (auto-commit create dirty-read excl nommap - rdonly thread truncate) - :keys ((transaction *current-transaction*) - (file +NULL-CHAR+) - (database +NULL-CHAR+) - (type DB-UNKNOWN) - (mode #o640)) - :cstrings (file database) - :transaction transaction) - -(def-function ("db_remove" %db-remove) - ((db :pointer-void) - (file :cstring) - (database :cstring) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-remove (db file database flags) - :keys ((database +NULL-CHAR+)) - :cstrings (file database)) - -(def-function ("db_rename" %db-rename) - ((db :pointer-void) - (file :cstring) - (database :cstring) - (newname :cstring) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-rename (db file database newname flags) - :keys ((database +NULL-CHAR+)) - :cstrings (file database newname)) - -(def-function ("db_sync" %db-sync) - ((db :pointer-void) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-sync (db flags)) - -(def-function ("db_truncate" %db-truncate) - ((db :pointer-void) - (txn :pointer-void) - (count :unsigned-int :out) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-truncate (db transaction flags) :flags (auto-commit) - :keys ((transaction *current-transaction*)) :outs 2 - :transaction transaction) - -;; Accessors - -(def-function ("db_get_raw" %db-get-key-buffered) - ((db :pointer-void) - (txn :pointer-void) - (key array-or-pointer-char) - (key-length :unsigned-int) - (buffer array-or-pointer-char) - (buffer-length :unsigned-int) - (flags :unsigned-int) - (result-length :unsigned-int :out)) - :returning :int) - -(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) - (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 - *get-buffer* *get-buffer-length* - (flags :auto-commit auto-commit - :get-both get-both - :dirty-read dirty-read)) - (declare (type fixnum result-length errno)) - (if (<= result-length *get-buffer-length*) - (cond - ((= errno 0) - (return-from db-get-key-buffered - (the (values array-or-pointer-char fixnum) - (values *get-buffer* result-length)))) - ((or (= errno DB_NOTFOUND) (= errno DB_KEYEMPTY)) - (return-from db-get-key-buffered - (the (values null fixnum) (values nil 0)))) - ((or (= errno DB_LOCK_DEADLOCK) (= errno DB_LOCK_NOTGRANTED)) - (throw transaction transaction)) - (t (error 'db-error :errno errno))) - (resize-get-buffer result-length))))) - -(def-function ("db_get_raw" %db-get-buffered) - ((db :pointer-void) - (txn :pointer-void) - (key :cstring) - (key-length :unsigned-int) - (buffer array-or-pointer-char) - (buffer-length :unsigned-int) - (flags :unsigned-int) - (result-length :unsigned-int :out)) - :returning :int) - -(defun db-get-buffered (db key &key - (key-length (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 string key) - (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 - *get-buffer* *get-buffer-length* - (flags :auto-commit auto-commit - :get-both get-both - :dirty-read dirty-read)) - (declare (type fixnum result-length errno)) - (if (<= result-length *get-buffer-length*) - (cond - ((= errno 0) - (return-from db-get-buffered - (the (values array-or-pointer-char fixnum) - (values *get-buffer* result-length)))) - ((or (= errno DB_NOTFOUND) (= errno DB_KEYEMPTY)) - (return-from db-get-buffered - (the (values null fixnum) (values nil 0)))) - ((or (= errno DB_LOCK_DEADLOCK) (= errno DB_LOCK_NOTGRANTED)) - (throw transaction transaction)) - (t (error 'db-error :errno errno))) - (resize-get-buffer result-length)))))) - -(defun db-get (db key &key (key-length (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 string key) - (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 - *get-buffer* *get-buffer-length* - (flags :auto-commit auto-commit - :get-both get-both - :dirty-read dirty-read)) - (declare (type fixnum result-length errno)) - (if (<= result-length *get-buffer-length*) - (cond - ((= errno 0) - (return-from db-get - (convert-from-foreign-string *get-buffer* - :length result-length - :null-terminated-p nil))) - ((or (= errno DB_NOTFOUND) (= errno DB_KEYEMPTY)) - (return-from db-get nil)) - ((or (= errno DB_LOCK_DEADLOCK) (= errno DB_LOCK_NOTGRANTED)) - (throw transaction transaction)) - (t (error 'db-error :errno errno))) - (resize-get-buffer result-length)))))) - -(def-function ("db_put_raw" %db-put-buffered) - ((db :pointer-void) - (txn :pointer-void) - (key array-or-pointer-char) - (key-length :unsigned-int) - (datum array-or-pointer-char) - (datum-length :unsigned-int) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-put-buffered (db transaction key key-length - datum datum-length flags) - :flags (auto-commit) - :keys ((transaction *current-transaction*)) - :declarations (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) - (type array-or-pointer-char key datum) - (type fixnum key-length datum-length) - (type boolean auto-commit)) - :transaction transaction) - -(def-function ("db_put_raw" %db-put) - ((db :pointer-void) - (txn :pointer-void) - (key :cstring) - (key-length :unsigned-int) - (datum :cstring) - (datum-length :unsigned-int) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno db-put (db transaction key key-length datum datum-length flags) - :flags (auto-commit) - :keys ((key-length (length key)) - (datum-length (length datum)) - (transaction *current-transaction*)) - :cstrings (key datum) - :declarations (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) - (type string key datum) - (type fixnum key-length datum-length) - (type boolean auto-commit)) - :transaction transaction) - -(def-function ("db_del" %db-delete-buffered) - ((db :pointer-void) - (txn :pointer-void) - (key array-or-pointer-char) - (key-length :unsigned-int) - (flags :unsigned-int)) - :returning :int) - -(defun db-delete-buffered (db key key-length &key auto-commit - (transaction *current-transaction*)) - (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) (type array-or-pointer-char key) - (type fixnum key-length) (type boolean auto-commit)) - (let ((errno (%db-delete-buffered db transaction - key key-length - (flags :auto-commit auto-commit)))) - (declare (type fixnum errno)) - (cond ((= errno 0) t) - ((or (= errno DB_NOTFOUND) - (= errno DB_KEYEMPTY)) - nil) - ((or (= errno DB_LOCK_DEADLOCK) - (= errno DB_LOCK_NOTGRANTED)) - (throw transaction transaction)) - (t (error 'db-error :errno errno))))) - -(def-function ("db_del" %db-delete) - ((db :pointer-void) - (txn :pointer-void) - (key :cstring) - (key-length :unsigned-int) - (flags :unsigned-int)) - :returning :int) - -(defun db-delete (db key &key auto-commit (key-length (length key)) - (transaction *current-transaction*)) - (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) (type string key) - (type fixnum key-length) (type boolean auto-commit)) - (with-cstrings ((key key)) - (let ((errno - (%db-delete db transaction key - key-length (flags :auto-commit auto-commit)))) - (declare (type fixnum errno)) - (cond ((= errno 0) nil) - ((or (= errno DB_NOTFOUND) - (= errno DB_KEYEMPTY)) - nil) - ((or (= errno DB_LOCK_DEADLOCK) - (= errno DB_LOCK_NOTGRANTED)) - (throw transaction transaction)) - (t (error 'db-error :errno errno)))))) - -;; Transactions - -(def-function ("db_txn_begin" %db-txn-begin) - ((env :pointer-void) - (parent :pointer-void) - (flags :unsigned-int) - (errno (* :int))) - :returning :pointer-void) - -(defun db-transaction-begin (env &key (parent *current-transaction*) - dirty-read txn-nosync txn-nowait - txn-sync) - (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void env parent) - (type boolean dirty-read txn-nosync txn-nowait - txn-sync) - (type pointer-int *errno-buffer*)) - (let* ((txn - (%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)) - (if (= errno 0) - txn - (error 'db-error :errno errno)))) - -(def-function ("db_txn_abort" %db-txn-abort) - ((txn :pointer-void)) - :returning :int) - -(wrap-errno (db-transaction-abort %db-txn-abort) (transaction) - :keys ((transaction *current-transaction*)) - :declarations (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void transaction))) - -(def-function ("db_txn_commit" %db-txn-commit) - ((txn :pointer-void) - (flags :unsigned-int)) - :returning :int) - -(wrap-errno (db-transaction-commit %db-txn-commit) (transaction flags) - :keys ((transaction *current-transaction*)) - :flags (txn-nosync txn-sync) - :declarations (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void transaction) - (type boolean txn-nosync txn-sync))) - -(defmacro with-transaction ((&key transaction environment - (parent '*current-transaction*) - (retries 100) - dirty-read txn-nosync - txn-nowait txn-sync) - &body body) - (let ((txn (if transaction transaction (gensym))) - (count (gensym)) - (result (gensym)) - (success (gensym))) - `(loop for ,count fixnum from 1 to ,retries - for ,txn of-type pointer-void = - (db-transaction-begin ,environment - :parent ,parent - :dirty-read ,dirty-read - :txn-nosync ,txn-nosync - :txn-nowait ,txn-nowait - :txn-sync ,txn-sync) - for ,success of-type boolean = nil - for ,result = - (let ((*current-transaction* ,txn)) - (catch ,txn - (unwind-protect - (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))))) - do - (unless (and (eq ,result ,txn) (not ,success)) - (return ,result)) - finally (error "Too many retries")))) - -;; 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))))))) - - -;; Locks and timeouts - - -(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)) - -(def-function ("db_txn_id" %db-transaction-id) - ((transaction :pointer-void)) - :returning :unsigned-int) - -(defun db-transaction-id (&optional (transaction *current-transaction*)) - (%db-transaction-id transaction)) - -(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_lock_get" %db-env-lock-get) - ((env :pointer-void) - (locker :unsigned-int) - (flags :unsigned-int) - (object array-or-pointer-char) - (object-length :unsigned-int) - (lock-mode DB-LOCKMODE) - (lock (* DB-LOCK))) - :returning :int) - -(wrap-errno db-env-lock-get (env locker flags object object-length - lock-mode lock) - :flags (lock-nowait)) - -(def-function ("db_env_lock_put" %db-env-lock-put) - ((env :pointer-void) - (lock (* DB-LOCK))) - :returning :int) - -(wrap-errno db-env-lock-put (env lock)) - -(defmacro with-lock ((env locker object object-length - &key (lock-mode DB-LOCKMODE#WRITE) - lock-nowait) - &body body) - (let ((lock (gensym)) - (locked (gensym))) - `(with-foreign-object (,lock 'DB-LOCK) - (let ((,locked nil)) - (unwind-protect - (progn - (db-env-lock-get ,env ,locker ,object ,object-length ,lock-mode - ,lock :lock-nowait ,lock-nowait) - (setq ,locked T) - ,@body) - (when ,locked (db-env-lock-put ,env ,lock))))))) - -(def-function ("db_env_lock_vec" %db-env-lock-vec) - ((env :pointer-void) - (locker :unsigned-int) - (flags :unsigned-int) - (list (:array DB-LOCKREQ)) - (nlist :int) - (elistp (* (* DB-LOCKREQ)))) - :returning :int) - -(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) - -;; Poor man's counters - -(def-function ("next_counter" %next-counter) - ((env :pointer-void) - (db :pointer-void) - (parent :pointer-void) - (key array-or-pointer-char) - (key-length :unsigned-int) - (lockid array-or-pointer-char) - (lockid-length :unsigned-int)) - :returning :int)

-(defun next-counter (env db parent key key-length lockid lockid-length) - (let ((ret (%next-counter env db parent key key-length lockid lockid-length))) - (if (< ret 0) - (error 'db-error :errno ret) - ret))) - -;; Misc - -(defun 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 - get-both - dirty-read - create - excl - nommap - rdonly - truncate - txn-nosync - txn-nowait - txn-sync - set-lock-timeout - set-transaction-timeout - lock-nowait) - (let ((flags 0)) - (declare (optimize (speed 3) (safety 0) (space 0)) - (type (unsigned-byte 32) flags) - (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 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))) - (when lock-nowait (setq flags (logior flags DB_LOCK_NOWAIT))) - flags)) - -;; Errors - -(def-function ("db_strerr" %db-strerror) - ((error :int)) - :returning :cstring) - -(defun db-strerror (errno) - (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))))))