- elephant-cvs@lists.common-lisp.net - mailman3.common-lisp.net

[elephant-cvs] CVS update: elephant/tests/testcollections.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv26292/tests Added Files: testcollections.lisp Log Message: test btrees, secondary indices and cursors Date: Thu Sep 16 06:26:37 2004 Author: blee

1 0

[elephant-cvs] CVS update: elephant/tests/mop-tests.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv26181/tests Modified Files: mop-tests.lisp Log Message: updates makunbound Date: Thu Sep 16 06:26:08 2004 Author: blee Index: elephant/tests/mop-tests.lisp diff -u elephant/tests/mop-tests.lisp:1.4 elephant/tests/mop-tests.lisp:1.5 --- elephant/tests/mop-tests.lisp:1.4 Sat Sep 4 11:16:11 2004 +++ elephant/tests/mop-tests.lisp Thu Sep 16 06:26:08 2004 @@ -84,7 +84,7 @@ t) (deftest mixes-right-slots - (values + (are-not-null (typep (find-slot-def 'mix-1 'slot1) 'ele::persistent-slot-definition) (typep (find-slot-def 'mix-1 'slot2) 'ele::transient-slot-definition) (typep (find-slot-def 'mix-1 'slot3) 'ele::transient-slot-definition) @@ -115,7 +115,7 @@ t) (deftest inherit-right-slots - (values + (are-not-null (typep (find-slot-def 'make-persistent2 'slot1) 'ele::persistent-slot-definition) (typep (find-slot-def 'make-persistent2 'slot2) @@ -138,13 +138,15 @@ t) (deftest initform-test - (slot-value (make-instance 'p-initform-test) 'slot1) + (let ((*auto-commit* t)) + (slot-value (make-instance 'p-initform-test) 'slot1)) 10) (deftest initarg-test - (values - (slot-value (make-instance 'p-initform-test-2) 'slot1) - (slot-value (make-instance 'p-initform-test-2 :slot1 20) 'slot1)) + (let ((*auto-commit* t)) + (values + (slot-value (make-instance 'p-initform-test-2) 'slot1) + (slot-value (make-instance 'p-initform-test-2 :slot1 20) 'slot1))) 10 20) (deftest no-eval-initform @@ -160,8 +162,19 @@ (progn (defclass redef () () (:metaclass persistent-metaclass)) (defclass redef () () (:metaclass persistent-metaclass)) - (values (subtypep 'redef 'persistent-object))) + (is-not-null (subtypep 'redef 'persistent-object))) t) -(with-open-store (*testdb-path*) - (do-tests)) +;; i wish i could use slot-makunbound but allegro sux +(deftest makunbound + (let ((p (make-instance 'p-class))) + (with-transaction () + (setf (slot1 p) t) + #-allegro + (slot-makunbound p 'slot1) + #+allegro + (slot-makunbound-using-class (find-class 'p-class) p + (find-slot-def 'p-class 'slot1)) + ) + (signals-condition (slot1 p))) + t) \ No newline at end of file

1 0

[elephant-cvs] CVS update: elephant/tests/elephant-tests.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv26111/tests Modified Files: elephant-tests.lisp Log Message: updates Date: Thu Sep 16 06:25:19 2004 Author: blee Index: elephant/tests/elephant-tests.lisp diff -u elephant/tests/elephant-tests.lisp:1.2 elephant/tests/elephant-tests.lisp:1.3 --- elephant/tests/elephant-tests.lisp:1.2 Sat Sep 4 11:16:11 2004 +++ elephant/tests/elephant-tests.lisp Thu Sep 16 06:25:19 2004 @@ -44,40 +44,50 @@ (:nicknames ele-tests :ele-tests) (:use common-lisp elephant rt) (:import-from :ele - *out-buf* + with-buffer-streams serialize - deserialize - buffer-stream-buffer) + deserialize) #+cmu (:import-from :pcl finalize-inheritance slot-definition-name + slot-makunbound-using-class class-slots) #+sbcl (:import-from :sb-mop finalize-inheritance slot-definition-name + slot-makunbound-using-class class-slots) #+allegro (:import-from :clos finalize-inheritance slot-definition-name + slot-makunbound-using-class class-slots) #+openmcl (:import-from :ccl finalize-inheritance slot-definition-name + slot-makunbound-using-class class-slots) #+lispworks (:import-from :clos finalize-inheritance slot-definition-name + slot-makunbound-using-class class-slots) ) (in-package :ele-tests) -(defvar *testdb-path* "/usr/local/share/common-lisp/elephant-0.1/tests/testdb") + +(defvar *testdb-path* "/usr/local/share/common-lisp/elephant-0.2/tests/testdb") + +(defun do-all-tests() + (with-open-store (*testdb-path*) + (let ((*auto-commit* nil)) + (do-tests)))) (defun find-slot-def (class-name slot-name) (find-if #'(lambda (slot-def) @@ -103,3 +113,11 @@ (progn ,@body) (error () t) (:no-error (&rest rest) (declare (ignore rest)) nil))) + +(defmacro is-not-null (&body body) + `(not (null (progn ,@body)))) + +(defmacro are-not-null (&rest forms) + `(values + ,@(loop for form in forms + collect `(is-not-null ,form)))) \ No newline at end of file

1 0

[elephant-cvs] CVS update: elephant/src/utils.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv26060/src Modified Files: utils.lisp Log Message: doc-strings buffer-streams to sleepycat.lisp with-transaction defaults to *auto-commit* nil Date: Thu Sep 16 06:23:50 2004 Author: blee Index: elephant/src/utils.lisp diff -u elephant/src/utils.lisp:1.5 elephant/src/utils.lisp:1.6 --- elephant/src/utils.lisp:1.5 Sat Sep 4 10:23:30 2004 +++ elephant/src/utils.lisp Thu Sep 16 06:23:49 2004 @@ -42,76 +42,53 @@ (in-package "ELEPHANT") -(eval-when (:compile-toplevel :load-toplevel :execute) - (use-package "UFFI")) -(declaim (inline ;resize-buffer-stream - finish-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) - (type fixnum *lisp-obj-id*) +(declaim (type fixnum *lisp-obj-id*) (type hash-table *circularity-hash*) (type boolean *auto-commit*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; 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 - (buffer (allocate-foreign-object :char 1) :type array-or-pointer-char) - (length 0 :type fixnum) - (position 0 :type fixnum)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; Thread-local specials (defparameter *store-controller* nil "The store controller which persistent objects talk to.") ;; Specials which control persistent objects -(defvar *auto-commit* T) - -(declaim (type buffer-stream *out-buf* *key-buf* *in-buf*)) - -;; Buffers for going in and out of the DB -(defvar *out-buf* (make-buffer-stream)) -(defvar *key-buf* (make-buffer-stream)) -(defvar *in-buf* (make-buffer-stream)) +(defvar *auto-commit* T + "Commit things not in transactions?") ;; Stuff the serializer uses -(defvar *lisp-obj-id* 0) -(defvar *circularity-hash* (make-hash-table :test 'eq)) -#+(or cmu scl sbcl allegro) -(defvar *resourced-byte-spec* (byte 32 0)) +(defvar *lisp-obj-id* 0 + "Circularity ids for the serializer.") +(defvar *circularity-hash* (make-hash-table :test 'eq) + "Circularity hash for the serializer.") + +#+(or cmu sbcl allegro) +(defvar *resourced-byte-spec* (byte 32 0) + "Byte specs on CMUCL, SBCL and Allegro are conses.") ;; TODO: make this for real! (defun run-elephant-thread (thunk) + "Sets the specials (which hopefully are thread-local) to +make the Elephant thread-safe." (let ((*current-transaction* +NULL-VOID+) - (*errno-buffer* (allocate-foreign-object :int 1)) - (*get-buffer* (allocate-foreign-object :char 1)) - (*get-buffer-length* 0) + (sleepycat::*errno-buffer* (allocate-foreign-object :int 1)) + ;; if vector-push-extend et al are thread-safe, this + ;; doesn't need to be thread-local. + (sleepycat::*buffer-streams* + (make-array 0 :adjustable t :fill-pointer t)) (*store-controller* *store-controller*) (*auto-commit* *auto-commit*) - (*out-buf* (make-buffer-stream)) - (*key-buf* (make-buffer-stream)) - (*in-buf* (make-buffer-stream)) (*lisp-obj-id* 0) (*circularity-hash* (make-hash-table :test 'eq)) - #+(or cmu scl sbcl allegro) + #+(or cmu sbcl allegro) (*resourced-byte-spec* (byte 32 0))) - (declare (special *current-transaction* *errno-buffer* - *get-buffer* *get-buffer-length* *store-controller* - *auto-commit* *out-buf* *key-buf* *in-buf* + (declare (special *current-transaction* sleepycat::*errno-buffer* + sleepycat::*buffer-streams* + *store-controller* *auto-commit* *lisp-obj-id* *circularity-hash* - #+(or cmu scl sbcl allegro) *resourced-byte-spec*)) + #+(or cmu sbcl allegro) *resourced-byte-spec*)) (funcall thunk))) @@ -128,6 +105,11 @@ txn-nowait txn-sync (retries 100)) &body body) + "Execute a body with a transaction in place. On success, +the transaction is committed. Otherwise, the transaction is +aborted. If the body deadlocks, the body is re-executed in +a new transaction, retrying a fixed number of iterations. +*auto-commit* is false for the body of the transaction." `(sleepycat:with-transaction (:transaction ,transaction :environment ,environment :parent ,parent @@ -136,7 +118,8 @@ :txn-nowait ,txn-nowait :txn-sync ,txn-sync :retries ,retries) - ,@body)) + (let ((*auto-commit* nil)) + ,@body))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -146,242 +129,70 @@ ;;; flushed from the table too (defun make-cache-table (&rest args) + "Make a values-weak hash table: when a value has been +collected, so are the keys." #+(or cmu sbcl scl) (apply #'make-hash-table args) #+allegro (apply #'make-hash-table :values :weak args) #+lispworks (apply #'make-hash-table :weak-kind :value args) + #+openmcl + (apply #'make-hash-table :weak :value args) #-(or cmu sbcl scl allegro lispworks) (apply #'make-hash-table args) ) +#+openmcl +(defclass cleanup-wrapper () + ((cleanup :accessor cleanup :initarg :cleanup) + (value :accessor value :initarg :value))) + +#+openmcl +(defmethod ccl:terminate ((c cleanup-wrapper)) + (funcall (cleanup c))) + (defun get-cache (key cache) + "Get a value from a cache-table." #+(or cmu sbcl) (let ((val (gethash key cache))) (if val (values (weak-pointer-value val) t) (values nil nil))) - #-(or cmu sbcl scl) + #+openmcl + (let ((wrap (gethash key cache))) + (if wrap (values (value wrap) t) + (values nil nil))) + #+(or allegro lispworks) (gethash key cache) ) (defun make-finalizer (key cache) #+(or cmu sbcl) (lambda () (remhash key cache)) - #+allegro + #+(or allegro openmcl) (lambda (obj) (declare (ignore obj)) (remhash key cache)) ) (defun setf-cache (key cache value) + "Set a value in a cache-table." #+(or cmu sbcl) (let ((w (make-weak-pointer value))) (finalize value (make-finalizer key cache)) (setf (gethash key cache) w) value) + #+openmcl + (let ((w (make-instance 'cleanup-wrapper :value value + :cleanup (make-finalizer key cache)))) + (ccl:terminate-when-unreachable w) + (setf (gethash key cache) w) + value) #+allegro (progn (excl:schedule-finalization value (make-finalizer key cache)) (setf (gethash key cache) value)) - #-(or cmu sbcl scl allegro) + #+lispworks (setf (gethash key cache) value) ) (defsetf get-cache setf-cache) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; buffer-stream methods - -(eval-when (:compile-toplevel :load-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) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type fixnum length)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (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))) - (copy-bufs newbuf 0 buf 0 len) - (free-foreign-object buf) - (setf buf newbuf) - (setf len newlen) - nil))))) - -(defun finish-buffer (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position)) - bs - (let ((length pos)) - (setf pos 0) - length))) - -(defun buffer-write-byte (b bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type (unsigned-byte 8) b)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 1))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (setf (deref-array buf '(:array :char) pos) b) - (setf pos needed)))) - -(defun buffer-write-int (i bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type (signed-byte 32) i)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 4))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (write-int buf i pos) - (setf pos needed) - nil))) - -(defun buffer-write-uint (u bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type (unsigned-byte 32) u)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 4))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (write-uint buf u pos) - (setf pos needed) - nil))) - -(defun buffer-write-float (d bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type single-float d)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 4))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (write-float buf d pos) - (setf pos needed) - nil))) - -(defun buffer-write-double (d bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type double-float d)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 8))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (write-double buf d pos) - (setf pos needed) - nil))) - -(defun buffer-write-string (s bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type string s)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let* ((str-bytes (byte-length s)) - (needed (+ pos 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 pos s 0 str-bytes) - (setf pos needed) - nil))) - -(defun buffer-read-byte (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (incf (buffer-stream-position bs)) - (deref-array (buffer-stream-buffer bs) '(:array :char) pos))) - -(defun buffer-read-fixnum (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 4)) - (the fixnum (read-int (buffer-stream-buffer bs) pos)))) - -(defun buffer-read-int (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 4)) - (the (signed-byte 32) (read-int (buffer-stream-buffer bs) pos)))) - -(defun buffer-read-uint (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 4)) - (the (unsigned-byte 32)(read-uint (buffer-stream-buffer bs) pos)))) - -(defun buffer-read-float (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 4)) - (read-float (buffer-stream-buffer bs) pos))) - -(defun buffer-read-double (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 8)) - (read-double (buffer-stream-buffer bs) pos))) - -(defun buffer-read-string (bs length) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type fixnum length)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos length)) - ;; wide!!! - #+(and allegro ics) - (excl:native-to-string - (offset-char-pointer (buffer-stream-buffer bs) pos) - :length length - :external-format :unicode) - #+lispworks - (fli:convert-from-foreign-string - (offset-char-pointer (buffer-stream-buffer bs) pos) - :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) pos) - :length length :null-terminated-p nil)))

1 0

[elephant-cvs] CVS update: elephant/src/sleepycat.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

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

1 0

[elephant-cvs] CVS update: elephant/src/serializer.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv25896/src Modified Files: serializer.lisp Log Message: doc-strings buffer-streamified sanified type tags Date: Thu Sep 16 06:20:42 2004 Author: blee Index: elephant/src/serializer.lisp diff -u elephant/src/serializer.lisp:1.8 elephant/src/serializer.lisp:1.9 --- elephant/src/serializer.lisp:1.8 Sat Sep 4 10:59:40 2004 +++ elephant/src/serializer.lisp Thu Sep 16 06:20:41 2004 @@ -51,30 +51,46 @@ ;; Constants -(defconstant +fixnum+ (char-code #\f)) -(defconstant +nil+ (char-code #\N)) -(defconstant +symbol+ (char-code #\S)) -(defconstant +string+ (char-code #\s)) -(defconstant +persistent+ (char-code #\P)) -(defconstant +single-float+ (char-code #\F)) -(defconstant +double-float+ (char-code #\D)) -(defconstant +char+ (char-code #\c)) -(defconstant +pathname+ (char-code #\p)) -(defconstant +positive-bignum+ (char-code #\B)) -(defconstant +negative-bignum+ (char-code #\b)) -(defconstant +rational+ (char-code #\r)) -(defconstant +cons+ (char-code #\C)) -(defconstant +hash-table+ (char-code #\H)) -(defconstant +object+ (char-code #\O)) +(defconstant +fixnum+ 1) +(defconstant +char+ 2) +(defconstant +single-float+ 3) +(defconstant +double-float+ 4) +(defconstant +negative-bignum+ 5) +(defconstant +positive-bignum+ 6) +(defconstant +rational+ 7) + +(defconstant +nil+ 8) + +;; 8-bit +#-(or lispworks (and allegro ics)) +(defconstant +symbol+ 9) +#-(or lispworks (and allegro ics)) +(defconstant +string+ 10) +#-(or lispworks (and allegro ics)) +(defconstant +pathname+ 11) + +;; 16-bit +#+(or lispworks (and allegro ics)) +(defconstant +symbol+ 12) +#+(or lispworks (and allegro ics)) +(defconstant +string+ 13) +#+(or lispworks (and allegro ics)) +(defconstant +pathname+ 14) + +(defconstant +persistent+ 15) +(defconstant +cons+ 16) +(defconstant +hash-table+ 17) +(defconstant +object+ 18) +(defconstant +array+ 19) -(defconstant +array+ (char-code #\A)) - -(defconstant +fill-pointer-p+ #x40) -(defconstant +adjustable-p+ #x80) +(defconstant +fill-pointer-p+ #x40) +(defconstant +adjustable-p+ #x80) (defun serialize (frob bs) - (declare (optimize (speed 3) (safety 0))) + "Serialize a lisp value into a buffer-stream." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) (setq *lisp-obj-id* 0) (clrhash *circularity-hash*) (labels @@ -207,7 +223,7 @@ (%serialize (row-major-aref frob i))))))) ))) (%serialize frob) - (finish-buffer bs))) + bs)) (defun slots-and-values (o) (declare (optimize (speed 3) (safety 0))) @@ -222,14 +238,10 @@ (push slot-name ret)) finally (return ret))) -(defun deserialize (buf) +(defun deserialize (buf-str) + "Deserialize a lisp value from a buffer-stream." (declare (optimize (speed 3) (safety 0)) - (type (or null array-or-pointer-char) buf)) - (unless buf (return-from deserialize nil)) - (setf (buffer-stream-buffer *in-buf*) buf) - (setf (buffer-stream-position *in-buf*) 0) - (setq *lisp-obj-id* 0) - (clrhash *circularity-hash*) + (type (or null buffer-stream) buf-str)) (labels ((%deserialize (bs) (declare (optimize (speed 3) (safety 0)) @@ -325,7 +337,12 @@ (setf (row-major-aref a i) (%deserialize bs))) a)))) (t (error "deserialize fubar!")))))) - (%deserialize *in-buf*))) + (etypecase buf-str + (null (return-from deserialize nil)) + (buffer-stream + (setq *lisp-obj-id* 0) + (clrhash *circularity-hash*) + (%deserialize buf-str))))) (defun deserialize-bignum (bs length positive) (declare (optimize (speed 3) (safety 0)) @@ -387,9 +404,9 @@ (defun int-byte-spec (position) (declare (optimize (speed 3) (safety 0)) (type (unsigned-byte 24) position)) - #+(or cmu scl sbcl allegro) + #+(or cmu sbcl allegro) (progn (setf (cdr *resourced-byte-spec*) (* 32 position)) *resourced-byte-spec*) - #-(or cmu scl sbcl allegro) + #-(or cmu sbcl allegro) (byte 32 (* 32 position)) )

1 0

[elephant-cvs] CVS update: elephant/src/berkeley-db.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv25863/src Added Files: berkeley-db.lisp Log Message: split from sleepycat.lisp doc-strings buffer-streamified Date: Thu Sep 16 06:19:57 2004 Author: blee

1 0

[elephant-cvs] CVS update: elephant/src/metaclasses.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv25836/src Modified Files: metaclasses.lisp Log Message: docstrings changeover to buffer-streams Date: Thu Sep 16 06:19:12 2004 Author: blee Index: elephant/src/metaclasses.lisp diff -u elephant/src/metaclasses.lisp:1.4 elephant/src/metaclasses.lisp:1.5 --- elephant/src/metaclasses.lisp:1.4 Thu Sep 2 09:15:48 2004 +++ elephant/src/metaclasses.lisp Thu Sep 16 06:19:12 2004 @@ -49,7 +49,8 @@ to user-defined classes and collections.)")) (defclass persistent-metaclass (standard-class) - ()) + () + (:documentation "Metaclass for persistent classes.")) (defclass persistent-slot-definition (standard-slot-definition) ()) @@ -81,6 +82,8 @@ :class) (defmethod direct-slot-definition-class ((class persistent-metaclass) &rest initargs) + "Checks for the transient tag (and the allocation type) +and chooses persistent or transient slot definitions." (let ((allocation-key (getf initargs :allocation)) (transient-p (getf initargs :transient))) (when (consp transient-p) (setq transient-p (car transient-p))) @@ -94,9 +97,11 @@ (find-class 'persistent-direct-slot-definition))))) (defmethod validate-superclass ((class persistent-metaclass) (super standard-class)) + "Persistent classes may inherit from ordinary classes." t) (defmethod validate-superclass ((class standard-class) (super persistent-metaclass)) + "Ordinary classes may NOT inherit from persistent classes." nil) (defgeneric persistent-p (class)) @@ -111,6 +116,8 @@ t) (defmethod effective-slot-definition-class ((class persistent-metaclass) &rest initargs) + "Chooses the persistent or transient effective slot +definition class depending on the keyword." (let ((transient-p (getf initargs :transient))) (when (consp transient-p) (setq transient-p (car transient-p))) (cond (transient-p @@ -193,17 +200,17 @@ (defmacro persistent-slot-reader (instance name) `(progn - (buffer-write-int (oid ,instance) *key-buf*) - (let* ((key-length (serialize ,name *key-buf*)) - (buf (db-get-key-buffered - (controller-db *store-controller*) - (buffer-stream-buffer *key-buf*) - key-length))) - (if buf (deserialize buf) - #+cmu - (error 'unbound-slot :instance ,instance :slot ,name) - #-cmu - (error 'unbound-slot :instance ,instance :name ,name))))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (oid ,instance) key-buf) + (serialize ,name key-buf) + (let ((buf (db-get-key-buffered + (controller-db *store-controller*) + key-buf value-buf))) + (if buf (deserialize buf) + #+cmu + (error 'unbound-slot :instance ,instance :slot ,name) + #-cmu + (error 'unbound-slot :instance ,instance :name ,name)))))) #+(or cmu sbcl) (defun make-persistent-reader (name) @@ -214,14 +221,14 @@ (defmacro persistent-slot-writer (new-value instance name) `(progn - (buffer-write-int (oid ,instance) *key-buf*) - (let ((key-length (serialize ,name *key-buf*)) - (val-length (serialize ,new-value *out-buf*))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (oid ,instance) key-buf) + (serialize ,name key-buf) + (serialize ,new-value value-buf) (db-put-buffered (controller-db *store-controller*) - (buffer-stream-buffer *key-buf*) key-length - (buffer-stream-buffer *out-buf*) val-length - :transaction *current-transaction* - :auto-commit *auto-commit*) + key-buf value-buf + :transaction *current-transaction* + :auto-commit *auto-commit*) ,new-value))) #+(or cmu sbcl) @@ -233,13 +240,13 @@ (defmacro persistent-slot-boundp (instance name) `(progn - (buffer-write-int (oid ,instance) *key-buf*) - (let* ((key-length (serialize ,name *key-buf*)) - (buf (db-get-key-buffered - (controller-db *store-controller*) - (buffer-stream-buffer *key-buf*) - key-length))) - (if buf T nil)))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (oid ,instance) key-buf) + (serialize ,name key-buf) + (let ((buf (db-get-key-buffered + (controller-db *store-controller*) + key-buf value-buf))) + (if buf T nil))))) #+(or cmu sbcl) (defun make-persistent-slot-boundp (name)

1 0

[elephant-cvs] CVS update: elephant/src/libsleepycat.c
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv25807/src Modified Files: libsleepycat.c Log Message: need to memcpy on writers (alignment) lisp-cmp func, assoc / btree cmp stuff cursor pget, remove key value using cursor length->size Date: Thu Sep 16 06:18:27 2004 Author: blee Index: elephant/src/libsleepycat.c diff -u elephant/src/libsleepycat.c:1.7 elephant/src/libsleepycat.c:1.8 --- elephant/src/libsleepycat.c:1.7 Thu Sep 2 16:45:53 2004 +++ elephant/src/libsleepycat.c Thu Sep 16 06:18:27 2004 @@ -39,40 +39,48 @@ ;;; to the Free Software Foundation, Inc., 59 Temple Place, ;;; Suite 330, Boston, MA 02111-1307 USA ;;; -8? +*/ /* Pointer arithmetic utility functions */ - +/* should these be in network-byte order? probably not..... */ int read_int(char *buf, int offset) { - return *(int*)(buf + offset); + int i; + memcpy(&i, buf+offset, sizeof(int)); + return i; } unsigned int read_uint(char *buf, int offset) { - return *(unsigned int*)(buf + offset); + unsigned int ui; + memcpy(&ui, buf+offset, sizeof(unsigned int)); + return ui; } float read_float(char *buf, int offset) { - return *(float*)(buf + offset); + float f; + memcpy(&f, buf+offset, sizeof(float)); + return f; } double read_double(char *buf, int offset) { - return *(double*)(buf + offset); + double d; + memcpy(&d, buf+offset, sizeof(double)); + return d; } void write_int(char *buf, int num, int offset) { - *(int*)(buf + offset) = num; + memcpy(buf+offset, &num, sizeof(int)); } void write_uint(char *buf, unsigned int num, int offset) { - *(unsigned int*)(buf + offset) = num; + memcpy(buf+offset, &num, sizeof(unsigned int)); } void write_float(char *buf, float num, int offset) { - *(float*)(buf + offset) = num; + memcpy(buf+offset, &num, sizeof(float)); } void write_double(char *buf, double num, int offset) { - *(double*)(buf + offset) = num; + memcpy(buf+offset, &num, sizeof(double)); } char *offset_charp(char *p, int offset) { @@ -172,6 +180,14 @@ return db->truncate(db, txnid, countp, flags); } +int db_set_flags(DB *db, u_int32_t flags) { + return db->set_flags(db, flags); +} + +int db_get_flags(DB *db, u_int32_t *flagsp) { + return db->get_flags(db, flagsp); +} + int db_set_pagesize(DB *db, u_int32_t pagesize) { return db->set_pagesize(db, pagesize); } @@ -180,54 +196,303 @@ return db->get_pagesize(db, pagesizep); } +int db_set_bt_compare(DB *db, + int (*bt_compare_fcn)(DB *db, const DBT *dbt1, + const DBT *dbt2)) { + return db->set_bt_compare(db, bt_compare_fcn); +} + +int db_set_dup_compare(DB *db, + int (*dup_compare_fcn)(DB *db, const DBT *dbt1, + const DBT *dbt2)) { + return db->set_dup_compare(db, dup_compare_fcn); +} + +#define type_numeric(c) ((c)<8) +#include <math.h> + +double read_num(char *buf); + +/* Inspired by the Sleepycat docs. We have to memcpy to + insure memory alignment. */ +int lisp_compare(DB *dbp, const DBT *a, const DBT *b) { + int difference; + double ddifference; + char *ad, *bd, at, bt; + ad = (char*)a->data; + bd = (char*)b->data; + + /* Compare OIDs. */ + difference = read_int(ad, 0) - read_int(bd, 0); + if (difference) return difference; + + /* Have a type tag? */ + if (a->size == 4) + if (b->size == 4) + return 0; + else + return -1; + else if (b->size == 4) + return 1; + + at = ad[4]; bt = bd[4]; + + /* Compare numerics. */ + if (type_numeric(at) && type_numeric(bt)) { + ddifference = read_num(ad+4) - read_num(bd+4); + if (ddifference > 0) return 1; + else if (ddifference < 0) return -1; + return 0; + } + + /* Compare types. */ + difference = at - bt; + if (difference) return difference; + + /* Same type! */ + switch (at) { + case 8: /* nil */ + return 0; + case 9: /* 8-bit symbol */ + case 10: /* 8-bit string */ + case 11: /* 8-bit pathname */ + return case_cmp(ad+9, read_int(ad, 5), bd+9, read_int(bd, 5)); + case 12: /* 16-bit symbol */ + case 13: /* 16-bit string */ + case 14: /* 16-bit pathname */ + return utf16_cmp(ad+9, read_int(ad, 5), bd+9, read_int(bd, 5)); + default: + return lex_cmp(ad+5, (a->size)-5, bd+5, (b->size)-5); + } +} + +int db_set_lisp_compare(DB *db) { + return db->set_bt_compare(db, &lisp_compare); +} + +int db_set_lisp_dup_compare(DB *db) { + return db->set_dup_compare(db, &lisp_compare); +} + +#ifndef exp2 +#define exp2(c) (pow(2,(c))) +#endif + +double read_num(char *buf) { + char *limit; + double i, result, denom; + switch (buf[0]) { + case 1: + case 2: + return (double)read_int(buf, 1); + case 3: + return (double)read_float(buf, 1); + case 4: + return read_double(buf, 1); + case 5: + result = 0; + buf += 5; + limit = buf + read_uint(buf, -4); + for(i=0 ; buf < limit; i++, buf = buf+4) { + result -= exp2(i*32) * read_uint(buf, 0); + } + return result; + case 6: + result = 0; + buf += 5; + limit = buf + read_uint(buf, -4); + for(i=0 ; buf < limit; i++, buf = buf+4) { + result += exp2(i*32) * read_uint(buf, 0); + } + return result; + case 7: + switch ((++buf)[0]) { + case 1: + result = (double)read_int(++buf, 0); + buf += 4; + break; + case 5: + result = 0; + buf += 5; + limit = buf + read_uint(buf, -4); + for(i=0 ; buf < limit; i++, buf = buf+4) { + result -= exp2(i*32) - read_uint(buf, 0); + } + break; + case 6: + result = 0; + buf += 5; + limit = buf + read_uint(buf, -4); + for(i=0 ; buf < limit; i++, buf = buf+4) { + result += exp2(i*32) * read_uint(buf, 0); + } + break; + } + + switch (buf[0]) { + case 1: + return result / read_int(++buf, 0); + case 5: + denom = 0; + buf += 5; + limit = buf + read_uint(buf, -4); + for(i=0 ; buf < limit; i++, buf = buf+4) { + denom -= exp2(i*32) * read_uint(buf, 0); + } + return result / denom; + case 6: + denom = 0; + buf += 5; + limit = buf + read_uint(buf, -4); + for(i=0 ; buf < limit; i++, buf = buf+4) { + denom += exp2(i*32) * read_uint(buf, 0); + } + return result / denom; + } + } +} + +int case_cmp(const char *a, int32_t length1, const char *b, int32_t length2) { + int min, sizediff, diff; + sizediff = length1 - length2; + min = sizediff > 0 ? length2 : length1; + diff = strncasecmp(a, b, min); + if (diff == 0) return sizediff; + return diff; +} + +int lex_cmp(const char *a, int32_t length1, const char *b, int32_t length2) { + int min, sizediff, diff; + sizediff = length1 - length2; + min = sizediff > 0 ? length2 : length1; + diff = memcmp(a, b, min); + if (diff == 0) return sizediff; + return diff; +} +/* The following is copied from + http://oss.software.ibm.com/cvs/icu/~checkout~/icu/source/common/ustring.c +*/ +typedef uint16_t UChar; + +#define UTF_IS_LEAD(c) (((c)&0xfffffc00)==0xd800) +#define UTF_IS_TRAIL(c) (((c)&0xfffffc00)==0xdc00) + +/* compare UTF-16 strings */ +/* memcmp/UnicodeString style, both length-specified */ +/* don't assume byte-aligned! */ +int utf16_cmp(const char *s1, int32_t length1, + const char *s2, int32_t length2) { + const char *start1, *start2, *limit1, *limit2; + UChar c1, c2; + int32_t lengthResult; + + if(length1<length2) { + lengthResult=-1; + limit1=s1+length1; + } else if(length1==length2) { + lengthResult=0; + limit1=s1+length1; + } else /* length1>length2 */ { + lengthResult=1; + limit1=s1+length2; + } + + if(s1==s2) return lengthResult; + + start1=s1; + start2=s2; + + for(;;) { + if(s1==limit1) return lengthResult; + + memcpy(&c1, s1, sizeof(UChar)); + memcpy(&c2, s2, sizeof(UChar)); + if(c1!=c2) break; + + s1 = s1 + 2; + s2 = s2 + 2; + } + + limit1=start1+length1; + limit2=start2+length2; + + if(c1>=0xd800 && c2>=0xd800) { + if(c1>=0xe000) + c1-=0x800; + else + c1+=0x2000; + + if(c2>=0xe000) + c2-=0x800; + else + c2+=0x2000; + + /* here's some newer code which i can't make work + if((c1<=0xdbff && (s1+1)!=limit1 && UTF_IS_TRAIL(*(s1+1))) || + (UTF_IS_TRAIL(c1) && start1!=s1 && UTF_IS_LEAD(*(s1-1)))) { + } else { + c1-=0x2800; + } + + if((c2<=0xdbff && (s2+1)!=limit2 && UTF_IS_TRAIL(*(s2+1))) || + (UTF_IS_TRAIL(c2) && start2!=s2 && UTF_IS_LEAD(*(s2-1)))) { + } else { + c2-=0x2800; + }*/ + } + + return (int32_t)c1-(int32_t)c2; +} + + /* Accessors */ /* We manage our own buffers (DB_DBT_USERMEM). */ int db_get_raw(DB *db, DB_TXN *txnid, - char *key, u_int32_t key_length, + char *key, u_int32_t key_size, char *buffer, u_int32_t buffer_length, - u_int32_t flags, u_int32_t *result_length) { - DBT DBTKey, DBTDatum; + u_int32_t flags, u_int32_t *result_size) { + DBT DBTKey, DBTValue; int ret; memset(&DBTKey, 0, sizeof(DBT)); - memset(&DBTDatum, 0, sizeof(DBT)); + memset(&DBTValue, 0, sizeof(DBT)); DBTKey.data = key; - DBTKey.size = key_length; - DBTDatum.data = buffer; - DBTDatum.ulen = buffer_length; - DBTDatum.flags |= DB_DBT_USERMEM; + DBTKey.size = key_size; + DBTValue.data = buffer; + DBTValue.ulen = buffer_length; + DBTValue.flags |= DB_DBT_USERMEM; - ret = db->get(db, txnid, &DBTKey, &DBTDatum, flags); - *result_length = DBTDatum.size; + ret = db->get(db, txnid, &DBTKey, &DBTValue, flags); + *result_size = DBTValue.size; return ret; } int db_put_raw(DB *db, DB_TXN *txnid, - char *key, u_int32_t key_length, - char *datum, u_int32_t datum_length, + char *key, u_int32_t key_size, + char *value, u_int32_t value_size, u_int32_t flags) { - DBT DBTKey, DBTDatum; + DBT DBTKey, DBTValue; memset(&DBTKey, 0, sizeof(DBT)); - memset(&DBTDatum, 0, sizeof(DBT)); + memset(&DBTValue, 0, sizeof(DBT)); DBTKey.data = key; - DBTKey.size = key_length; - DBTDatum.data = datum; - DBTDatum.size = datum_length; + DBTKey.size = key_size; + DBTValue.data = value; + DBTValue.size = value_size; - return db->put(db, txnid, &DBTKey, &DBTDatum, flags); + return db->put(db, txnid, &DBTKey, &DBTValue, flags); } int db_del(DB *db, DB_TXN *txnid, - char *key, u_int32_t key_length, + char *key, u_int32_t key_size, u_int32_t flags) { DBT DBTKey; memset(&DBTKey, 0, sizeof(DBT)); DBTKey.data = key; - DBTKey.size = key_length; + DBTKey.size = key_size; return db->del(db, txnid, &DBTKey, flags); } @@ -255,72 +520,148 @@ } int db_cursor_get_raw(DBC *cursor, - char *keybuf, u_int32_t keybuf_length, - char *buffer, u_int32_t buffer_length, - u_int32_t flags, u_int32_t *key_length, - u_int32_t *result_length) { - DBT DBTKey, DBTDatum; + char *keybuf, u_int32_t keybuf_size, + u_int32_t keybuf_length, + char *buffer, u_int32_t buffer_size, + u_int32_t buffer_length, + u_int32_t flags, u_int32_t *ret_key_size, + u_int32_t *result_size) { + DBT DBTKey, DBTValue; + int ret; + + memset(&DBTKey, 0, sizeof(DBT)); + memset(&DBTValue, 0, sizeof(DBT)); + DBTKey.data = keybuf; + DBTKey.size = keybuf_size; + DBTKey.ulen = keybuf_length; + DBTKey.flags |= DB_DBT_USERMEM; + DBTValue.data = buffer; + DBTValue.size = buffer_size; + DBTValue.ulen = buffer_length; + DBTValue.flags |= DB_DBT_USERMEM; + + ret = cursor->c_get(cursor, &DBTKey, &DBTValue, flags); + *ret_key_size = DBTKey.size; + *result_size = DBTValue.size; + + return ret; +} + +int db_cursor_pget_raw(DBC *cursor, + char *keybuf, u_int32_t keybuf_size, + u_int32_t keybuf_length, + char *pkeybuf, u_int32_t pkeybuf_size, + u_int32_t pkeybuf_length, + char *buffer, u_int32_t buffer_size, + u_int32_t buffer_length, + u_int32_t flags, + u_int32_t *ret_key_size, + u_int32_t *ret_pkey_size, + u_int32_t *result_size) { + DBT DBTKey, DBTPKey, DBTValue; int ret; memset(&DBTKey, 0, sizeof(DBT)); - memset(&DBTDatum, 0, sizeof(DBT)); + memset(&DBTPKey, 0, sizeof(DBT)); + memset(&DBTValue, 0, sizeof(DBT)); DBTKey.data = keybuf; + DBTKey.size = keybuf_size; DBTKey.ulen = keybuf_length; DBTKey.flags |= DB_DBT_USERMEM; - DBTDatum.data = buffer; - DBTDatum.ulen = buffer_length; - DBTDatum.flags |= DB_DBT_USERMEM; - - ret = cursor->c_get(cursor, &DBTKey, &DBTDatum, flags); - *key_length = DBTKey.size; - *result_length = DBTDatum.size; + DBTPKey.data = pkeybuf; + DBTPKey.size = pkeybuf_size; + DBTPKey.ulen = pkeybuf_length; + DBTPKey.flags |= DB_DBT_USERMEM; + DBTValue.data = buffer; + DBTValue.size = buffer_size; + DBTValue.ulen = buffer_length; + DBTValue.flags |= DB_DBT_USERMEM; + + ret = cursor->c_pget(cursor, &DBTKey, &DBTPKey, &DBTValue, flags); + *ret_key_size = DBTKey.size; + *ret_pkey_size = DBTPKey.size; + *result_size = DBTValue.size; return ret; } int db_cursor_put_raw(DBC *cursor, - char *key, u_int32_t key_length, - char *datum, u_int32_t datum_length, + char *key, u_int32_t key_size, + char *value, u_int32_t value_size, u_int32_t flags) { - DBT DBTKey, DBTDatum; + DBT DBTKey, DBTValue; memset(&DBTKey, 0, sizeof(DBT)); - memset(&DBTDatum, 0, sizeof(DBT)); + memset(&DBTValue, 0, sizeof(DBT)); DBTKey.data = key; - DBTKey.size = key_length; - DBTDatum.data = datum; - DBTDatum.size = datum_length; + DBTKey.size = key_size; + DBTValue.data = value; + DBTValue.size = value_size; - return cursor->c_put(cursor, &DBTKey, &DBTDatum, flags); + return cursor->c_put(cursor, &DBTKey, &DBTValue, flags); } +/* Silently does nothing if the key/value isn't found. + Can't use auto-commit here! */ +int db_del_kv(DB *db, DB_TXN *tid, + char *key, u_int32_t key_size, + char *value, u_int32_t value_size) { + DBT DBTKey, DBTValue; + DBC *cursor; + int ret, c_ret; + + memset(&DBTKey, 0, sizeof(DBT)); + DBTKey.data = key; + DBTKey.size = key_size; + memset(&DBTValue, 0, sizeof(DBT)); + DBTValue.data = value; + DBTValue.size = value_size; + + if ((ret = db->cursor(db, tid, &cursor, 0)) != 0) + return ret; + + if ((ret = cursor->c_get(cursor, &DBTKey, &DBTValue, DB_GET_BOTH)) != 0) + goto fail; + + ret = cursor->c_del(cursor, 0); + + fail: + if ((c_ret = cursor->c_close(cursor)) != 0) + return c_ret; + return ret; +} + /* Bulk retrieval */ int db_cursor_get_multiple_key(DBC *cursor, - char *keybuf, u_int32_t keybuf_length, - char *buffer, u_int32_t buffer_length, - u_int32_t flags, u_int32_t *key_length, - u_int32_t *result_length, + char *keybuf, u_int32_t keybuf_size, + u_int32_t keybuf_length, + char *buffer, u_int32_t buffer_size, + u_int32_t buffer_length, + u_int32_t flags, u_int32_t *ret_key_size, + u_int32_t *result_size, void **pointer, DBT **data) { - DBT DBTKey, DBTDatum; + DBT DBTKey, DBTValue; int ret; memset(&DBTKey, 0, sizeof(DBT)); - memset(&DBTDatum, 0, sizeof(DBT)); + memset(&DBTValue, 0, sizeof(DBT)); DBTKey.data = keybuf; + DBTKey.size = keybuf_size; DBTKey.ulen = keybuf_length; DBTKey.flags |= DB_DBT_USERMEM; - DBTDatum.data = buffer; - DBTDatum.ulen = buffer_length; - DBTDatum.flags |= DB_DBT_USERMEM; + DBTValue.data = buffer; + DBTValue.size = buffer_size; + DBTValue.ulen = buffer_length; + DBTValue.flags |= DB_DBT_USERMEM; flags |= DB_MULTIPLE_KEY; - ret = cursor->c_get(cursor, &DBTKey, &DBTDatum, flags); - *key_length = DBTKey.size; - *result_length = DBTDatum.size; - if ((DBTKey.size <= DBTKey.ulen) && (DBTDatum.size <= DBTDatum.ulen)) { - **data = DBTDatum; + ret = cursor->c_get(cursor, &DBTKey, &DBTValue, flags); + *ret_key_size = DBTKey.size; + *result_size = DBTValue.size; + if ((DBTKey.size <= DBTKey.ulen) && (DBTValue.size <= DBTValue.ulen)) { + **data = DBTValue; DB_MULTIPLE_INIT(*pointer, *data); } @@ -328,11 +669,11 @@ } void db_multiple_key_next(void *pointer, DBT *data, - char **key, u_int32_t *key_length, - char **result, u_int32_t *result_length) { + char **key, u_int32_t *ret_key_size, + char **result, u_int32_t *result_size) { DB_MULTIPLE_KEY_NEXT(pointer, data, - *key, *key_length, - *result, *result_length); + *key, *ret_key_size, + *result, *result_size); } /* Transactions */ @@ -373,12 +714,12 @@ } int db_env_lock_get(DB_ENV *env, u_int32_t locker, - u_int32_t flags, char *object, u_int32_t object_length, + u_int32_t flags, char *object, u_int32_t object_size, const db_lockmode_t lock_mode, DB_LOCK *lock) { DBT DBTObject; memset(&DBTObject, 0, sizeof(DBT)); DBTObject.data = object; - DBTObject.size = object_length; + DBTObject.size = object_size; return env->lock_get(env, locker, flags, &DBTObject, lock_mode, lock); } @@ -414,11 +755,28 @@ return env->lock_detect(env, flags, atype, aborted); } +/* Secondary indices */ + +int db_associate(DB *primary, DB_TXN *txnid, DB *secondary, + int (*callback)(DB *, const DBT *, const DBT *, DBT *), + u_int32_t flags) { + return primary->associate(primary, txnid, secondary, callback, flags); +} + +int never_index(DB *db, const DBT *key, const DBT *data, DBT *result) { + return DB_DONOTINDEX; +} + +int db_fake_associate(DB *primary, DB_TXN *txnid, DB *secondary, + u_int32_t flags) { + return primary->associate(primary, txnid, secondary, &never_index, flags); +} + /* Poor man's counters */ int next_counter(DB_ENV *env, DB *db, DB_TXN *parent, - char *key, u_int32_t key_length, - char *lockid, u_int32_t lockid_length) { + char *key, u_int32_t key_size, + char *lockid, u_int32_t lockid_size) { DB_LOCK lock; DBT DBTKey, DBTData; DB_TXN *tid; @@ -430,9 +788,9 @@ memset(&DBTKey, 0, sizeof(DBTKey)); memset(&DBTData, 0, sizeof(DBTData)); DBTKey.data = key; - DBTKey.size = key_length; + DBTKey.size = key_size; DBTData.data = lockid; - DBTData.size = lockid_length; + DBTData.size = lockid_size; tries = 0;

1 0

[elephant-cvs] CVS update: elephant/src/elephant.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv25620/src Modified Files: elephant.lisp Log Message: doc-strings slot-makunbound-using-class Date: Thu Sep 16 06:16:15 2004 Author: blee Index: elephant/src/elephant.lisp diff -u elephant/src/elephant.lisp:1.10 elephant/src/elephant.lisp:1.11 --- elephant/src/elephant.lisp:1.10 Sat Sep 4 10:17:24 2004 +++ elephant/src/elephant.lisp Thu Sep 16 06:16:14 2004 @@ -41,16 +41,39 @@ ;;; (defpackage elephant + (:documentation + "Elephant: an object-oriented database for Common Lisp. +Uses the SLEEPYCAT package to talk to Berkeley DB / +Sleepycat.") (:nicknames ele :ele) - (:use common-lisp sleepycat) + (:use common-lisp sleepycat uffi) (:shadow #:with-transaction) (:export #:*store-controller* #:*current-transaction* #:*auto-commit* #:open-store #:close-store #:with-open-store #:store-controller #:open-controller #:close-controller #:with-open-controller #:controller-path #:controller-environment #:controller-db #:controller-root #:add-to-root #:get-from-root + #:persistent #:persistent-object #:persistent-metaclass + #:persistent-collection #:btree #:get-value #:remove-kv + #:indexed-btree #:add-index #:get-index #:remove-index + #:btree-index #:get-primary-key + #:indices #:primary #:key-form #:key-fn + + #:cursor #:secondary-cursor #:make-cursor + #:with-btree-cursor #:map-btree #:cursor-close + #:cursor-duplicate #:cursor-current #:cursor-first + #:cursor-last #:cursor-next #:cursor-next-dup + #:cursor-next-nodup #:cursor-prev #:cursor-prev-nodup + #:cursor-set #:cursor-set-range #:cursor-get-both + #:cursor-get-both-range #:cursor-delete #:cursor-put + #:cursor-pcurrent #:cursor-pfirst #:cursor-plast + #:cursor-pnext #:cursor-pnext-dup #:cursor-pnext-nodup + #:cursor-pprev #:cursor-pprev-nodup #:cursor-pset + #:cursor-pset-range #:cursor-pget-both + #:cursor-pget-both-range + #:db-transaction-begin #:db-transaction-abort #:db-transaction-commit #:with-transaction #:db-env-set-lock-detect #:db-env-get-lock-detect @@ -76,6 +99,7 @@ class-slots slot-value-using-class slot-boundp-using-class + slot-makunbound-using-class slot-definition-allocation slot-definition-initargs compute-slots @@ -113,6 +137,7 @@ class-slots slot-value-using-class slot-boundp-using-class + slot-makunbound-using-class slot-definition-allocation slot-definition-initargs compute-slots) @@ -151,6 +176,7 @@ class-slots slot-value-using-class slot-boundp-using-class + slot-makunbound-using-class slot-definition-allocation slot-definition-initargs compute-slots) @@ -173,6 +199,7 @@ class-slots slot-value-using-class slot-boundp-using-class + slot-makunbound-using-class slot-definition-allocation slot-definition-initargs compute-slots @@ -203,10 +230,15 @@ class-slots slot-value-using-class slot-boundp-using-class + slot-makunbound-using-class slot-definition-allocation slot-definition-initargs compute-slots) ) -(in-package "ELE") \ No newline at end of file +(in-package "ELE") + +#+cmu +(eval-when (:compile-toplevel) + (proclaim '(optimize (ext:inhibit-warnings 3)))) \ No newline at end of file

1 0