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))))))
