[elephant-cvs] CVS update: elephant/src/classes.lisp elephant/src/collections.lisp elephant/src/controller.lisp elephant/src/elephant.lisp elephant/src/libsleepycat.c elephant/src/metaclasses.lisp elephant/src/serializer.lisp elephant/src/sleepycat.lisp elephant/src/utils.lisp
Robert L. Read
rread at common-lisp.net
Tue Oct 18 20:41:35 UTC 2005
Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp.net:/tmp/cvs-serv16451/src
Modified Files:
Tag: SQL-BACK-END
classes.lisp collections.lisp controller.lisp elephant.lisp
libsleepycat.c metaclasses.lisp serializer.lisp sleepycat.lisp
utils.lisp
Log Message:
Differences of existing files based on sql-back-end work
Date: Tue Oct 18 22:41:27 2005
Author: rread
Index: elephant/src/classes.lisp
diff -u elephant/src/classes.lisp:1.13 elephant/src/classes.lisp:1.13.2.1
--- elephant/src/classes.lisp:1.13 Thu Feb 24 02:07:52 2005
+++ elephant/src/classes.lisp Tue Oct 18 22:41:27 2005
@@ -45,13 +45,31 @@
(defmethod initialize-instance :before ((instance persistent)
&rest initargs
- &key from-oid)
+ &key from-oid
+ spec
+ ;; Putting the default use
+ ;; of the global variable here
+ ;; is very bad for testing and multi-repository
+ ;; use; it is, however, good for making
+ ;; things work exactly the way they originally did!
+ (sc *store-controller*))
"Sets the OID."
(declare (ignore initargs))
+
+;; This lines are fundamentally valuable in making sure that
+;; we hvae completely specified things.
+;; (if (null sc)
+;; (break))
(if (not from-oid)
- (setf (oid instance) (next-oid *store-controller*))
+ (setf (oid instance) (next-oid sc))
(setf (oid instance) from-oid))
- (cache-instance *store-controller* instance))
+ (if (not spec)
+ (if (not (typep sc 'bdb-store-controller))
+ (setf (:dbcn-spc-pst instance) (:dbcn-spc sc))
+ (setf (:dbcn-spc-pst instance) (controller-path sc))
+ )
+ (setf (:dbcn-spc-pst instance) spec))
+ (cache-instance sc instance))
(defclass persistent-object (persistent)
()
@@ -141,7 +159,7 @@
(flet ((persistent-slot-p (item)
(member item persistent-slot-names :test #'eq)))
(let ((transient-slot-inits
- (if (eq slot-names t) ; t means all slots
+ (if (eq slot-names t) ; t means all slots
(transient-slot-names class)
(remove-if #'persistent-slot-p slot-names)))
(persistent-slot-inits
@@ -150,23 +168,27 @@
;; initialize the persistent slots
(flet ((initialize-from-initarg (slot-def)
(loop for initarg in initargs
- with slot-initargs = (slot-definition-initargs slot-def)
- when (member initarg slot-initargs :test #'eq)
- do
- (setf (slot-value-using-class class instance slot-def)
- (getf initargs initarg))
- (return t))))
+ with slot-initargs = (slot-definition-initargs slot-def)
+ when (member initarg slot-initargs :test #'eq)
+ do
+ (setf (slot-value-using-class class instance slot-def)
+ (getf initargs initarg))
+ (return t))))
(loop for slot-def in (class-slots class)
- unless (initialize-from-initarg slot-def)
- when (member (slot-definition-name slot-def) persistent-slot-inits :test #'eq)
- unless (slot-boundp-using-class class instance slot-def)
- do
- (let ((initfun (slot-definition-initfunction slot-def)))
- (when initfun
- (setf (slot-value-using-class class instance slot-def)
- (funcall initfun))))))
- ;; let the implementation initialize the transient slots
- (apply #'call-next-method instance transient-slot-inits initargs)))))
+ unless
+ (initialize-from-initarg slot-def)
+ when
+ (member (slot-definition-name slot-def) persistent-slot-inits :test #'eq)
+ unless
+ (slot-boundp-using-class class instance slot-def)
+ do
+ (let ((initfun (slot-definition-initfunction slot-def)))
+ (when initfun
+ (setf (slot-value-using-class class instance slot-def)
+ (funcall initfun))))
+ )
+ ;; let the implementation initialize the transient slots
+ (apply #'call-next-method instance transient-slot-inits initargs))))))
(defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys)
;; probably should delete discarded slots, but we'll worry about that later
@@ -237,14 +259,26 @@
(defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
"Deletes the slot from the database."
- (declare (optimize (speed 3)))
- (with-buffer-streams (key-buf)
- (buffer-write-int (oid instance) key-buf)
- (serialize (slot-definition-name slot-def) key-buf)
- (db-delete-buffered
- (controller-db *store-controller*) key-buf
- :transaction *current-transaction*
- :auto-commit *auto-commit*))
+ (declare (optimize (speed 3))
+ (ignore class))
+ (if (sql-store-spec-p (:dbcn-spc-pst instance))
+ (progn
+ (let* ((sc (check-con (:dbcn-spc-pst instance)))
+ (con (controller-db sc)))
+ (sql-remove-from-root
+ (form-slot-key (oid instance) (slot-definition-name slot-def))
+ sc
+ con
+ )
+ ))
+ (with-buffer-streams (key-buf)
+ (buffer-write-int (oid instance) key-buf)
+ (serialize (slot-definition-name slot-def) key-buf)
+ (db-delete-buffered
+ (controller-db (check-con (:dbcn-spc-pst instance))) key-buf
+ :transaction *current-transaction*
+ :auto-commit *auto-commit*))
+ )
instance)
#+allegro
@@ -253,4 +287,4 @@
until (eq (slot-definition-name slot) slot-name)
finally (if (typep slot 'persistent-slot-definition)
(slot-makunbound-using-class class instance slot)
- (call-next-method))))
\ No newline at end of file
+ (call-next-method))))
Index: elephant/src/collections.lisp
diff -u elephant/src/collections.lisp:1.11 elephant/src/collections.lisp:1.11.2.1
--- elephant/src/collections.lisp:1.11 Sat Sep 25 20:57:37 2004
+++ elephant/src/collections.lisp Tue Oct 18 22:41:27 2005
@@ -48,10 +48,36 @@
(:documentation "Abstract superclass of all collection types."))
;;; btree access
-(defclass btree (persistent-collection) ()
+(defclass btree (persistent-collection)
+
+;; I don't like having to put this here, as this is only used by
+;; the extending class indexed-btree. But I can't figure out
+;; how to make the :transient flag work on that class without
+;; creating a circularity in the class presidence list...
+(
+)
(:documentation "A hash-table like interface to a BTree,
which stores things in a semi-ordered fashion."))
+(defclass bdb-btree (btree) ()
+ (:documentation "A BerkleyDB implementation of a BTree"))
+
+
+;; It would be nice if this were a macro or a function
+;; that would allow all of its arguments to be passed through;
+;; otherwise an initialization slot is inaccessible.
+;; I'll worry about that later.
+(defun make-bdb-btree (sc)
+ (let ((bt (make-instance 'bdb-btree :sc sc)))
+ (setf (:dbcn-spc-pst bt) (controller-path sc))
+ bt)
+ )
+
+;; somehow these functions need to be part of our strategy,
+;; or better yet methods on the store-controller.
+
+
+
(defgeneric get-value (key bt)
(:documentation "Get a value from a Btree."))
@@ -61,45 +87,128 @@
(defgeneric remove-kv (key bt)
(:documentation "Remove a key / value pair from a BTree."))
-(defmethod get-value (key (bt btree))
+(defmethod get-value (key (bt bdb-btree))
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(let ((buf (db-get-key-buffered
- (controller-btrees *store-controller*)
+ (controller-btrees
+ (check-con (:dbcn-spc-pst bt))
+;; *store-controller*
+ )
key-buf value-buf)))
- (if buf (values (deserialize buf) T)
+ (if buf (values (deserialize buf :sc (check-con (:dbcn-spc-pst bt))) T)
(values nil nil)))))
-(defmethod (setf get-value) (value key (bt btree))
+(defmethod existsp (key (bt bdb-btree))
+ (declare (optimize (speed 3)))
+ (with-buffer-streams (key-buf value-buf)
+ (buffer-write-int (oid bt) key-buf)
+ (serialize key key-buf)
+ (let ((buf (db-get-key-buffered
+ (controller-btrees (check-con (:dbcn-spc-pst bt)))
+ key-buf value-buf)))
+ (if buf t
+ nil))))
+
+
+(defmethod (setf get-value) (value key (bt bdb-btree))
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(serialize value value-buf)
- (db-put-buffered (controller-btrees *store-controller*)
+ (db-put-buffered (controller-btrees (check-con (:dbcn-spc-pst bt)))
key-buf value-buf
:auto-commit *auto-commit*)
value))
-(defmethod remove-kv (key (bt btree))
+(defmethod remove-kv (key (bt bdb-btree))
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
- (db-delete-buffered (controller-btrees *store-controller*)
+ (db-delete-buffered (controller-btrees (check-con (:dbcn-spc-pst bt)))
key-buf :auto-commit *auto-commit*)))
;; Secondary indices
-(defclass indexed-btree (btree)
- ((indices :accessor indices :initform (make-hash-table))
+ (defclass indexed-btree ()
+ (
+ )
+ (:documentation "A BTree which supports secondary indices."))
+
+
+
+(defclass bdb-indexed-btree (indexed-btree bdb-btree )
+ (
+ (indices :accessor indices :initform (make-hash-table)
+ )
(indices-cache :accessor indices-cache :initform (make-hash-table)
- :transient t))
+ :transient t
+)
+ )
(:metaclass persistent-metaclass)
- (:documentation "A BTree which supports secondary indices."))
+ (:documentation "A BDB-based BTree supports secondary indices."))
+
+
+(defmethod build-indexed-btree ((sc bdb-store-controller))
+ (let ((bt (make-instance 'bdb-indexed-btree :sc sc)))
+ (setf (:dbcn-spc-pst bt) (controller-path sc))
+;; I must be confused with multipler inheritance, because the above
+;;; initforms in bdb-indexed-btree should be working, but aren't.
+ (setf (indices bt) (make-hash-table))
+ (setf (indices-cache bt) (make-hash-table))
+ bt)
+ )
+
+(defmethod build-btree-index ((sc bdb-store-controller) &key primary key-form)
+ (let ((bt (make-instance 'bdb-btree-index :primary primary :key-form key-form :sc sc)))
+ (setf (:dbcn-spc-pst bt) (controller-path sc))
+;; I must be confused with multipler inheritance, because the above
+;;; initforms in bdb-indexed-btree should be working, but aren't.
+ bt)
+ )
+
+(defun btree-differ (x y)
+ (let ((cx1 (make-cursor x))
+ (cy1 (make-cursor y))
+ (done nil)
+ (rv nil)
+ (mx nil)
+ (kx nil)
+ (vx nil)
+ (my nil)
+ (ky nil)
+ (vy nil))
+ (cursor-first cx1)
+ (cursor-first cy1)
+ (do ((i 0 (1+ i)))
+ (done nil)
+ (multiple-value-bind (m k v) (cursor-current cx1)
+ (setf mx m)
+ (setf kx k)
+ (setf vx v))
+ (multiple-value-bind (m k v) (cursor-current cy1)
+ (setf my m)
+ (setf ky k)
+ (setf vy v))
+ (if (not (and (equal mx my)
+ (equal kx ky)
+ (equal vx vy)))
+ (setf rv (list mx my kx ky vx vy)))
+ (setf done (and (not mx) (not mx))
+ )
+ (cursor-next cx1)
+ (cursor-next cy1)
+ )
+ (cursor-close cx1)
+ (cursor-close cy1)
+ rv
+ ))
+
(defmethod shared-initialize :after ((instance indexed-btree) slot-names
&rest rest)
@@ -124,39 +233,47 @@
(defgeneric remove-index (bt index-name)
(:documentation "Remove a named index."))
-(defmethod add-index ((bt indexed-btree) &key index-name key-form populate)
- (if (and (not (null index-name))
- (symbolp index-name) (or (symbolp key-form) (listp key-form)))
- (let ((indices (indices bt))
- (index (make-instance 'btree-index :primary bt
- :key-form key-form)))
- (setf (gethash index-name (indices-cache bt)) index)
- (setf (gethash index-name indices) index)
- (setf (indices bt) indices)
- (when populate
- (let ((key-fn (key-fn index)))
- (with-buffer-streams (primary-buf secondary-buf)
- (with-transaction ()
- (map-btree
- #'(lambda (k v)
- (multiple-value-bind (index? secondary-key)
- (funcall key-fn index k v)
- (when index?
- (buffer-write-int (oid bt) primary-buf)
- (serialize k primary-buf)
- (buffer-write-int (oid index) secondary-buf)
- (serialize secondary-key secondary-buf)
- ;; should silently do nothing if
- ;; the key/value already exists
- (db-put-buffered
- (controller-indices *store-controller*)
- secondary-buf primary-buf)
- (reset-buffer-stream primary-buf)
- (reset-buffer-stream secondary-buf))))
- bt)))))
- index)
- (error "Invalid index initargs!")))
-
+(defmethod add-index ((bt bdb-indexed-btree) &key index-name key-form populate)
+ (let ((sc (check-con (:dbcn-spc-pst bt))))
+;; Setting the value of *store-controller* is unfortunately
+;; absolutely required at present, I think because the copying
+;; of objects is calling "make-instance" without an argument.
+;; I am sure I can find a way to make this cleaner, somehow.
+ (if (and (not (null index-name))
+ (symbolp index-name) (or (symbolp key-form) (listp key-form)))
+ ;; Can it be that this fails?
+ (let (
+ (ht (indices bt))
+ (index (build-btree-index sc :primary bt
+ :key-form key-form)))
+ (setf (gethash index-name (indices-cache bt)) index)
+ (setf (gethash index-name ht) index)
+ (setf (indices bt) ht)
+ (when populate
+ (let ((key-fn (key-fn index)))
+ (with-buffer-streams (primary-buf secondary-buf)
+ (with-transaction (:store-controller sc)
+ (map-btree
+ #'(lambda (k v)
+ (multiple-value-bind (index? secondary-key)
+ (funcall key-fn index k v)
+ (when index?
+ (buffer-write-int (oid bt) primary-buf)
+ (serialize k primary-buf)
+ (buffer-write-int (oid index) secondary-buf)
+ (serialize secondary-key secondary-buf)
+ ;; should silently do nothing if
+ ;; the key/value already exists
+ (db-put-buffered
+ (controller-indices sc)
+ secondary-buf primary-buf)
+ (reset-buffer-stream primary-buf)
+ (reset-buffer-stream secondary-buf))))
+ bt)))))
+ index)
+ (error "Invalid index initargs!")))
+)
+
(defmethod get-index ((bt indexed-btree) index-name)
(gethash index-name (indices-cache bt)))
@@ -166,65 +283,75 @@
(remhash index-name indices)
(setf (indices bt) indices)))
-(defmethod (setf get-value) (value key (bt indexed-btree))
+(defmethod (setf get-value) (value key (bt bdb-indexed-btree))
"Set a key / value pair, and update secondary indices."
- (declare (optimize (speed 3)))
- (let ((indices (indices-cache bt)))
- (with-buffer-streams (key-buf value-buf secondary-buf)
- (buffer-write-int (oid bt) key-buf)
- (serialize key key-buf)
- (serialize value value-buf)
- (with-transaction ()
- (db-put-buffered (controller-btrees *store-controller*)
- key-buf value-buf)
- (loop for index being the hash-value of indices
- do
- (multiple-value-bind (index? secondary-key)
- (funcall (key-fn index) index key value)
- (when index?
- (buffer-write-int (oid index) secondary-buf)
- (serialize secondary-key secondary-buf)
- ;; should silently do nothing if the key/value already
- ;; exists
- (db-put-buffered (controller-indices *store-controller*)
- secondary-buf key-buf)
- (reset-buffer-stream secondary-buf))))
- value))))
-
-(defmethod remove-kv (key (bt indexed-btree))
- "Remove a key / value pair, and update secondary indices."
- (declare (optimize (speed 3)))
- (with-buffer-streams (key-buf secondary-buf)
- (buffer-write-int (oid bt) key-buf)
- (serialize key key-buf)
- (with-transaction ()
- (let ((value (get-value key bt)))
- (when value
- (let ((indices (indices-cache bt)))
- (loop
- for index being the hash-value of indices
+ (let ((sc (check-con (:dbcn-spc-pst bt))))
+ (let ((indices (indices-cache bt)))
+ (with-buffer-streams (key-buf value-buf secondary-buf)
+ (buffer-write-int (oid bt) key-buf)
+ (serialize key key-buf)
+ (serialize value value-buf)
+ (with-transaction (:store-controller sc)
+ (db-put-buffered (controller-btrees sc)
+ key-buf value-buf)
+ (loop for index being the hash-value of indices
do
(multiple-value-bind (index? secondary-key)
(funcall (key-fn index) index key value)
(when index?
(buffer-write-int (oid index) secondary-buf)
(serialize secondary-key secondary-buf)
- ;; need to remove kv pairs with a cursor! --
- ;; this is a C performance hack
- (sleepycat::db-delete-kv-buffered
- (controller-indices *store-controller*)
- secondary-buf key-buf)
+ ;; should silently do nothing if the key/value already
+ ;; exists
+ (db-put-buffered (controller-indices sc)
+ secondary-buf key-buf)
(reset-buffer-stream secondary-buf))))
- (db-delete-buffered (controller-btrees *store-controller*)
- key-buf)))))))
+ value))))
+ )
+
+(defmethod remove-kv (key (bt bdb-indexed-btree))
+ "Remove a key / value pair, and update secondary indices."
+ (declare (optimize (speed 3)))
+ (let ((sc (check-con (:dbcn-spc-pst bt))))
+ (with-buffer-streams (key-buf secondary-buf)
+ (buffer-write-int (oid bt) key-buf)
+ (serialize key key-buf)
+ (with-transaction (:store-controller sc)
+ (let ((value (get-value key bt)))
+ (when value
+ (let ((indices (indices-cache bt)))
+ (loop
+ for index being the hash-value of indices
+ do
+ (multiple-value-bind (index? secondary-key)
+ (funcall (key-fn index) index key value)
+ (when index?
+ (buffer-write-int (oid index) secondary-buf)
+ (serialize secondary-key secondary-buf)
+ ;; need to remove kv pairs with a cursor! --
+ ;; this is a C performance hack
+ (sleepycat::db-delete-kv-buffered
+ (controller-indices (check-con (:dbcn-spc-pst bt)))
+ secondary-buf key-buf)
+ (reset-buffer-stream secondary-buf))))
+ (db-delete-buffered (controller-btrees (check-con (:dbcn-spc-pst bt)))
+ key-buf))))))))
+;; This also needs to build the correct kind of index, and
+;; be the correct kind of btree...
(defclass btree-index (btree)
((primary :type indexed-btree :reader primary :initarg :primary)
- (key-form :reader key-form :initarg :key-form)
+ (key-form :reader key-form :initarg :key-form :initform nil)
(key-fn :type function :accessor key-fn :transient t))
(:metaclass persistent-metaclass)
(:documentation "Secondary index to an indexed-btree."))
+
+(defclass bdb-btree-index (btree-index bdb-btree )
+ ()
+ (:metaclass persistent-metaclass)
+ (:documentation "A BDB-based BTree supports secondary indices."))
+
(defmethod shared-initialize :after ((instance btree-index) slot-names
&rest rest)
(declare (ignore slot-names rest))
@@ -233,16 +360,18 @@
(setf (key-fn instance) (fdefinition key-form))
(setf (key-fn instance) (compile nil key-form)))))
-(defmethod get-value (key (bt btree-index))
+;; I now think this code should be split out into a separate
+;; class...
+(defmethod get-value (key (bt bdb-btree-index))
"Get the value in the primary DB from a secondary key."
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(let ((buf (db-get-key-buffered
- (controller-indices-assoc *store-controller*)
+ (controller-indices-assoc (check-con (:dbcn-spc-pst bt)))
key-buf value-buf)))
- (if buf (values (deserialize buf) T)
+ (if buf (values (deserialize buf :sc (check-con (:dbcn-spc-pst bt))) T)
(values nil nil)))))
(defmethod (setf get-value) (value key (bt btree-index))
@@ -260,11 +389,11 @@
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(let ((buf (db-get-key-buffered
- (controller-indices *store-controller*)
+ (controller-indices (check-con (:dbcn-spc-pst bt)))
key-buf value-buf)))
(if buf
(let ((oid (buffer-read-fixnum buf)))
- (values (deserialize buf) oid))
+ (values (deserialize buf :sc (check-con (:dbcn-spc-pst bt))) oid))
(values nil nil)))))
(defmethod remove-kv (key (bt btree-index))
@@ -275,18 +404,39 @@
;; Cursor operations
-
+;; Node that I have not created a bdb-cursor, but have
+;; created a sql-currsor. This is almost certainly wrong
+;; and furthermore will badly screw things up when we get to
+;; secondary cursors.
(defclass cursor ()
- ((handle :accessor cursor-handle :initarg :handle)
+ (
(oid :accessor cursor-oid :type fixnum :initarg :oid)
+
+;; (intialized-p cursor) means that the cursor has
+;; a legitimate position, not that any initialization
+;; action has been taken. The implementors of this abstract class
+;; should make sure that happens under the sheets...
+;; According to my understanding, cursors are initialized
+;; when you invoke an operation that sets them to something
+;; (such as cursor-first), and are uninitialized if you
+;; move them in such a way that they no longer have a legimtimate
+;; value.
(initialized-p :accessor cursor-initialized-p
:type boolean :initform nil :initarg :initialized-p)
(btree :accessor cursor-btree :initarg :btree))
(:documentation "A cursor for traversing (primary) BTrees."))
+(defclass bdb-cursor (cursor)
+ (
+ (handle :accessor cursor-handle :initarg :handle)
+ )
+ (:documentation "A cursor for traversing (primary) BDB-BTrees."))
+
+
(defgeneric make-cursor (bt)
(:documentation "Construct a cursor for traversing BTrees."))
+
(defgeneric cursor-close (cursor)
(:documentation
"Close the cursor. Make sure to close cursors before the
@@ -352,14 +502,15 @@
"Put by cursor. Currently doesn't properly move the
cursor."))
-(defmethod make-cursor ((bt btree))
+(defmethod make-cursor ((bt bdb-btree))
"Make a cursor from a btree."
(declare (optimize (speed 3)))
- (make-instance 'cursor
+ (make-instance 'bdb-cursor
:btree bt
- :handle (db-cursor (controller-btrees *store-controller*))
+ :handle (db-cursor (controller-btrees (check-con (:dbcn-spc-pst bt))))
:oid (oid bt)))
+
(defmacro with-btree-cursor ((var bt) &body body)
"Macro which opens a named cursor on a BTree (primary or
not), evaluates the forms, then closes the cursor."
@@ -375,13 +526,17 @@
(multiple-value-bind (more k v) (cursor-next curs)
(unless more (return nil))
(funcall fn k v)))))
+(defun dump-btree (bt)
+ (format t "DUMP ~A~%" bt)
+ (map-btree #'(lambda (k v) (format t "k ~A / v ~A~%" k v)) bt)
+ )
-(defmethod cursor-close ((cursor cursor))
+(defmethod cursor-close ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(db-cursor-close (cursor-handle cursor))
(setf (cursor-initialized-p cursor) nil))
-(defmethod cursor-duplicate ((cursor cursor))
+(defmethod cursor-duplicate ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(make-instance (type-of cursor)
:initialized-p (cursor-initialized-p cursor)
@@ -390,7 +545,7 @@
(cursor-handle cursor)
:position (cursor-initialized-p cursor))))
-(defmethod cursor-current ((cursor cursor))
+(defmethod cursor-current ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(when (cursor-initialized-p cursor)
(with-buffer-streams (key-buf value-buf)
@@ -399,10 +554,13 @@
:current t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn (setf (cursor-initialized-p cursor) t)
- (values t (deserialize key) (deserialize val)))
+ (values t (deserialize key
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))
(setf (cursor-initialized-p cursor) nil))))))
-(defmethod cursor-first ((cursor cursor))
+(defmethod cursor-first ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (cursor-oid cursor) key-buf)
@@ -411,11 +569,14 @@
key-buf value-buf :set-range t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn (setf (cursor-initialized-p cursor) t)
- (values t (deserialize key) (deserialize val)))
+ (values t (deserialize key
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))
(setf (cursor-initialized-p cursor) nil)))))
;;A bit of a hack.....
-(defmethod cursor-last ((cursor cursor))
+(defmethod cursor-last ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (+ (cursor-oid cursor) 1) key-buf)
@@ -429,7 +590,10 @@
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn
(setf (cursor-initialized-p cursor) t)
- (values t (deserialize key) (deserialize val)))
+ (values t (deserialize key
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))
(setf (cursor-initialized-p cursor) nil))))
(multiple-value-bind (key val)
(db-cursor-move-buffered (cursor-handle cursor) key-buf
@@ -437,10 +601,13 @@
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn
(setf (cursor-initialized-p cursor) t)
- (values t (deserialize key) (deserialize val)))
+ (values t (deserialize key
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))
(setf (cursor-initialized-p cursor) nil))))))
-(defmethod cursor-next ((cursor cursor))
+(defmethod cursor-next ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf value-buf)
@@ -448,11 +615,12 @@
(db-cursor-move-buffered (cursor-handle cursor)
key-buf value-buf :next t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
- (values t (deserialize key) (deserialize val))
+ (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil))))
(cursor-first cursor)))
-(defmethod cursor-prev ((cursor cursor))
+(defmethod cursor-prev ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf value-buf)
@@ -460,11 +628,12 @@
(db-cursor-move-buffered (cursor-handle cursor)
key-buf value-buf :prev t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
- (values t (deserialize key) (deserialize val))
+ (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil))))
(cursor-last cursor)))
-(defmethod cursor-set ((cursor cursor) key)
+(defmethod cursor-set ((cursor bdb-cursor) key)
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (cursor-oid cursor) key-buf)
@@ -474,10 +643,10 @@
key-buf value-buf :set t)
(if k
(progn (setf (cursor-initialized-p cursor) t)
- (values t key (deserialize val)))
+ (values t key (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))
(setf (cursor-initialized-p cursor) nil)))))
-(defmethod cursor-set-range ((cursor cursor) key)
+(defmethod cursor-set-range ((cursor bdb-cursor) key)
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (cursor-oid cursor) key-buf)
@@ -487,10 +656,11 @@
key-buf value-buf :set-range t)
(if (and k (= (buffer-read-int k) (cursor-oid cursor)))
(progn (setf (cursor-initialized-p cursor) t)
- (values t (deserialize k) (deserialize val)))
+ (values t (deserialize k :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))
(setf (cursor-initialized-p cursor) nil)))))
-(defmethod cursor-get-both ((cursor cursor) key value)
+(defmethod cursor-get-both ((cursor bdb-cursor) key value)
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (cursor-oid cursor) key-buf)
@@ -505,7 +675,7 @@
(values t key value))
(setf (cursor-initialized-p cursor) nil)))))
-(defmethod cursor-get-both-range ((cursor cursor) key value)
+(defmethod cursor-get-both-range ((cursor bdb-cursor) key value)
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (cursor-oid cursor) key-buf)
@@ -516,10 +686,10 @@
key-buf value-buf :get-both-range t)
(if k
(progn (setf (cursor-initialized-p cursor) t)
- (values t key (deserialize v)))
+ (values t key (deserialize v :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))
(setf (cursor-initialized-p cursor) nil)))))
-(defmethod cursor-delete ((cursor cursor))
+(defmethod cursor-delete ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf value-buf)
@@ -530,11 +700,12 @@
(when (and key (= (buffer-read-int key) (cursor-oid cursor)))
;; in case of a secondary index this should delete everything
;; as specified by the BDB docs.
- (remove-kv (deserialize key) (cursor-btree cursor)))
+ (remove-kv (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (cursor-btree cursor)))
(setf (cursor-initialized-p cursor) nil)))
(error "Can't delete with uninitialized cursor!")))
-(defmethod cursor-put ((cursor cursor) value &key (key nil key-specified-p))
+(defmethod cursor-put ((cursor bdb-cursor) value &key (key nil key-specified-p))
"Put by cursor. Not particularly useful since primaries
don't support duplicates. Currently doesn't properly move
the cursor."
@@ -548,7 +719,9 @@
value-buf :current t)
(declare (ignore v))
(if (and k (= (buffer-read-int k) (cursor-oid cursor)))
- (setf (get-value (deserialize k) (cursor-btree cursor))
+ (setf (get-value
+ (deserialize k :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (cursor-btree cursor))
value)
(setf (cursor-initialized-p cursor) nil))))
(error "Can't put with uninitialized cursor!"))))
@@ -558,6 +731,9 @@
(defclass secondary-cursor (cursor) ()
(:documentation "Cursor for traversing secondary indices."))
+(defclass bdb-secondary-cursor (bdb-cursor) ()
+ (:documentation "Cursor for traversing bdb secondary indices."))
+
(defgeneric cursor-pcurrent (cursor)
(:documentation
"Returns has-tuple / secondary key / value / primary key
@@ -639,16 +815,18 @@
different key.) Returns has-tuple / secondary key / value /
primary key."))
-(defmethod make-cursor ((bt btree-index))
+
+(defmethod make-cursor ((bt bdb-btree-index))
"Make a secondary-cursor from a secondary index."
(declare (optimize (speed 3)))
- (make-instance 'secondary-cursor
+ (make-instance 'bdb-secondary-cursor
:btree bt
:handle (db-cursor
- (controller-indices-assoc *store-controller*))
+ (controller-indices-assoc (check-con (:dbcn-spc-pst bt))))
:oid (oid bt)))
-(defmethod cursor-pcurrent ((cursor secondary-cursor))
+
+(defmethod cursor-pcurrent ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(when (cursor-initialized-p cursor)
(with-buffer-streams (key-buf pkey-buf value-buf)
@@ -658,11 +836,17 @@
:current t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn (setf (cursor-initialized-p cursor) t)
- (values t (deserialize key) (deserialize val)
+ (values t
+ (deserialize
+ key
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize
+ val
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
(progn (buffer-read-int pkey) (deserialize pkey))))
(setf (cursor-initialized-p cursor) nil))))))
-(defmethod cursor-pfirst ((cursor secondary-cursor))
+(defmethod cursor-pfirst ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf pkey-buf value-buf)
(buffer-write-int (cursor-oid cursor) key-buf)
@@ -671,12 +855,14 @@
key-buf pkey-buf value-buf :set-range t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn (setf (cursor-initialized-p cursor) t)
- (values t (deserialize key) (deserialize val)
+ (values t
+(deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+(deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
(progn (buffer-read-int pkey) (deserialize pkey))))
(setf (cursor-initialized-p cursor) nil)))))
;;A bit of a hack.....
-(defmethod cursor-plast ((cursor secondary-cursor))
+(defmethod cursor-plast ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf pkey-buf value-buf)
(buffer-write-int (+ (cursor-oid cursor) 1) key-buf)
@@ -690,9 +876,11 @@
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn
(setf (cursor-initialized-p cursor) t)
- (values t (deserialize key) (deserialize val)
+ (values t
+ (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
(progn (buffer-read-int pkey)
- (deserialize pkey))))
+ (deserialize pkey :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))))
(setf (cursor-initialized-p cursor) nil))))
(multiple-value-bind (key pkey val)
(db-cursor-pmove-buffered (cursor-handle cursor) key-buf
@@ -700,11 +888,12 @@
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn
(setf (cursor-initialized-p cursor) t)
- (values t (deserialize key) (deserialize val)
+ (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
(progn (buffer-read-int pkey) (deserialize pkey))))
(setf (cursor-initialized-p cursor) nil))))))
-(defmethod cursor-pnext ((cursor secondary-cursor))
+(defmethod cursor-pnext ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf pkey-buf value-buf)
@@ -712,12 +901,15 @@
(db-cursor-pmove-buffered (cursor-handle cursor)
key-buf pkey-buf value-buf :next t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
- (values t (deserialize key) (deserialize val)
+ (values t (deserialize key
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
(progn (buffer-read-int pkey) (deserialize pkey)))
(setf (cursor-initialized-p cursor) nil))))
(cursor-pfirst cursor)))
-(defmethod cursor-pprev ((cursor secondary-cursor))
+(defmethod cursor-pprev ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf pkey-buf value-buf)
@@ -725,12 +917,15 @@
(db-cursor-pmove-buffered (cursor-handle cursor)
key-buf pkey-buf value-buf :prev t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
- (values t (deserialize key) (deserialize val)
+ (values t (deserialize key
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val
+ :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
(progn (buffer-read-int pkey) (deserialize pkey)))
(setf (cursor-initialized-p cursor) nil))))
(cursor-plast cursor)))
-(defmethod cursor-pset ((cursor secondary-cursor) key)
+(defmethod cursor-pset ((cursor bdb-secondary-cursor) key)
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf pkey-buf value-buf)
(buffer-write-int (cursor-oid cursor) key-buf)
@@ -740,11 +935,11 @@
key-buf pkey-buf value-buf :set t)
(if k
(progn (setf (cursor-initialized-p cursor) t)
- (values t key (deserialize val)
- (progn (buffer-read-int pkey) (deserialize pkey))))
+ (values t key (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (progn (buffer-read-int pkey) (deserialize pkey :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))))
(setf (cursor-initialized-p cursor) nil)))))
-(defmethod cursor-pset-range ((cursor secondary-cursor) key)
+(defmethod cursor-pset-range ((cursor bdb-secondary-cursor) key)
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf pkey-buf value-buf)
(buffer-write-int (cursor-oid cursor) key-buf)
@@ -754,11 +949,12 @@
key-buf pkey-buf value-buf :set-range t)
(if (and k (= (buffer-read-int k) (cursor-oid cursor)))
(progn (setf (cursor-initialized-p cursor) t)
- (values t (deserialize k) (deserialize val)
- (progn (buffer-read-int pkey) (deserialize pkey))))
+ (values t (deserialize k :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (progn (buffer-read-int pkey) (deserialize pkey :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))))
(setf (cursor-initialized-p cursor) nil)))))
-(defmethod cursor-pget-both ((cursor secondary-cursor) key pkey)
+(defmethod cursor-pget-both ((cursor bdb-secondary-cursor) key pkey)
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf pkey-buf value-buf)
(let ((primary-oid (oid (primary (cursor-btree cursor)))))
@@ -772,10 +968,10 @@
(declare (ignore p))
(if k
(progn (setf (cursor-initialized-p cursor) t)
- (values t key (deserialize val) pkey))
+ (values t key (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) pkey))
(setf (cursor-initialized-p cursor) nil))))))
-(defmethod cursor-pget-both-range ((cursor secondary-cursor) key pkey)
+(defmethod cursor-pget-both-range ((cursor bdb-secondary-cursor) key pkey)
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf pkey-buf value-buf)
(let ((primary-oid (oid (primary (cursor-btree cursor)))))
@@ -788,11 +984,11 @@
pkey-buf value-buf :get-both-range t)
(if k
(progn (setf (cursor-initialized-p cursor) t)
- (values t key (deserialize val)
- (progn (buffer-read-int p) (deserialize p))))
+ (values t key (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (progn (buffer-read-int p) (deserialize p :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))))
(setf (cursor-initialized-p cursor) nil))))))
-(defmethod cursor-delete ((cursor secondary-cursor))
+(defmethod cursor-delete ((cursor bdb-secondary-cursor))
"Delete by cursor: deletes ALL secondary indices."
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
@@ -804,30 +1000,31 @@
(when (and key (= (buffer-read-int key) (cursor-oid cursor))
(= (buffer-read-int pkey) (oid (primary
(cursor-btree cursor)))))
- (remove-kv (deserialize pkey) (primary (cursor-btree cursor))))
+ (remove-kv (deserialize pkey :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (primary (cursor-btree cursor))))
(setf (cursor-initialized-p cursor) nil)))
(error "Can't delete with uninitialized cursor!")))
-(defmethod cursor-get-both ((cursor secondary-cursor) key value)
+(defmethod cursor-get-both ((cursor bdb-secondary-cursor) key value)
"cursor-get-both not implemented for secondary indices.
Use cursor-pget-both."
(declare (ignore cursor key value))
(error "cursor-get-both not implemented on secondary
indices. Use cursor-pget-both."))
-(defmethod cursor-get-both-range ((cursor secondary-cursor) key value)
+(defmethod cursor-get-both-range ((cursor bdb-secondary-cursor) key value)
"cursor-get-both-range not implemented for secondary indices.
Use cursor-pget-both-range."
(declare (ignore cursor key value))
(error "cursor-get-both-range not implemented on secondary indices. Use cursor-pget-both-range."))
-(defmethod cursor-put ((cursor secondary-cursor) value &rest rest)
+(defmethod cursor-put ((cursor bdb-secondary-cursor) value &rest rest)
"Puts are forbidden on secondary indices. Try adding to
the primary."
(declare (ignore rest value cursor))
(error "Puts are forbidden on secondary indices. Try adding to the primary."))
-(defmethod cursor-next-dup ((cursor secondary-cursor))
+(defmethod cursor-next-dup ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(when (cursor-initialized-p cursor)
(with-buffer-streams (key-buf value-buf)
@@ -835,10 +1032,11 @@
(db-cursor-move-buffered (cursor-handle cursor)
key-buf value-buf :next-dup t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
- (values t (deserialize key) (deserialize val))
+ (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil))))))
-(defmethod cursor-next-nodup ((cursor secondary-cursor))
+(defmethod cursor-next-nodup ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf value-buf)
@@ -846,11 +1044,12 @@
(db-cursor-move-buffered (cursor-handle cursor)
key-buf value-buf :next-nodup t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
- (values t (deserialize key) (deserialize val))
+ (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil))))
(cursor-first cursor)))
-(defmethod cursor-prev-nodup ((cursor secondary-cursor))
+(defmethod cursor-prev-nodup ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf value-buf)
@@ -858,11 +1057,12 @@
(db-cursor-move-buffered (cursor-handle cursor)
key-buf value-buf :prev-nodup t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
- (values t (deserialize key) (deserialize val))
+ (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil))))
(cursor-last cursor)))
-(defmethod cursor-pnext-dup ((cursor secondary-cursor))
+(defmethod cursor-pnext-dup ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(when (cursor-initialized-p cursor)
(with-buffer-streams (key-buf pkey-buf value-buf)
@@ -870,11 +1070,12 @@
(db-cursor-pmove-buffered (cursor-handle cursor)
key-buf pkey-buf value-buf :next-dup t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
- (values t (deserialize key) (deserialize val)
+ (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
(progn (buffer-read-int pkey) (deserialize pkey)))
(setf (cursor-initialized-p cursor) nil))))))
-(defmethod cursor-pnext-nodup ((cursor secondary-cursor))
+(defmethod cursor-pnext-nodup ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf pkey-buf value-buf)
@@ -882,12 +1083,13 @@
(db-cursor-pmove-buffered (cursor-handle cursor) key-buf
pkey-buf value-buf :next-nodup t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
- (values t (deserialize key) (deserialize val)
- (progn (buffer-read-int pkey) (deserialize pkey)))
+ (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (progn (buffer-read-int pkey) (deserialize pkey :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))
(setf (cursor-initialized-p cursor) nil))))
(cursor-pfirst cursor)))
-(defmethod cursor-pprev-nodup ((cursor secondary-cursor))
+(defmethod cursor-pprev-nodup ((cursor bdb-secondary-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf pkey-buf value-buf)
@@ -895,8 +1097,10 @@
(db-cursor-pmove-buffered (cursor-handle cursor) key-buf
pkey-buf value-buf :prev-nodup t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
- (values t (deserialize key) (deserialize val)
- (progn (buffer-read-int pkey) (deserialize pkey)))
+ (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))
+ (progn (buffer-read-int pkey)
+ (deserialize pkey :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))
(setf (cursor-initialized-p cursor) nil))))
(cursor-plast cursor)))
Index: elephant/src/controller.lisp
diff -u elephant/src/controller.lisp:1.12 elephant/src/controller.lisp:1.12.2.1
--- elephant/src/controller.lisp:1.12 Thu Feb 24 02:06:10 2005
+++ elephant/src/controller.lisp Tue Oct 18 22:41:27 2005
@@ -42,20 +42,47 @@
(in-package "ELEPHANT")
+
+;; This list contains functions that take one arugment,
+;; the "spec", and will construct an appropriate store
+;; controller from it.
+(defvar *strategies* '())
+
+(defvar *elephant-lib-path* "/usr/local/share/common-lisp/elephant-0.2/")
+
+(defun register-strategy (spec-to-controller)
+ (setq *strategies* (delete spec-to-controller *strategies*))
+ (setq *strategies* (cons spec-to-controller *strategies*))
+ )
+
+(defun get-controller (spec)
+ (let ((store-controllers nil))
+ (dolist (s *strategies*)
+ (let ((sc (funcall s spec)))
+ (if sc
+ (push sc store-controllers))))
+ (if (not (= (length store-controllers) 1))
+ (error "Strategy resolution for this spec completely failed!")
+ (car store-controllers))
+ ))
+
+
(defclass store-controller ()
+ ;; purely abstract class doesn't need a slot, though it
+ ;; should take the common ones.
((path :type (or pathname string)
:accessor controller-path
:initarg :path)
+ (root :reader controller-root)
+ (db :type (or null pointer-void) :accessor controller-db :initform '())
(environment :type (or null pointer-void)
:accessor controller-environment)
- (db :type (or null pointer-void) :accessor controller-db)
(oid-db :type (or null pointer-void) :accessor controller-oid-db)
(oid-seq :type (or null pointer-void) :accessor controller-oid-seq)
(btrees :type (or null pointer-void) :accessor controller-btrees)
(indices :type (or null pointer-void) :accessor controller-indices)
(indices-assoc :type (or null pointer-void)
:accessor controller-indices-assoc)
- (root :reader controller-root)
(instance-cache :accessor instance-cache
:initform (make-cache-table :test 'eql)))
(:documentation "Class of objects responsible for the
@@ -63,6 +90,35 @@
creation, counters, locks, the root (for garbage collection,)
et cetera."))
+(defclass bdb-store-controller (store-controller)
+ (
+ )
+ (:documentation "Class of objects responsible for the
+book-keeping of holding DB handles, the cache, table
+creation, counters, locks, the root (for garbage collection,)
+et cetera."))
+
+;; Without somemore sophistication, these functions
+;; need to be defined here, so that they will be available for testing
+;; even if you do not use the strategy in question...
+(defun bdb-store-spec-p (path)
+ (stringp path))
+
+(defun sql-store-spec-p (path)
+ (listp path))
+
+
+;; This has now way of passing in optionals?
+(defun bdb-test-and-construct (spec)
+ (if (bdb-store-spec-p spec)
+ (open-store-bdb spec)
+ nil)
+ )
+
+(eval-when ( :load-toplevel)
+ (register-strategy 'bdb-test-and-construct)
+ )
+
(defgeneric open-controller (sc &key recover recover-fatal thread)
(:documentation
"Opens the underlying environment and all the necessary
@@ -73,6 +129,118 @@
"Close the db handles and environment. Tries to wipe out
references to the db handles."))
+(defgeneric build-btree (sc)
+ (:documentation
+ "Construct a btree of the appropriate type corresponding to this store-controller."))
+
+(defgeneric build-indexed-btree (sc)
+ (:documentation
+ "Construct a btree of the appropriate type corresponding to this store-controller."))
+
+(defgeneric get-transaction-macro-symbol (sc)
+ (:documentation
+ "Return the strategy-specific macro symbol that will let you do a transaction within that macro."))
+
+
+(defun make-indexed-btree (&optional (sc *store-controller*))
+ (build-indexed-btree sc)
+ )
+
+
+(defgeneric build-btree-index (sc &key primary key-form)
+ (:documentation
+ "Construct a btree of the appropriate type corresponding to this store-controller."))
+
+(defgeneric copy-from-key (key src dst)
+ (:documentation
+ "Move the object identified by key on the root in the src to the dst."))
+
+(defmethod copy-from-key (key src dst)
+ (let ((v (get-from-root key :store-controller src)))
+ (if v
+ (add-to-root key v :store-controller dst)
+ v))
+ )
+
+(defun copy-btree-contents (src dst)
+ (map-btree
+ #'(lambda (k v)
+ (setf (get-value k dst) v)
+ )
+ src)
+ )
+
+;; I don't know if I need a "deeper" copy here or not....
+(defun my-copy-hash-table (ht)
+ (let ((nht (make-hash-table)))
+ (maphash
+ #'(lambda (k v)
+ (setf (gethash k nht) v))
+ ht)
+ nht)
+ )
+
+(defun add-index-from-index (iname v dstibt dstsc)
+ (declare (type btree-index v)
+ (type indexed-btree dstibt))
+ (let ((kf (key-form v)))
+ (format t " kf ~A ~%" kf)
+ (let ((index
+ (build-btree-index dstsc :primary dstibt
+ :key-form kf)))
+ ;; Why do I have to do this here?
+ (setf (indices dstibt) (make-hash-table))
+ (setf (indices-cache dstibt) (make-hash-table))
+ (setf (gethash iname (indices-cache dstibt)) index)
+ (setf (gethash iname (indices dstibt)) index)
+ )
+ )
+ )
+
+(defun my-copy-indices (ht dst dstsc)
+ (maphash
+ #'(lambda (k v)
+ (add-index-from-index k v dst dstsc))
+ ht)
+ )
+
+(defmethod migrate ((dst store-controller) obj)
+ "Copy a currently persistent object to a new repository."
+ (if (typep obj 'btree)
+ ;; For a btree, we need to copy the object with the indices intact,
+ ;; then just read it out...
+ (if (typep obj 'indexed-btree)
+ ;; We have to copy the indexes..
+ (let ((nobj (build-indexed-btree dst)))
+ (my-copy-indices (indices obj) nobj dst)
+ (copy-btree-contents obj nobj)
+ nobj
+ )
+ (let ((nobj (build-btree dst)))
+ (copy-btree-contents obj nobj)
+ nobj)
+ )
+ (error (format nil "the migrate function cannot migrate objects like ~A~%" obj)
+ )))
+
+;; ;; This routine attempst to do a destructive migration
+;; ;; of the object to the new repository
+(defmethod migraten-pobj ((dst store-controller) obj copy-fn)
+ "Migrate a persistent object and apply a binary (lambda (dst src) ...) function to the new object."
+ ;; The simplest thing to do here is to make
+ ;; an object of the new class;
+ ;; we will make it the responsibility of the caller to
+ ;; perform the copy on the slots --- or
+ ;; we can force them to pass in this function.
+ (if (typep obj 'persistent)
+ (let ((nobj (make-instance (type-of obj) :sc dst)))
+ (apply copy-fn (list nobj obj))
+ nobj)
+ (error (format "obj ~A is not a persistent object!~%" obj))
+ )
+ )
+
+
(defun add-to-root (key value &key (store-controller *store-controller*))
"Add an arbitrary persistent thing to the root, so you can
retrieve it in a later session. N.B. this means it (and
@@ -85,6 +253,13 @@
(declare (type store-controller store-controller))
(get-value key (controller-root store-controller)))
+(defun from-root-existsp (key &key (store-controller *store-controller*))
+ "Get a something from the root."
+ (declare (type store-controller store-controller))
+ (if (existsp key (controller-root store-controller))
+ t
+ nil))
+
(defun remove-from-root (key &key (store-controller *store-controller*))
"Remove something from the root."
(declare (type store-controller store-controller))
@@ -104,14 +279,14 @@
;; Should get cached since make-instance calls cache-instance
(make-instance class-name :from-oid oid))))
-(defun next-oid (sc)
+(defmethod next-oid ((sc bdb-store-controller))
"Get the next OID."
- (declare (type store-controller sc))
+ (declare (type bdb-store-controller sc))
(db-sequence-get-fixnum (controller-oid-seq sc) 1 :transaction +NULL-VOID+
:auto-commit t :txn-nosync t))
;; Open/close
-(defmethod open-controller ((sc store-controller) &key (recover nil)
+(defmethod open-controller ((sc bdb-store-controller) &key (recover nil)
(recover-fatal nil) (thread t))
(let ((env (db-env-create)))
;; thread stuff?
@@ -124,6 +299,7 @@
(indices (db-create env))
(indices-assoc (db-create env)))
(setf (controller-db sc) db)
+ (setf (gethash (controller-path sc) *dbconnection-spec*) sc)
(db-open db :file "%ELEPHANT" :database "%ELEPHANTDB"
:auto-commit t :type DB-BTREE :create t :thread thread)
@@ -160,11 +336,11 @@
:auto-commit t :create t :thread t)
(setf (controller-oid-seq sc) oid-seq)))
- (let ((root (make-instance 'btree :from-oid -1)))
+ (let ((root (make-instance 'bdb-btree :from-oid -1 :sc sc)))
(setf (slot-value sc 'root) root))
sc)))
-(defmethod close-controller ((sc store-controller))
+(defmethod close-controller ((sc bdb-store-controller))
(when (slot-value sc 'root)
;; no root
(setf (slot-value sc 'root) nil)
@@ -187,6 +363,49 @@
(setf (controller-environment sc) nil)
nil))
+;; Do these things need to take &rest arguments?
+(defmethod build-btree ((sc bdb-store-controller))
+ (make-bdb-btree sc)
+ )
+
+
+(defun make-btree (&optional (sc *store-controller*))
+ (build-btree sc)
+ )
+
+(defmethod get-transaction-macro-symbol ((sc bdb-store-controller))
+ 'with-transaction
+ )
+
+(defun open-store (spec &key (recover nil)
+ (recover-fatal nil) (thread t))
+ "Conveniently open a store controller."
+ (setq *store-controller*
+ (get-controller spec))
+ (open-controller *store-controller* :recover recover
+ :recover-fatal recover-fatal :thread thread))
+
+(defun open-store-bdb (spec &key (recover nil)
+ (recover-fatal nil) (thread t))
+ "Conveniently open a store controller."
+ (setq *store-controller*
+ (if (bdb-store-spec-p spec)
+ (make-instance 'bdb-store-controller :path spec)
+ (error (format nil "uninterpretable path/spec specifier: ~A" spec))))
+ (open-controller *store-controller* :recover recover
+ :recover-fatal recover-fatal :thread thread))
+
+
+(defmacro with-open-store-bdb ((path) &body body)
+ "Executes the body with an open controller,
+ unconditionally closing the controller on exit."
+ `(let ((*store-controller* (make-instance 'bdb-store-controller :path ,path)))
+ (declare (special *store-controller*))
+ (open-controller *store-controller*)
+ (unwind-protect
+ (progn , at body)
+ (close-controller *store-controller*))))
+
(defmacro with-open-controller ((&optional (sc '*store-controller*))
&body body)
"Executes body with the specified controller open, closing
@@ -198,34 +417,37 @@
, at body))
(close-controller ,sc)))
-(defun open-store (path &key (recover nil)
- (recover-fatal nil) (thread t))
- "Conveniently open a store controller."
- (setq *store-controller* (make-instance 'store-controller :path path))
- (open-controller *store-controller* :recover recover
- :recover-fatal recover-fatal :thread thread))
-
(defun close-store ()
"Conveniently close the store controller."
- (close-controller *store-controller*))
+ (if *store-controller*
+ (close-controller *store-controller*)))
-(defmacro with-open-store ((path) &body body)
+(defmacro with-open-store ((spec) &body body)
"Executes the body with an open controller,
unconditionally closing the controller on exit."
- `(let ((*store-controller* (make-instance 'store-controller :path ,path)))
- (declare (special *store-controller*))
- (open-controller *store-controller*)
- (unwind-protect
- (progn , at body)
- (close-controller *store-controller*))))
+ `(let ((*store-controller*
+ (get-controller ,spec)))
+ (declare (special *store-controller*))
+;; (open-controller *store-controller*)
+ (unwind-protect
+ (progn , at body)
+ (close-controller *store-controller*))))
+
;;; Make these respect the transaction keywords (e.g. degree-2)
-(defun start-transaction (&key (parent *current-transaction*))
- "Start a transaction. May be nested but not interleaved."
- (vector-push-extend *current-transaction* *transaction-stack*)
- (setq *current-transaction*
- (db-transaction-begin (controller-environment *store-controller*)
- :parent parent)))
+;; (defun start-transaction (&key (parent *current-transaction*))
+;; "Start a transaction. May be nested but not interleaved."
+;; (vector-push-extend *current-transaction* *transaction-stack*)
+;; (setq *current-transaction*
+;; (db-transaction-begin (controller-environment *store-controller*)
+;; :parent parent)))
+
+(defun start-ele-transaction (&key (parent *current-transaction*) (store-controller *store-controller*))
+ "Start a transaction. May be nested but not interleaved."
+ (vector-push-extend *current-transaction* *transaction-stack*)
+ (setq *current-transaction*
+ (db-transaction-begin (controller-environment store-controller)
+ :parent parent)))
(defun commit-transaction ()
"Commit the current transaction."
@@ -236,3 +458,12 @@
"Abort the current transaction."
(db-transaction-abort)
(setq *current-transaction* (vector-pop *transaction-stack*)))
+
+(defgeneric persistent-slot-reader-aux (sc instance name)
+ (:documentation
+ "Auxilliary method to allow implementation-specific slot reading"))
+
+(defgeneric persistent-slot-writer-aux (sc new-value instance name)
+ (:documentation
+ "Auxilliary method to allow implementation-specific slot writing"))
+
Index: elephant/src/elephant.lisp
diff -u elephant/src/elephant.lisp:1.14 elephant/src/elephant.lisp:1.14.2.1
--- elephant/src/elephant.lisp:1.14 Thu Feb 24 02:07:52 2005
+++ elephant/src/elephant.lisp Tue Oct 18 22:41:27 2005
@@ -49,20 +49,49 @@
(:use common-lisp sleepycat uffi)
(:shadow #:with-transaction)
(:export #:*store-controller* #:*current-transaction* #:*auto-commit*
+ #:bdb-store-controller
+ #:sql-store-controller
+ #:make-bdb-btree
+ #:make-sql-btree
+ #:bdb-indexed-btree
+ #:sql-indexed-btree
+ #:from-root-existsp
#: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 #:remove-from-root
#:start-transaction #:commit-transaction #:abort-transaction
+ #:start-ele-transaction #:commit-transaction #:abort-transaction
+ #:build-btree
+ #:make-btree
+ #:make-indexed-btree
+ #:copy-from-key
+ #:open-store-bdb
+ #:open-store-sql
+ #:btree-differ
+ #:migrate
+ #:persistent-slot-boundp-sql
+ #:persistent-slot-reader-sql
+ #:persistent-slot-writer-sql
+ #:*elephant-lib-path*
+
#:persistent #:persistent-object #:persistent-metaclass
- #:persistent-collection #:btree #:get-value #:remove-kv
+ #:persistent-collection #:btree
+ #:bdb-btree #:sql-btree
+ #:get-value #:remove-kv
+
#:indexed-btree #:add-index #:get-index #:remove-index
#:btree-index #:get-primary-key
#:indices #:primary #:key-form #:key-fn
+ #:build-indexed-btree
+ #:make-indexed-btree
+
+ #:bdb-cursor #:sql-cursor
+ #:cursor-init
#:cursor #:secondary-cursor #:make-cursor
#:with-btree-cursor #:map-btree #:cursor-close
#:cursor-duplicate #:cursor-current #:cursor-first
@@ -249,4 +278,4 @@
#+cmu
(eval-when (:compile-toplevel)
- (proclaim '(optimize (ext:inhibit-warnings 3))))
\ No newline at end of file
+ (proclaim '(optimize (ext:inhibit-warnings 3))))
Index: elephant/src/libsleepycat.c
diff -u elephant/src/libsleepycat.c:1.11 elephant/src/libsleepycat.c:1.11.2.1
--- elephant/src/libsleepycat.c:1.11 Thu Feb 24 02:04:13 2005
+++ elephant/src/libsleepycat.c Tue Oct 18 22:41:27 2005
@@ -58,6 +58,11 @@
#include <string.h>
#include <wchar.h>
+/* Some utility stuff used to be here but has been placed in
+ libmemutil.c */
+
+/* Pointer arithmetic utility functions */
+/* should these be in network-byte order? probably not..... */
/* Pointer arithmetic utility functions */
/* should these be in network-byte order? probably not..... */
int read_int(char *buf, int offset) {
Index: elephant/src/metaclasses.lisp
diff -u elephant/src/metaclasses.lisp:1.7 elephant/src/metaclasses.lisp:1.7.2.1
--- elephant/src/metaclasses.lisp:1.7 Thu Feb 24 02:07:52 2005
+++ elephant/src/metaclasses.lisp Tue Oct 18 22:41:27 2005
@@ -42,8 +42,43 @@
(in-package "ELEPHANT")
+(defvar *dbconnection-spec*
+ (make-hash-table :test 'equal))
+
+(defun connection-is-indeed-open (con)
+ t ;; I don't yet know how to implement this
+ )
+
+;; This needs to be a store-controller method...
+(defun check-con (spec &optional sc )
+ (let ((con (gethash spec *dbconnection-spec*)))
+ (if (and con (connection-is-indeed-open con))
+ con
+ (if (not (typep sc 'bdb-store-controller))
+ (progn
+ (error "We can't default to *store-controller* in a multi-use enviroment."))
+ ;; (setf (gethash spec *dbconnection-spec*)
+ ;; (clsql:connect (:dbcn-spc sc)
+ ;; :database-type :postgresql-socket
+ ;; :if-exists :old)))
+ (error "We don't know how to open a bdb-connection here!")
+ ;; if they don't give us connection-spec, we can't reopen things...
+ ))))
+
+
+
(defclass persistent ()
- ((%oid :accessor oid :initarg :from-oid))
+ ((%oid :accessor oid :initarg :from-oid)
+ ;; This is just an idea for storing connections in the persistent
+ ;; objects; these should be transient as well, if that flag exists!
+ ;; In the case of sleepy cat, this is the controller-db from
+ ;; the store-controller. In the case of SQL this is
+ ;; the connection spec (since the connection might be broken?)
+ ;; It probably would be better to put a string in here in the case
+ ;; of sleepycat...
+ (dbonnection-spec-pst :type list :accessor :dbcn-spc-pst :initarg :dbconnection-spec-pst
+ :initform '())
+ )
(:documentation
"Abstract superclass for all persistent classes (common
to user-defined classes and collections.)"))
@@ -65,7 +100,12 @@
(cdr (%persistent-slots class)))
(defmethod update-persistent-slots ((class persistent-metaclass) new-slot-list)
- (setf (%persistent-slots class) (cons new-slot-list (car (%persistent-slots class)))))
+;; (setf (%persistent-slots class) (cons new-slot-list (car (%persistent-slots class)))))
+ (setf (%persistent-slots class) (cons new-slot-list
+ (if (slot-boundp class '%persistent-slots)
+ (car (%persistent-slots class))
+ nil)
+ )))
(defclass persistent-slot-definition (standard-slot-definition)
())
@@ -155,8 +195,8 @@
(defmethod compute-effective-slot-definition-initargs ((class slots-class)
direct-slots)
(let* ((name (loop for s in direct-slots
- when s
- do (return (slot-definition-name s))))
+ when s
+ do (return (slot-definition-name s))))
(initer (dolist (s direct-slots)
(when (%slot-definition-initfunction s)
(return s))))
@@ -184,7 +224,7 @@
(defun ensure-transient-chain (slot-definitions initargs)
(declare (ignore initargs))
(loop for slot-definition in slot-definitions
- always (transient slot-definition)))
+ always (transient slot-definition)))
(defmethod compute-effective-slot-definition-initargs ((class persistent-metaclass) slot-definitions)
(let ((initargs (call-next-method)))
@@ -194,19 +234,22 @@
(setf (getf initargs :allocation) :database)
initargs))))
+
(defmacro persistent-slot-reader (instance name)
- `(progn
- (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))))))
+`(if (not (bdb-store-spec-p (:dbcn-spc-pst ,instance)))
+ (persistent-slot-reader-aux (check-con (:dbcn-spc-pst ,instance)) ,instance ,name)
+ (progn
+ (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 (check-con (:dbcn-spc-pst ,instance)))
+ key-buf value-buf)))
+ (if buf (deserialize buf :sc (check-con (:dbcn-spc-pst instance)))
+ #+cmu
+ (error 'unbound-slot :instance ,instance :slot ,name)
+ #-cmu
+ (error 'unbound-slot :instance ,instance :name ,name)))))))
#+(or cmu sbcl)
(defun make-persistent-reader (name)
@@ -216,16 +259,18 @@
(persistent-slot-reader instance name)))
(defmacro persistent-slot-writer (new-value instance name)
- `(progn
- (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*)
- key-buf value-buf
- :transaction *current-transaction*
- :auto-commit *auto-commit*)
- ,new-value)))
+ `(if (not (bdb-store-spec-p (:dbcn-spc-pst ,instance)))
+ (persistent-slot-writer-aux (check-con (:dbcn-spc-pst ,instance)) ,new-value ,instance ,name)
+ (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 (check-con (:dbcn-spc-pst ,instance)))
+ key-buf value-buf
+ :transaction *current-transaction*
+ :auto-commit *auto-commit*)
+ ,new-value)))
#+(or cmu sbcl)
(defun make-persistent-writer (name)
@@ -234,15 +279,22 @@
(type persistent-object instance))
(persistent-slot-writer new-value instance name)))
+;; This this is not a good way to form a key...
+(defun form-slot-key (oid name)
+ (format nil "~A ~A" oid name)
+ )
+
(defmacro persistent-slot-boundp (instance name)
- `(progn
- (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)))))
+ `(if (not (bdb-store-spec-p (:dbcn-spc-pst ,instance)))
+ (persistent-slot-boundp-aux (check-con (:dbcn-spc-pst ,instance)) ,instance ,name)
+ (progn
+ (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 (check-con (:dbcn-spc-pst ,instance)))
+ key-buf value-buf)))
+ (if buf T nil))))))
#+(or cmu sbcl)
(defun make-persistent-slot-boundp (name)
@@ -265,11 +317,11 @@
(defun persistent-slot-names (class)
(let ((slot-definitions (class-slots class)))
(loop for slot-definition in slot-definitions
- when (equalp (class-of slot-definition) (find-class 'persistent-effective-slot-definition))
- collect (slot-definition-name slot-definition))))
+ when (equalp (class-of slot-definition) (find-class 'persistent-effective-slot-definition))
+ collect (slot-definition-name slot-definition))))
(defun transient-slot-names (class)
(let ((slot-definitions (class-slots class)))
(loop for slot-definition in slot-definitions
- unless (persistent-p slot-definition)
- collect (slot-definition-name slot-definition))))
\ No newline at end of file
+ unless (persistent-p slot-definition)
+ collect (slot-definition-name slot-definition))))
Index: elephant/src/serializer.lisp
diff -u elephant/src/serializer.lisp:1.10 elephant/src/serializer.lisp:1.10.2.1
--- elephant/src/serializer.lisp:1.10 Thu Feb 24 02:06:10 2005
+++ elephant/src/serializer.lisp Tue Oct 18 22:41:27 2005
@@ -261,7 +261,7 @@
(push slot-name ret))
finally (return ret)))
-(defun deserialize (buf-str)
+(defun deserialize (buf-str &key sc)
"Deserialize a lisp value from a buffer-stream."
(declare (optimize (speed 3) (safety 0))
(type (or null buffer-stream) buf-str))
@@ -306,7 +306,8 @@
((= tag +ucs4-string+)
(buffer-read-ucs4-string bs (buffer-read-fixnum bs)))
((= tag +persistent+)
- (get-cached-instance *store-controller*
+;; (get-cached-instance *store-controller*
+ (get-cached-instance sc
(buffer-read-fixnum bs)
(%deserialize bs)))
((= tag +single-float+)
@@ -361,13 +362,21 @@
(let* ((id (buffer-read-fixnum bs))
(maybe-o (gethash id *circularity-hash*)))
(if maybe-o maybe-o
- (let ((o (make-instance (%deserialize bs))))
+ (let ((typedesig (%deserialize bs)))
+ ;; now, depending on what typedesig is, we might
+ ;; or might not need to specify the store controller here..
+ (let ((o
+ (if (subtypep typedesig 'persistent)
+ (make-instance typedesig :sc sc)
+ (make-instance typedesig)
+ )
+ ))
(setf (gethash id *circularity-hash*) o)
(loop for i fixnum from 0 below (%deserialize bs)
do
(setf (slot-value o (%deserialize bs))
(%deserialize bs)))
- o))))
+ o)))))
((= tag +array+)
(let* ((id (buffer-read-fixnum bs))
(maybe-array (gethash id *circularity-hash*)))
@@ -464,3 +473,73 @@
#-(or cmu sbcl allegro)
(byte 32 (* 32 position))
)
+
+
+(eval-when (:compile-toplevel :load-toplevel)
+ (asdf:operate 'asdf:load-op :cl-base64)
+)
+(defun ser-deser-equal (x1 &keys sc)
+ (let* (
+ (x1s (serialize-to-base64-string x1))
+ (x1prime (deserialize-from-base64-string x1s :sc sc)))
+ (assert (equal x1 x1prime))
+ (equal x1 x1prime)))
+
+
+(defun serialize-to-base64-string (x)
+ (with-buffer-streams (out-buf)
+ (cl-base64::usb8-array-to-base64-string
+ (sleepycat::buffer-read-byte-vector
+ (serialize x out-buf))))
+ )
+
+
+(defun deserialize-from-base64-string (x &keys sc)
+ (with-buffer-streams (other)
+ (deserialize
+ (sleepycat::buffer-write-byte-vector
+ other
+ (cl-base64::base64-string-to-usb8-array x))
+ :sc sc
+ )
+ ))
+
+;; (defclass blob ()
+;; ((slot1 :accessor slot1 :initarg :slot1)
+;; (slot2 :accessor slot2 :initarg :slot2)))
+
+;; (defvar keys (loop for i from 1 to 1000
+;; collect (concatenate 'string "key-" (prin1-to-string i))))
+
+;; (defvar objs (loop for i from 1 to 1000
+;; collect (make-instance 'blob
+;; :slot1 i
+;; :slot2 (* i 100))))
+;; (defmethod blob-equal ((a blob) (b blob))
+;; (and (equal (slot1 a) (slot1 b))
+;; (equal (slot2 a) (slot2 b))))
+
+;; (defun test-base64-serializer ()
+;; (let* ((x1 "spud")
+;; (x2 (cons 'a 'b))
+;; (objs (loop for i from 1 to 1000
+;; collect (make-instance 'blob
+;; :slot1 i
+;; :slot2 (* i 100))))
+;; )
+;; (and
+;; (ser-deser-equal x1)
+;; (ser-deser-equal x2)
+;; (reduce
+;; #'(lambda (x y) (and x y))
+;; (mapcar
+;; #'(lambda (x)
+;; (equal x
+;; (with-buffer-streams (other)
+;; (deserialize (serialize x other))
+;; )))
+;; ;; (deserialize-from-base64-string
+;; ;; (serialize-to-base64-string x))))
+;; objs)
+;; :initial-value t)
+;; )))
Index: elephant/src/sleepycat.lisp
diff -u elephant/src/sleepycat.lisp:1.13 elephant/src/sleepycat.lisp:1.13.2.1
--- elephant/src/sleepycat.lisp:1.13 Thu Feb 24 02:06:09 2005
+++ elephant/src/sleepycat.lisp Tue Oct 18 22:41:27 2005
@@ -124,44 +124,18 @@
(eval-when (:compile-toplevel)
(proclaim '(optimize (ext:inhibit-warnings 3))))
-(eval-when (:compile-toplevel :load-toplevel)
- ;; UFFI
- ;;(asdf:operate 'asdf:load-op :uffi)
- ;; DSO loading - Edit these for your system!
+(eval-when (:compile-toplevel :load-toplevel)
- ;; Under linux you may need to load some kind of pthread
- ;; library. I can't figure out which is the right one.
- ;; This one worked for me. There are known issues with
- ;; Red Hat and Berkeley DB, search google.
- #+linux
- (unless
- (uffi:load-foreign-library "/lib/tls/libpthread.so.0" :module "pthread")
- (error "Couldn't load libpthread!"))
-
- (unless
- (uffi:load-foreign-library
- ;; Sleepycat: this works on linux
- #+linux
- "/db/ben/lisp/db43/lib/libdb.so"
- ;; this works on FreeBSD
- #+(and (or bsd freebsd) (not darwin))
- "/usr/local/lib/db43/libdb.so"
- #+darwin
- "/usr/local/BerkeleyDB.4.3/lib/libdb.dylib"
- :module "sleepycat")
- (error "Couldn't load libdb (Sleepycat)!"))
-
- ;; Libsleepycat.so: edit this
- (unless
- (uffi:load-foreign-library
- (if (find-package 'asdf)
- (merge-pathnames
- #p"libsleepycat.so"
- (asdf:component-pathname (asdf:find-system 'elephant)))
- "/usr/local/share/common-lisp/elephant-0.2/libsleepycat.so")
- :module "libsleepycat")
- (error "Couldn't load libsleepycat!"))
+ (unless
+ (uffi:load-foreign-library
+ (if (find-package 'asdf)
+ (merge-pathnames
+ #p"libmemutil.so"
+ (asdf:component-pathname (asdf:find-system 'elephant)))
+ (format nil "~A/~A" *elephant-lib-path* "libmemutil.so"))
+ :module "libmemutil")
+ (error "Couldn't load libmemutil.so!"))
;; fini on user editable part
@@ -786,7 +760,32 @@
(type buffer-stream bs))
(let ((position (buffer-stream-position bs)))
(incf (buffer-stream-position bs))
- (deref-array (buffer-stream-buffer bs) '(:array :char) position)))
+ (deref-array (buffer-stream-buffer bs) '(:array :unsigned-byte) position)))
+
+(defun buffer-read-byte-vector (bs)
+ "Read the whole buffer into byte vector."
+ (declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs))
+ (let* ((position (buffer-stream-position bs))
+ (size (buffer-stream-size bs))
+ (vlen (- size position)))
+ (if (>= vlen 0)
+ (let ((v (make-array vlen :element-type '(unsigned-byte 8))))
+ (dotimes (i vlen v)
+ (setf (aref v i) (buffer-read-byte bs))))
+ nil)))
+
+(defun buffer-write-byte-vector (bs bv)
+ "Read the whole buffer into byte vector."
+ (declare (optimize (speed 3) (safety 0))
+ (type buffer-stream bs))
+ (let* ((position (buffer-stream-position bs))
+ (size (buffer-stream-size bs))
+ (vlen (length bv))
+ (writable (max vlen (- size position))))
+ (dotimes (i writable bs)
+ (buffer-write-byte (aref bv i) bs))))
+
(defun buffer-read-fixnum (bs)
"Read a 32-bit signed integer, which is assumed to be a fixnum."
Index: elephant/src/utils.lisp
diff -u elephant/src/utils.lisp:1.8 elephant/src/utils.lisp:1.8.2.1
--- elephant/src/utils.lisp:1.8 Thu Feb 24 02:06:08 2005
+++ elephant/src/utils.lisp Tue Oct 18 22:41:27 2005
@@ -99,36 +99,65 @@
#+(or cmu sbcl allegro) *resourced-byte-spec*))
(funcall thunk)))
+;; get rid of spot idx and adjust the arrray
+(defun remove-indexed-element-and-adjust (idx array)
+ (let ((last (- (length array) 1)))
+ (do ((i idx (1+ i)))
+ ((= i last) nil)
+ (progn
+ (setf (aref array i) (aref array (+ 1 i)))))
+ (adjust-array array last)))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Macros
-
;; Good defaults for elephant
-(defmacro with-transaction ((&key transaction
- (environment '(controller-environment
- *store-controller*))
- (parent '*current-transaction*)
- degree-2 dirty-read txn-nosync
- txn-nowait txn-sync
- (retries 100))
- &body body)
+(defmacro with-transaction (
+ (&key transaction
+ (store-controller '*store-controller*)
+ environment
+ (parent '*current-transaction*)
+ degree-2 dirty-read txn-nosync
+ 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
- :degree-2 ,degree-2
- :dirty-read ,dirty-read
- :txn-nosync ,txn-nosync
- :txn-nowait ,txn-nowait
- :txn-sync ,txn-sync
- :retries ,retries)
- (let ((*auto-commit* nil))
- , at body)))
+ `(if (not (typep ,store-controller 'elephant::bdb-store-controller))
+ (elephant::with-transaction-sql (:store-controller-sql ,store-controller)
+ , at body)
+;; (if (clsql::in-transaction-p
+;; :database
+;; (controller-db ,store-controller))
+;; (progn
+;; , at body)
+;; (prog2
+;; (clsql::set-autocommit nil)
+;; (clsql::with-transaction
+;; (:database
+;; (controller-db ,store-controller))
+;; , at body)
+;; (clsql::set-autocommit t)))
+ (let ((env (if ,environment ,environment
+ (controller-environment ,store-controller))))
+ (sleepycat:with-transaction (:transaction ,transaction
+ :environment env
+ :parent ,parent
+ :degree-2 ,degree-2
+ :dirty-read ,dirty-read
+ :txn-nosync ,txn-nosync
+ :txn-nowait ,txn-nowait
+ :txn-sync ,txn-sync
+ :retries ,retries)
+
+ (let ((*auto-commit* nil))
+ , at body)))
+ ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
More information about the Elephant-cvs
mailing list