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 ,@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 @@ ,@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 ,@body) - (close-controller *store-controller*)))) + `(let ((*store-controller* + (get-controller ,spec))) + (declare (special *store-controller*)) +;; (open-controller *store-controller*) + (unwind-protect + (progn ,@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)) - ,@body))) + `(if (not (typep ,store-controller 'elephant::bdb-store-controller)) + (elephant::with-transaction-sql (:store-controller-sql ,store-controller) + ,@body) +;; (if (clsql::in-transaction-p +;; :database +;; (controller-db ,store-controller)) +;; (progn +;; ,@body) +;; (prog2 +;; (clsql::set-autocommit nil) +;; (clsql::with-transaction +;; (:database +;; (controller-db ,store-controller)) +;; ,@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)) + ,@body))) + )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;