February 2006 - elephant-cvs@common-lisp.net

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 22 Feb '06

22 Feb '06

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory common-lisp:/tmp/cvs-serv15680/src/db-bdb Modified Files: bdb-collections.lisp Log Message: Added final indexing test (redefine class) green under ACL (and shouldn't have a problem under SBCL). A little tweak here and there, updated the TODO list. --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/21 19:40:03 1.3 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/22 04:40:57 1.4 @@ -90,6 +90,9 @@ (defmethod build-indexed-btree ((sc bdb-store-controller)) (make-instance 'bdb-indexed-btree :sc sc)) +(defmethod build-btree-index ((sc bdb-store-controller) &key primary key-form) + (make-instance 'bdb-btree-index :primary primary :key-form key-form :sc sc)) + (defmethod add-index ((bt bdb-indexed-btree) &key index-name key-form populate) (let ((sc (get-con bt))) ;; Setting the value of *store-controller* is unfortunately @@ -206,9 +209,6 @@ (:metaclass persistent-metaclass) (:documentation "A BDB-based BTree supports secondary indices.")) -(defmethod build-btree-index ((sc bdb-store-controller) &key primary key-form) - (make-instance 'bdb-btree-index :primary primary :key-form key-form :sc sc)) - (defmethod get-value (key (bt bdb-btree-index)) "Get the value in the primary DB from a secondary key." (declare (optimize (speed 3)))

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 22 Feb '06

22 Feb '06

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv15680/tests Modified Files: testindexing.lisp Log Message: Added final indexing test (redefine class) green under ACL (and shouldn't have a problem under SBCL). A little tweak here and there, updated the TODO list. --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/21 19:40:08 1.6 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/22 04:40:57 1.7 @@ -217,14 +217,49 @@ 1 t 2 40 nil nil nil 1 1) (deftest indexing-redef-class - nil - nil) - -(deftest indexing-explicit-changes - nil + (progn + (when (find-class 'idx-eight nil) + (disable-class-indexing 'idx-eight :errorp nil) + (setf (find-class 'idx-six nil) nil)) + + (defclass idx-eight () + ((slot1 :accessor slot1 :initarg :slot1 :index t) + (slot2 :accessor slot2 :initarg :slot2) + (slot3 :accessor slot3 :initarg :slot3 :transient t) + (slot4 :accessor slot4 :initarg :slot4 :index t) + (slot5 :accessor slot5 :initarg :slot5))) + + (let ((o1 nil) + (o2 nil)) + (with-transaction () + (setf o1 (make-instance 'idx-eight :slot1 1 :slot2 2 :slot3 3 :slot4 4 :slot5 5)) + (setf o2 (make-instance 'idx-eight :slot1 10 :slot2 20 :slot3 30 :slot4 40 :slot5 50))) + + (defclass idx-eight () + ((slot1 :accessor slot1 :initarg :slot1 :initform 11) + (slot2 :accessor slot2 :initarg :slot2 :initform 12 :index t) + (slot3 :accessor slot3 :initarg :slot3 :initform 13) + (slot6 :accessor slot6 :initarg :slot6 :initform 14 :index t) + (slot7 :accessor slot7 :initarg :slot7))) + + (values + (and (eq (slot1 o1) 1) + (signals-error (get-instances-by-value 'idx-eight 'slot1 1))) + (and (eq (slot2 o1) 2) + (eq (length (get-instances-by-value 'idx-eight 'slot2 2)) 1)) + (eq (slot3 o1) 13) ;; transient values not preserved (would be inconsistent) + (and (not (slot-exists-p o1 'slot4)) + (not (slot-exists-p o1 'slot5)) + (signals-error (get-instances-by-value 'idx-eight 'slot4))) + (and (eq (slot6 o1) 14) + (eq (length (get-instances-by-value 'idx-eight 'slot6 14)) 2)) + (and (not (slot-boundp o1 'slot7)))))) + t t t t t t) + + nil) -;; create 10k objects, write each object's slots +;; create 500 objects, write each object's slots (defclass stress-normal () ((stress1 :accessor stress1 :initarg :stress1 :initform nil :index nil)

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 21 Feb '06

21 Feb '06

Update of /project/elephant/cvsroot/elephant/src/elephant In directory common-lisp:/tmp/cvs-serv12650/src/elephant Modified Files: classes.lisp classindex.lisp controller.lisp elephant.lisp metaclasses.lisp migrate.lisp Log Message: Migration tests pass on BDB. Only migrate ipclass failes under SQLite 3 (May be due to other current failures under SQLite 3) Significant improvements in transaction stability, stability with mutiple open stores, bdb processing speed, and various bug fixes turned up by getting these tests to pass. --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/21 19:40:03 1.2 @@ -174,7 +174,7 @@ (when (and (indexed class) (not from-oid)) (let ((class-index (find-class-index (class-of instance)))) (when class-index - (with-transaction () + (with-transaction (:store-controller (get-con class-index)) (setf (get-value oid class-index) instance))))) )))) --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/02/21 19:40:03 1.2 @@ -28,7 +28,7 @@ (defgeneric find-inverted-index (persistent-metaclass index-name &key null-on-fail) (:documentation "This method finds an inverted index defined on - the class described by persistent-metaclass.")) + the class described by an instance of persistent-metaclass.")) (defgeneric enable-class-indexing (persistent-metaclass slot-names &rest rest) (:documentation "Enable a class instance index for this object. It's @@ -68,19 +68,20 @@ the dependant indices in synch. Only classes with derived indices need to update on writes to non-indexed slots." (let ((slot-name (slot-definition-name slot-def)) - (oid (oid instance))) + (oid (oid instance)) + (con (get-con instance))) (declare (type fixnum oid)) (if (no-indexing-needed? class instance slot-def oid) - (with-transaction () - (persistent-slot-writer (get-con instance) new-value instance slot-name)) + (with-transaction (:store-controller con) + (persistent-slot-writer con new-value instance slot-name)) (let ((class-idx (find-class-index class)) (*auto-commit* nil)) ;; (format t "Indexing object: ~A oid: ~A~%" instance oid) - (with-transaction () + (with-transaction (:store-controller con) ;; NOTE: Quick and dirty hack to ensure consistency -- needs performance improvement (when (get-value oid class-idx) (remove-kv oid class-idx)) - (persistent-slot-writer (get-con instance) new-value instance slot-name) + (persistent-slot-writer con new-value instance slot-name) (setf (get-value oid class-idx) instance)))))) @@ -164,7 +165,9 @@ (when (controller-class-root sc) (map-btree (lambda (class-name index) (declare (ignore index)) - (setf (%index-cache (find-class class-name)) nil)) + (let ((class (find-class class-name :errorp nil))) + (when class + (setf (%index-cache class) nil)))) (controller-class-root sc)))) ;; ============================= @@ -215,7 +218,7 @@ (remove-class-slot-index class name) (with-transaction (:store-controller sc) (remove-index class-idx name))))) - ;; Drop the class instance index from the class root + ;; Drop the class instance index from the class root (with-transaction (:store-controller sc) (remove-kv (class-name class) (controller-class-root sc))) (setf (%index-cache class) nil) @@ -398,10 +401,9 @@ (when instances (assert (consp instances)) (with-transaction (:store-controller sc) - (let ((class-idx (find-class-index (class-of (first instances))))) - (mapc (lambda (instance) - (remove-kv (oid instance) class-idx)) - instances))))) + (mapc (lambda (instance) + (remove-kv (oid instance) (find-class-index (class-of instance)))) + instances)))) ;; ============================= ;; CLASS / DB SYNCHRONIZATION --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/20 21:21:44 1.5 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/21 19:40:03 1.6 @@ -33,7 +33,7 @@ (defparameter *elephant-backends* '((:bdb (:ele-bdb)) (:clsql (:ele-clsql)) - (:acache (:ele-acache)) +;; (:acache (:ele-acache)) ) "Entries have the form of (backend-type asdf-depends-list") @@ -96,7 +96,12 @@ (satisfy-asdf-dependencies (second record)))) (defun satisfy-asdf-dependencies (dep-list) - (mapc #'(lambda (dep) (asdf:operate 'asdf:load-op dep)) dep-list)) + (mapc #'(lambda (dep) + ;; Only load the first time, after that it's the + ;; users fault if they edit source code + (unless (asdf::system-registered-p dep) + (asdf:operate 'asdf:load-op dep))) + dep-list)) ;; ================================================ ;; @@ -173,7 +178,7 @@ (let ((obj (get-cache oid (instance-cache sc)))) (if obj obj ;; Should get cached since make-instance calls cache-instance - (make-instance class-name :from-oid oid)))) + (make-instance class-name :from-oid oid :sc sc)))) (defmethod flush-instance-cache ((sc store-controller)) "Reset the instance cache (flush object lookups). Useful --- /project/elephant/cvsroot/elephant/src/elephant/elephant.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/elephant.lisp 2006/02/21 19:40:03 1.2 @@ -46,7 +46,7 @@ #:primary #:key-form #:key-fn #:btree-differ - #:migrate + #:migrate #:*inhibit-slot-copy* #:cursor #:secondary-cursor #:make-cursor #:with-btree-cursor #:cursor-close #:cursor-init --- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/19 20:06:04 1.2 +++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/21 19:40:03 1.3 @@ -358,14 +358,20 @@ (make-persistent-slot-boundp name))) slot-def) -(defun persistent-slot-names (class) +(defun persistent-slot-defs (class) (let ((slot-definitions (class-slots class))) - (loop for slot-definition in slot-definitions - when (subtypep (type-of slot-definition) 'persistent-effective-slot-definition) - collect (slot-definition-name slot-definition)))) + (loop for slot-def in slot-definitions + when (subtypep (type-of slot-def) 'persistent-effective-slot-definition) + collect slot-def))) -(defun transient-slot-names (class) +(defun transient-slot-defs (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)))) + (loop for slot-def in slot-definitions + unless (persistent-p slot-def) + collect slot-def))) + +(defun persistent-slot-names (class) + (mapcar #'slot-definition-name (persistent-slot-defs class))) + +(defun transient-slot-names (class) + (mapcar #'slot-definition-name (transient-slot-defs class))) \ No newline at end of file --- /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2006/02/20 15:45:37 1.2 +++ /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2006/02/21 19:40:06 1.3 @@ -27,17 +27,28 @@ ;; NOTES AND LIMITATIONS: ;; - Migrate currently will not handle circular list objects ;; - Migrate does not support arrays with nested persistent objects +;; +;; +;; - Indexed classes only have their class index copied if you use the +;; top level migration. Objects will be copied without slot data if you +;; try to migrate an object outside of a store-to-store migration due to +;; the class object belonging to one store or another ;; - Migrate assumes that after migration, indexed classes belong to the ;; target store. +;; ;; - In general, migration is a one-time activity and afterwards (or after ;; a validation test) the source store should be closed. Any failures ;; in migration should then be easy to catch +;; ;; - Each call to migration will be good about keeping track of already ;; copied objects to avoid duplication. Duplication _shouldn't_ screw -;; up the semantics, just cost storage but is to be avoided. However -;; this information is not saved between calls and there's no other -;; way to do comparisons between objects across stores (different oid -;; namespaces) so user beware of the pitfalls of partial migrations... +;; up the semantics, just add storage overhead but is to be avoided. +;; However this information is not saved between calls and there's no +;; other way to do comparisons between objects across stores (different +;; oid namespaces) so user beware of the pitfalls of partial migrations... +;; - Migration does not maintain OID equivalence so any datastructures which +;; index into those will have to have a way to reconstruct themselves (better +;; to keep the object references themselves rather than oids) ;; ;; CUSTOMIZE MIGRATION: ;; - To customize migration overload a version of migrate to specialize on @@ -48,8 +59,9 @@ ;; In the body of this method you can call (call-next-method) ;; to get a destination repository object with all the slots copied over ;; to the target repository which you can then overwrite. To avoid the -;; slot copying, bind the dynamic variable *inhibit-slot-writes* in your -;; user method using (with-inhibited-slot-copy () ...) a convenience macro +;; default persistent slot copying, bind the dynamic variable +;; *inhibit-slot-writes* in your user method using +;; (with-inhibited-slot-copy () ...) a convenience macro ;; @@ -84,7 +96,9 @@ (let ((*migrating* t)) (declare (special *migrating*)) (reset-migrate-duplicate-detection) - (call-next-method)))) + (let ((result (call-next-method))) + (reset-migrate-duplicate-detection) + result)))) (defmethod migrate :before ((dst store-controller) (src persistent)) "This provides some sanity checking that we aren't trying to copy @@ -103,18 +117,56 @@ "Perform a wholesale repository migration from the root. Also acts as a poor man's GC if you copy to another store of the same type!" + ;; Indexed class slots can only be copied once the class metaobject is + ;; pointing at the new indices...but we know that class indices only contain + ;; indexed persistent objects which (see below) are not copied by default + ;; so we do the slot updates here + (map-btree (lambda (classname classidx) + ;; Class indexes should never be copied already + (assert (not (object-was-copied-p classidx))) + (let ((newcidx + (with-transaction (:store-controller dst) + (build-indexed-btree dst)))) + ;; Add inverse indices to new main class index + (map-indices (lambda (name srciidx) + (with-transaction (:store-controller dst) + (add-index newcidx + :index-name name + :key-form (key-form srciidx) + :populate nil))) + classidx) + ;; Add the class index to the class root + (with-transaction (:store-controller dst) + (setf (get-value classname (controller-class-root dst)) newcidx)) + ;; Update the class to point at all it's new objects in the new store + (setf (%index-cache (find-class classname)) newcidx) + ;; Migrate the indexes' objects + (copy-cindex-contents newcidx classidx) + ;; And remember the class index just incase it's indexed elswhere + ;; (and trips the assert above) + (register-copied-object classidx newcidx))) + (controller-class-root src)) + ;; Copy all other reachable objects (map-btree (lambda (key value) (let ((newval (migrate dst value))) (with-transaction (:store-controller dst :txn-nosync t) (add-to-root key newval :store-controller dst)))) (controller-root src)) - (map-btree (lambda (classname classidx) - (declare (ignore classidx)) - (when (find-class classname nil) - (migrate dst (find-class classname)))) - (controller-class-root src)) dst) +(defun copy-cindex-contents (new old) + (let ((sc (get-con new))) + (map-btree (lambda (oldoid oldinst) + (declare (ignore oldoid)) + (let ((newinst (migrate sc oldinst))) + (with-transaction (:store-controller sc) + ;; This isn't redundant in most cases, but we may have + ;; indexed objects without slots and without a slot + ;; write the new index won't be updated in that case + (setf (get-value (oid newinst) new) newinst)))) + old))) + + ;; PERSISTENT OBJECTS THAT AREN'T INDICES (defvar *inhibit-slot-copy* nil) @@ -132,24 +184,22 @@ a function that calls the default copy and then does stuff with the slot values. A dynamic variable: *inhibit-slot-copy* can be bound in the caller to keep the new object from having it's slots copied" - (let ((class (class-of src))) - (migrate dst class) - ;; Copy or lookup persistent object - (if (object-was-copied-p src) - (retrieve-copied-object src) - (copy-persistent-object dst src)))) - -(defmethod migrate ((dst store-controller) (class persistent-metaclass)) - ;; Migrate classes with indices - (return-from migrate) - (unless (or (not (indexed class)) - (equal (controller-spec dst) - (:dbcn-spc-pst (%index-cache class)))) - (format t "Migrating class~A~%" (class-name class)) - (let ((new-cidx (migrate dst (%index-cache class)))) - (setf (get-value (class-name class) (controller-class-root dst)) new-cidx) - (setf (%index-cache class) new-cidx))) - class) + ;; Copy or lookup persistent object + (if (object-was-copied-p src) + (retrieve-copied-object src) + (copy-persistent-object dst src))) + +;; (defmethod migrate ((dst store-controller) (class persistent-metaclass)) +;; "Migrate classes with indices" +;; (let ((dstcidx (get-value (class-name class) (controller-class-root dst)))) +;; (when (and (indexed class) ;; indexed +;; (not dstcidx) ;; hasn't been copied +;; (%index-cache class)) ;; we have a valid reference +;; (format t "Migrating class~A~%" (class-name class)) +;; (let ((new-cidx (migrate dst (%index-cache class) +;; (setf (get-value (class-name class) (controller-class-root dst)) new-cidx) +;; (setf (%index-cache class) new-cidx))) +;; class) (defun reset-migrate-duplicate-detection () (setf *migrate-copied-oids* (make-hash-table))) @@ -164,24 +214,30 @@ (defun retrieve-copied-object (src) (gethash (oid src) *migrate-copied-oids*)) -;; (make-instance (class-of src) -;; :sc dstsc -;; :from-oid (gethash (oid src) *migrate-copied-oids*))) (defun copy-persistent-object (dstsc src) - (let ((dst (make-instance (class-of src) :sc dstsc))) + "Copy the persistent object reference by making a new one and + potentially copy over the slot values as well" + (let* ((class (class-of src)) + (dst (make-instance (class-of src) :sc dstsc))) (register-copied-object src dst) - (unless *inhibit-slot-copy* + (when (and (not *inhibit-slot-copy*) + (not (inhibit-indexed-slot-copy? dstsc class))) (copy-persistent-slots dstsc (class-of src) src dst)) dst)) +(defun inhibit-indexed-slot-copy? (sc class) + (and (indexed class) + (not (equal (controller-spec sc) + (:dbcn-spc-pst (%index-cache class)))))) + (defun copy-persistent-slots (dstsc class src dst) - "Copy all slots from src to dst - transient and persistent - so we maintain any active data" - (loop for slot-def in (class-slots class) do + "Copy only persistent slots from src to dst" + (loop for slot-def in (persistent-slot-defs class) do (when (slot-boundp-using-class class src slot-def) - (setf (slot-value-using-class class dst slot-def) - (migrate dstsc (slot-value-using-class class src slot-def)))))) + (let ((value (migrate dstsc (slot-value-using-class class src slot-def)))) + (with-transaction (:store-controller dstsc) + (setf (slot-value-using-class class dst slot-def) value)))))) ;; MIGRATE INDICES (Override normal persistent copies) @@ -190,8 +246,9 @@ "Copy an index and it's contents to the target repository" (if (object-was-copied-p src) (retrieve-copied-object src) - (let ((newbtree (build-btree dst))) - (copy-btree-contents dst newbtree src) + (let ((newbtree (build-btree dst))) + (with-transaction (:store-controller dst :txn-nosync t) + (copy-btree-contents dst newbtree src)) (register-copied-object src newbtree) newbtree))) @@ -199,19 +256,19 @@ "Also copy the inverse indices for indexed btrees" (if (object-was-copied-p src) (retrieve-copied-object src) - (let ((newbtree (build-indexed-btree dst))) - (copy-btree-contents dst newbtree src) - (map-indices (lambda (name srciidx) - (add-index newbtree :index-name name :key-form (key-form srciidx) :populate t)) - newbtree) - (register-copied-object src newbtree) - newbtree))) + (with-transaction (:store-controller dst :txn-nosync t) + (let ((newbtree (build-indexed-btree dst))) + (copy-btree-contents dst newbtree src) + (map-indices (lambda (name srciidx) + (add-index newbtree :index-name name :key-form (key-form srciidx) :populate t)) + src) + (register-copied-object src newbtree) + newbtree)))) (defmethod copy-btree-contents ((sc store-controller) dst src) (map-btree (lambda (key value) (let ((newval (migrate sc value))) - (with-transaction (:store-controller sc :txn-nosync t) - (setf (get-value key dst) newval)))) + (setf (get-value key dst) newval))) src))

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 21 Feb '06

21 Feb '06

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv12650/tests Modified Files: elephant-tests.lisp testindexing.lisp testmigration.lisp Log Message: Migration tests pass on BDB. Only migrate ipclass failes under SQLite 3 (May be due to other current failures under SQLite 3) Significant improvements in transaction stability, stability with mutiple open stores, bdb processing speed, and various bug fixes turned up by getting these tests to pass. --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/20 15:45:38 1.16 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/21 19:40:08 1.17 @@ -80,7 +80,7 @@ '(:clsql (:postgresql "localhost.localdomain" "test" "postgres" ""))) (defvar *testsqlite3-spec* - '(:clsql (:sqlite3 "sqlite3-test.db")) + '(:clsql (:sqlite3 "tests/sqlite3-test.db")) "This is of the form '(filename &optional init-function),") (defvar *testsqlite3-memory-spec* @@ -132,8 +132,8 @@ (print (do-test 'migrate-basic)) (print (do-test 'migrate-btree)) (print (do-test 'migrate-idx-btree)) - (print (do-test 'migrate-pclass)))) -;; (print (do-test 'migrate-ipclass)))) + (print (do-test 'migrate-pclass)) + (print (do-test 'migrate-ipclass)))) (defun do-migration-test-spec (test spec1 spec2) (let ((*test-spec-primary* spec1) --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/19 04:53:02 1.5 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/21 19:40:08 1.6 @@ -30,8 +30,9 @@ ;;(format t "Global vars:~%") ;;(format t "~%basic store: ~A ~A~%" *store-controller* (elephant::controller-spec *store-controller*)) ;;(format t "auto-commit: ~A~%" *auto-commit*) - (disable-class-indexing 'idx-one :errorp nil) - (setf (find-class 'idx-one) nil) + (when (find-class 'idx-one nil) + (disable-class-indexing 'idx-one :errorp nil) + (setf (find-class 'idx-one) nil)) (defclass idx-one () ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)) @@ -55,28 +56,33 @@ (deftest indexing-inherit (progn ;; (format t "inherit store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) - (disable-class-indexing 'idx-one :sc *store-controller* :errorp nil) - (disable-class-indexing 'idx-two :sc *store-controller* :errorp nil) - (setf (find-class 'idx-one) nil) - (setf (find-class 'idx-two) nil) - (defclass idx-one () + (when (find-class 'idx-two nil) + (disable-class-indexing 'idx-two :sc *store-controller* :errorp nil) + (setf (find-class 'idx-two) nil)) + + (when (find-class 'idx-three nil) + (disable-class-indexing 'idx-three :sc *store-controller* :errorp nil) + (setf (find-class 'idx-three) nil)) + + (defclass idx-two () ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t) (slot2 :initarg :slot2 :initform 2 :accessor slot2 :index t) (slot3 :initarg :slot3 :initform 3 :accessor slot3) (slot4 :initarg :slot4 :initform 4 :accessor slot4 :transient t)) (:metaclass persistent-metaclass)) - (defclass idx-two (idx-one) + (defclass idx-three (idx-two) ((slot2 :initarg :slot2 :initform 20 :accessor slot2) (slot3 :initarg :slot3 :initform 30 :accessor slot3 :index t) (slot4 :initarg :slot4 :initform 40 :accessor slot4 :index t)) (:metaclass persistent-metaclass)) + (progn (with-transaction () - (setq inst1 (make-instance 'idx-one :sc *store-controller*)) - (setq inst2 (make-instance 'idx-two :sc *store-controller*))) + (setq inst1 (make-instance 'idx-two :sc *store-controller*)) + (setq inst2 (make-instance 'idx-three :sc *store-controller*))) (values (slot1 inst1) (slot2 inst1) @@ -86,47 +92,48 @@ (slot2 inst2) (slot3 inst2) (slot4 inst2) - (equal (elephant::indexing-record-slots (elephant::indexed-record (find-class 'idx-one))) - '(slot1 slot2)) (equal (elephant::indexing-record-slots (elephant::indexed-record (find-class 'idx-two))) + '(slot1 slot2)) + (equal (elephant::indexing-record-slots (elephant::indexed-record (find-class 'idx-three))) '(slot1 slot3 slot4))))) 1 2 3 4 1 20 30 40 t t) (deftest indexing-range (progn ;; (format t "range store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) - (disable-class-indexing 'idx-two :errorp nil) - (disable-class-indexing 'idx-one :errorp nil) - (setf (find-class 'idx-two) nil) - (setf (find-class 'idx-one) nil) + (when (find-class 'idx-four nil) + (disable-class-indexing 'idx-four :errorp nil) + (setf (find-class 'idx-four) nil)) - (defclass idx-one () + (defclass idx-four () ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)) (:metaclass persistent-metaclass)) - (defun make-idx-one (val) - (make-instance 'idx-one :slot1 val)) + (defun make-idx-four (val) + (make-instance 'idx-four :slot1 val)) (with-transaction () - (mapc #'make-idx-one '(1 1 1 2 2 4 5 5 5 6 10))) + (mapc #'make-idx-four '(1 1 1 2 2 4 5 5 5 6 10))) ;; Range should get multiple & single keys inclusive of ;; start and end - (values (equal (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 2 6)) + (values (equal (mapcar #'slot1 (get-instances-by-range 'idx-four 'slot1 2 6)) '(2 2 4 5 5 5 6)) ;; interior range - (equal (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 0 2)) + (equal (mapcar #'slot1 (get-instances-by-range 'idx-four 'slot1 0 2)) '(1 1 1 2 2)) - (equal (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 6 15)) + (equal (mapcar #'slot1 (get-instances-by-range 'idx-four 'slot1 6 15)) '(6 10)))) t t t) (deftest indexing-reconnect-db (progn - (disable-class-indexing 'idx-two :errorp nil) - (setf (find-class 'idx-two) nil) ;; (format t "connect store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) + + (when (find-class 'idx-five nil) + (disable-class-indexing 'idx-two :errorp nil) + (setf (find-class 'idx-two) nil)) - (defclass idx-two () + (defclass idx-five () ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t) (slot2 :initarg :slot2 :initform 2 :accessor slot2) (slot3 :initarg :slot3 :initform 3 :accessor slot3 :index t)) @@ -136,13 +143,13 @@ (*default-indexed-class-synch-policy* :db)) (with-transaction () - (make-instance 'idx-two)) + (make-instance 'idx-five)) ;; Wipe out the class so it's not a redefinition - (setf (find-class 'idx-two) nil) + (setf (find-class 'idx-five) nil) ;; Assume our db is out of synch with our class def - (defclass idx-two () + (defclass idx-five () ((slot1 :initarg :slot1 :initform 1 :accessor slot1) (slot2 :initarg :slot2 :initform 2 :accessor slot2 :index t) (slot3 :initarg :slot3 :initform 3 :accessor slot3 :index t)) @@ -150,34 +157,37 @@ ;; Add an instance of the new class (with-transaction () - (make-instance 'idx-two)) + (make-instance 'idx-five)) ;; DB should dominate (if set as default) - (values (length (get-instances-by-value 'idx-two 'slot3 3)) - (length (get-instances-by-value 'idx-two 'slot1 1)) - (signals-error (length (get-instances-by-value 'idx-two 'slot2 2)))))) + (values (length (get-instances-by-value 'idx-five 'slot3 3)) + (length (get-instances-by-value 'idx-five 'slot1 1)) + (signals-error (length (get-instances-by-value 'idx-five 'slot2 2)))))) 2 2 t) (deftest indexing-change-class (progn - (disable-class-indexing 'idx-one :errorp nil) - (disable-class-indexing 'idx-two :errorp nil) - (setf (find-class 'idx-one) nil) - (setf (find-class 'idx-two) nil) - (defclass idx-one () + (when (find-class 'idx-six nil) + (disable-class-indexing 'idx-six :errorp nil) + (setf (find-class 'idx-six) nil)) + (when (find-class 'idx-seven nil) + (disable-class-indexing 'idx-seven :errorp nil) + (setf (find-class 'idx-seven) nil)) + + (defclass idx-six () ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t) (slot2 :initarg :slot2 :initform 2 :accessor slot2 :index t)) (:metaclass persistent-metaclass)) - (defclass idx-two () + (defclass idx-seven () ((slot1 :initarg :slot1 :initform 10 :accessor slot1 :index nil) (slot3 :initarg :slot3 :initform 30 :accessor slot3 :index t) (slot4 :initarg :slot4 :initform 40 :accessor slot4 :index t)) (:metaclass persistent-metaclass)) - (defmethod update-instance-for-different-class :before ((old idx-one) - (new idx-two) + (defmethod update-instance-for-different-class :before ((old idx-six) + (new idx-seven) &key) (setf (slot3 new) (slot2 old))) @@ -185,8 +195,8 @@ (foo nil)) (declare (special *auto-commit*) (dynamic-extent *auto-commit*)) - (setf foo (make-instance 'idx-one)) - (change-class foo 'idx-two) + (setf foo (make-instance 'idx-six)) + (change-class foo 'idx-seven) (values ;; shared data from original slot @@ -197,12 +207,12 @@ (slot3 foo) (slot4 foo) ;; verify proper indexing changes (none should lookup a value) - (get-instances-by-class 'idx-one) - (get-instances-by-value 'idx-one 'slot1 1) - (get-instances-by-value 'idx-one 'slot2 2) + (get-instances-by-class 'idx-six) + (get-instances-by-value 'idx-six 'slot1 1) + (get-instances-by-value 'idx-six 'slot2 2) ;; new indexes - (length (get-instances-by-class 'idx-two)) - (length (get-instances-by-value 'idx-two 'slot3 2)) + (length (get-instances-by-class 'idx-seven)) + (length (get-instances-by-value 'idx-seven 'slot3 2)) ))) 1 t 2 40 nil nil nil 1 1) --- /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/20 21:21:45 1.9 +++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/21 19:40:08 1.10 @@ -42,27 +42,19 @@ (progn (format t "~%Single store mode: ignoring") t) - (let ((old-store *store-controller*) - (*prev-commit* *auto-commit*) - (*auto-commit* t) - (rv nil) - (sc1 nil) - (sc2 nil)) + (let* ((*store-controller*) + (*auto-commit* t) + (sc1 (open-store *test-spec-primary* :recover t)) + (sc2 (open-store *test-spec-secondary* :recover t))) (unwind-protect (progn - (setf sc1 (open-store *test-spec-primary* :recover t)) - (setf sc2 (open-store *test-spec-secondary* :recover t)) (add-to-root "x" "y" :store-controller sc1) (migrate sc2 sc1) - (setf rv (equal (get-from-root "x" :store-controller sc1) - (get-from-root "x" :store-controller sc2)))) - (progn - (when sc1 (close-store sc1)) - (when sc2 (close-store sc2)) - (setq *store-controller* old-store) - (setq *auto-commit* *prev-commit*))) - rv)) - t) + (equal (get-from-root "x" :store-controller sc1) + (get-from-root "x" :store-controller sc2))) + (close-store sc1) + (close-store sc2)))) + t) ;; Simple test of a btree (deftest migrate-btree @@ -71,23 +63,21 @@ (progn (format t "~%Single store mode: ignoring") nil) - (let ((old-store *store-controller*) - (*prev-commit* *auto-commit*) - (*auto-commit* t) - (rv nil)) - (unwind-protect - (let - ((sc1 (open-store *test-spec-primary*)) - (sc2 (open-store *test-spec-secondary*))) - (let ((ibt (make-btree sc1))) - (loop for i from 0 to 10 - do - (setf (get-value i ibt) (* i i))) - (let ((mig (migrate sc2 ibt))) - (btree-differ ibt mig)))) - (progn - (setq *store-controller* old-store) - (setq *auto-commit* *prev-commit*))))) + (let ((*store-controller* nil) + (*auto-commit* t) + (sc1 (open-store *test-spec-primary* :recover t)) + (sc2 (open-store *test-spec-secondary* :recover t))) + (declare (special *store-controller* *auto-commit*)) + (unwind-protect + (let ((ibt (make-btree sc1))) + (with-transaction (:store-controller sc1) + (loop for i from 0 to 10 + do + (setf (get-value i ibt) (* i i)))) + (let ((mig (migrate sc2 ibt))) + (btree-differ ibt mig))) + (close-store sc1) + (close-store sc2)))) nil) ;; Simple test of indexed btrees @@ -97,40 +87,41 @@ (progn (format t "~%Single store mode: ignoring") t) - (let ((old-store *store-controller*) - (*prev-commit* *auto-commit*) - (*auto-commit* t) - (rv nil)) - (unwind-protect - (let ((sc1 (open-store *test-spec-primary*)) - (sc2 (open-store *test-spec-secondary*)) - ) - (let* ((ibt (make-indexed-btree sc1))) - (let ((index - (add-index ibt :index-name 'crunch :key-form 'crunch - :populate t))) - (loop for i from 0 to 10 - do - (setf (get-value i ibt) (* i i))) - (let* ((mig (migrate sc2 ibt)) - (nindex (get-index ibt 'crunch))) - (loop for i from 0 to 10 - do - (if (not - (equal - (get-value i index) - (get-value i nindex) - )) - (progn - (format t "YIKES ~A ~%" i) - ))) - (setf rv (not (btree-differ ibt mig))) - )))) - (progn - (setq *store-controller* old-store) - (setq *auto-commit* *prev-commit*))) - rv - )) + (let ((old-store *store-controller*) + (*store-controller* nil) + (*prev-commit* *auto-commit*) + (*auto-commit* t) + (rv nil) + (sc1 (open-store *test-spec-primary* :recover t)) + (sc2 (open-store *test-spec-secondary* :recover t))) + (declare (special *auto-commit*)) + (unwind-protect + (let* ((ibt (make-indexed-btree sc1))) + (let ((index + (add-index ibt :index-name 'crunch :key-form 'crunch + :populate t))) + (with-transaction (:store-controller sc1) + (loop for i from 0 to 10 + do + (setf (get-value i ibt) (* i i)))) + (let* ((mig (migrate sc2 ibt)) + (nindex (get-index ibt 'crunch))) + (loop for i from 0 to 10 + do + (if (not + (equal + (get-value i index) + (get-value i nindex) + )) + (progn + (format t "YIKES ~A ~%" i) + ))) + (not (btree-differ ibt mig))))) + (progn + (setq *store-controller* old-store) + (setq *auto-commit* *prev-commit*) + (close-store sc1) + (close-store sc2))))) t) ;; Simple test of persistent classes @@ -140,27 +131,32 @@ (progn (format t "~%Single store mode: ignoring") t) - (let ((*prev-commit* *auto-commit*)) + (let ((*auto-commit* t) + (*store-controller* nil) + (sc1 (open-store *test-spec-primary* :recover t)) + (sc2 (open-store *test-spec-secondary* :recover t))) + (declare (special *auto-commit* *store-controller*)) (unwind-protect - (prog2 - (setq *auto-commit* t) - (let ( - (sc1 (open-store *test-spec-primary*)) - (sc2 (open-store *test-spec-secondary*))) - (let* ((f1 (make-instance 'pfoo :sc sc1)) - (f2 (make-instance 'pfoo :slot1 "this is a string" :sc sc1)) - (b1 (make-instance 'pbar :slot2 "another string" :sc sc1)) - ) - (let ((fm1 (migrate sc2 f1)) - (fm2 (migrate sc2 f2)) - (bm1 (migrate sc2 b1))) - (and - (and (not (slot-boundp fm1 'slot1)) - (not (slot-boundp f1 'slot1))) - (equal (slot1 fm2) (slot1 f2)) - (equal (slot2 bm1) (slot2 b1))) - )))) - (setq *auto-commit* *prev-commit*)))) + (progn + ;; Make instances + (let* ((f1 (with-transaction (:store-controller sc1) + (make-instance 'pfoo :sc sc1))) + (f2 (with-transaction (:store-controller sc1) + (make-instance 'pfoo :slot1 "this is a string" :sc sc1))) + (b1 (with-transaction (:store-controller sc1) + (make-instance 'pbar :slot2 "another string" :sc sc1))) + ) + (let ((fm1 (migrate sc2 f1)) + (fm2 (migrate sc2 f2)) + (bm1 (migrate sc2 b1))) + (and + (and (not (slot-boundp fm1 'slot1)) + (not (slot-boundp f1 'slot1))) + (equal (slot1 fm2) (slot1 f2)) + (equal (slot2 bm1) (slot2 b1))) + ))) + (close-store sc1) + (close-store sc2)))) t) (defpclass ipfoo () @@ -168,37 +164,54 @@ ;; Simple test of persistent classes with indexed slots (deftest migrate-ipclass - (if (or (not (boundp '*test-spec-secondary*) ) + (if (or (not (boundp '*test-spec-secondary*)) (null *test-spec-secondary*)) (progn - (format t "~%Single store mode: ignoring") - t) - (let ((*prev-commit* *auto-commit*)) - (unwind-protect - (progn - (setq *auto-commit* t) - (let ((sc1 (open-store *test-spec-primary*)) - (sc2 (open-store *test-spec-secondary*))) - ;; ensure class index is initialized in sc1 - (find-class-index 'ipfoo :sc sc1) - (let* ((f1 (make-instance 'ipfoo :sc sc1)) - (f2 (make-instance 'ipfoo :slot1 10)) - (f3 (make-instance 'ipfoo :slot1 20))) - (format t "Made instances") - (let ((fm1 (migrate sc2 f1)) - (fm2 (migrate sc2 f2)) - (fm3 (migrate sc2 f3))) - (format t "Migrated instances") - (values - (and - (and (not (slot-boundp fm1 'slot1)) - (not (slot-boundp f1 'slot1))) - (equal (slot1 fm2) (slot1 f2)) - (equal (slot2 fm3) (slot2 f3))) - (length (get-instances-by-class 'ipfoo))) - )))) - (setq *auto-commit* *prev-commit*)))) - t 2 ) + (format t "~%Single store mode: ignoring ") + (values 3 1 1 1 1 10 20 )) + (progn +;; (format t "Opening store~%") + (let ((*auto-commit* nil) + (sc2 (open-store *test-spec-secondary* :recover t)) + (sc1 (open-store *test-spec-primary* :recover t))) + (declare (special *auto-commit*)) + (unwind-protect + ;; ensure class index is initialized in sc1 + (progn + (setf (elephant::%index-cache (find-class 'ipfoo)) nil) + (find-class-index 'ipfoo :sc sc1) +;; (format t "Making objects~%") + (with-transaction (:store-controller sc1) + (drop-instances (get-instances-by-class 'ipfoo) :sc sc1) + (make-instance 'ipfoo :slot1 1 :sc sc1) + (make-instance 'ipfoo :slot1 10 :sc sc1) + (make-instance 'ipfoo :slot1 20 :sc sc1)) +;; (format t "Migrating~%") + (migrate sc2 sc1) + ;; Make sure our ipfoo class now points at a cache in sc2! + (assert (equal (elephant::controller-spec sc2) + (:dbcn-spc-pst (elephant::%index-cache (find-class 'ipfoo))))) +;; (format t "Fetching~%") + (let ((fm1 (get-instances-by-value 'ipfoo 'slot1 1)) + (fm2 (get-instances-by-value 'ipfoo 'slot1 10)) + (fm3 (get-instances-by-value 'ipfoo 'slot1 20)) + (all (get-instances-by-class 'ipfoo))) +;; (format t "Clear & return~%") + (let ((insts (get-instances-by-class 'ipfoo))) + (with-transaction (:store-controller sc2) +;; (format t "Dropping instances~%") + (drop-instances insts :sc sc2))) + (values + (length all) + (length fm1) + (length fm2) + (length fm3) + (slot1 (car fm1)) + (slot1 (car fm2)) + (slot1 (car fm3))))) + (close-store sc1) + (close-store sc2))))) + 3 1 1 1 1 10 20 )

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 21 Feb '06

21 Feb '06

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory common-lisp:/tmp/cvs-serv12650/src/db-bdb Modified Files: bdb-collections.lisp Log Message: Migration tests pass on BDB. Only migrate ipclass failes under SQLite 3 (May be due to other current failures under SQLite 3) Significant improvements in transaction stability, stability with mutiple open stores, bdb processing speed, and various bug fixes turned up by getting these tests to pass. --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/19 20:06:03 1.2 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/21 19:40:03 1.3 @@ -90,9 +90,6 @@ (defmethod build-indexed-btree ((sc bdb-store-controller)) (make-instance 'bdb-indexed-btree :sc sc)) -(defmethod build-btree-index ((sc bdb-store-controller) &key primary key-form) - (make-instance 'bdb-btree-index :primary primary :key-form key-form :sc sc)) - (defmethod add-index ((bt bdb-indexed-btree) &key index-name key-form populate) (let ((sc (get-con bt))) ;; Setting the value of *store-controller* is unfortunately @@ -209,6 +206,9 @@ (:metaclass persistent-metaclass) (:documentation "A BDB-based BTree supports secondary indices.")) +(defmethod build-btree-index ((sc bdb-store-controller) &key primary key-form) + (make-instance 'bdb-btree-index :primary primary :key-form key-form :sc sc)) + (defmethod get-value (key (bt bdb-btree-index)) "Get the value in the primary DB from a secondary key." (declare (optimize (speed 3)))

1 0

[elephant-cvs] CVS elephant/src/db-acache
by ieslick 21 Feb '06

21 Feb '06

Update of /project/elephant/cvsroot/elephant/src/db-acache In directory common-lisp:/tmp/cvs-serv12650/src/db-acache Modified Files: README acache-collections.lisp acache-controller.lisp Log Message: Migration tests pass on BDB. Only migrate ipclass failes under SQLite 3 (May be due to other current failures under SQLite 3) Significant improvements in transaction stability, stability with mutiple open stores, bdb processing speed, and various bug fixes turned up by getting these tests to pass. --- /project/elephant/cvsroot/elephant/src/db-acache/README 2006/02/20 21:21:41 1.1 +++ /project/elephant/cvsroot/elephant/src/db-acache/README 2006/02/21 19:40:02 1.2 @@ -1,6 +1,14 @@ - This directory contains a quick and dirty sketch of an allegrocache -backend, mostly to test out the new backend abstraction. Too bad we -can't use allegroserve directly behind the metaclass protocol...the -apis are a little too different for that. +backend, mostly to test out the new backend abstraction. + +Basic btrees work fine but iteration (cursors) are very limited. +I think the best way to go is reverse engineer the db.btree API +and just implement the elephant backend on top of that API. I +may do this at some point, but not today... + +Or better yet, find someone willing to write a btree library in +lisp. John Fedaro said it wasn't a huge amount of work and can +be done with very high performance in all Common Lisp. + +Ian --- /project/elephant/cvsroot/elephant/src/db-acache/acache-collections.lisp 2006/02/20 21:21:41 1.1 +++ /project/elephant/cvsroot/elephant/src/db-acache/acache-collections.lisp 2006/02/21 19:40:02 1.2 @@ -26,11 +26,32 @@ (defmethod map-btree (fn (bt acache-btree)) (map-map fn bt)) + + +;; INDEXED BTREE + +(defclass acache-indexed-btree (indexed-btree acache-btree) + ((indices :accessor indices :initarg :indices :initform (make-hash-table)) + (indices-cache :accessor indices-cache :initarg :indicies-cache :initform nil :transient t)) + (:metaclass persistent-metaclass)) + +(defmethod build-indexed-btree ((sc acache-store-controller)) + (make-instance 'acache-indexed-btree :sc sc)) + +(defclass acache-btree-index (btree-index acache-btree) + () + (:metaclass persistent-metaclass)) + +(defmethod build-btree-index ((sc acache-store-controller) &key primary key-form) + (make-instance 'acache-btree-index :primary primary :key-form :sc sc)) + ;; -;; Cursors need to have their own model of where they are +;; CURSORS ;; -;; INDEXED BTREE +(defclass acache-cursor (cursor) + ()) + +(defmethod make-cursor ((bt acache-btree)) + (make-instance 'acache-cursor)) -;; How to handle add-index? Have to hack it up on btrees just like slot -;; values...which means solving the complex key problem \ No newline at end of file --- /project/elephant/cvsroot/elephant/src/db-acache/acache-controller.lisp 2006/02/20 21:21:41 1.1 +++ /project/elephant/cvsroot/elephant/src/db-acache/acache-controller.lisp 2006/02/21 19:40:02 1.2 @@ -51,9 +51,7 @@ (defmethod next-oid ((sc acache-store-controller)) - (db.allegrocache:with-transaction-restart () - (incf (oid-record-counter (controller-oidrec sc))) - (commit))) + (incf (oid-record-counter (controller-oidrec sc)))) (defmethod close-controller ((sc acache-store-controller)) ;; Ensure deletion of common

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 20 Feb '06

20 Feb '06

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv10634/tests Modified Files: testmigration.lisp Log Message: A quick AllegroCache backend based on the allegrocache map and compound keys - functionality is only partial but the basics work --- /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/20 15:45:38 1.8 +++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/20 21:21:45 1.9 @@ -175,7 +175,7 @@ t) (let ((*prev-commit* *auto-commit*)) (unwind-protect - (prog2 + (progn (setq *auto-commit* t) (let ((sc1 (open-store *test-spec-primary*)) (sc2 (open-store *test-spec-secondary*)))

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 20 Feb '06

20 Feb '06

Update of /project/elephant/cvsroot/elephant/src/elephant In directory common-lisp:/tmp/cvs-serv10634/src/elephant Modified Files: collections.lisp controller.lisp Log Message: A quick AllegroCache backend based on the allegrocache map and compound keys - functionality is only partial but the basics work --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2006/02/20 15:45:37 1.2 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2006/02/20 21:21:42 1.3 @@ -324,8 +324,8 @@ (progn ,@body) (cursor-close ,var)))) -(defun map-btree (fn btree) - "Like maphash." +(defmethod map-btree (fn (btree btree)) + "Like maphash. Default implementation - overridable" (with-btree-cursor (curs btree) (loop (multiple-value-bind (more k v) (cursor-next curs) --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/20 15:45:37 1.4 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/20 21:21:44 1.5 @@ -30,9 +30,11 @@ ;; Dynamic tracking of active connections -(defvar *elephant-backends* +(defparameter *elephant-backends* '((:bdb (:ele-bdb)) - (:clsql (:ele-clsql))) + (:clsql (:ele-clsql)) + (:acache (:ele-acache)) + ) "Entries have the form of (backend-type asdf-depends-list") (defvar *elephant-controller-init* (make-hash-table)) @@ -53,20 +55,31 @@ cached? That might be dangerous so for now we error" (declare (ignore sc)) (let ((con (gethash (:dbcn-spc-pst instance) *dbconnection-spec*))) - (cond((not con) - ;; NOTE: Create a new one here & warn instead? - (error "Object's store controller was lost")) - ((and con (connection-is-indeed-open con)) - con) - (t (open-controller con))))) + (cond ((not con) + ;; ISE NOTE: Create a new one here & warn instead? + ;; (get-controller spec) + (error "Object's store controller was lost")) + ;; If it's valid and open + ((and con (connection-is-indeed-open con)) + con) + ;; If the object exists but is closed, reopen + (t (open-controller con))) + con)) (defun get-controller (spec) + "This is used by open-store to fetch or open a controller. + This maintains the dbconnection-spec table so should be + the only point of entry for getting access to controllers + from specs. Get-con is used to validate connections and + reopen if necessary and perhaps these two should be combined + at some point" (let ((cached-sc (gethash spec *dbconnection-spec*))) (if (and cached-sc (connection-is-indeed-open cached-sc)) cached-sc (build-controller spec)))) (defun build-controller (spec) + "Actually construct the controller & load dependencies" (assert (and (consp spec) (symbolp (first spec)))) (load-backend (first spec)) (let ((init (lookup-backend-con-init (first spec))))

1 0

[elephant-cvs] CVS elephant/src/db-acache
by ieslick 20 Feb '06

20 Feb '06

Update of /project/elephant/cvsroot/elephant/src/db-acache In directory common-lisp:/tmp/cvs-serv10634/src/db-acache Added Files: README acache-collections.lisp acache-controller.lisp acache-transactions.lisp package.lisp Log Message: A quick AllegroCache backend based on the allegrocache map and compound keys - functionality is only partial but the basics work --- /project/elephant/cvsroot/elephant/src/db-acache/README 2006/02/20 21:21:41 NONE +++ /project/elephant/cvsroot/elephant/src/db-acache/README 2006/02/20 21:21:41 1.1 This directory contains a quick and dirty sketch of an allegrocache backend, mostly to test out the new backend abstraction. Too bad we can't use allegroserve directly behind the metaclass protocol...the apis are a little too different for that. --- /project/elephant/cvsroot/elephant/src/db-acache/acache-collections.lisp 2006/02/20 21:21:41 NONE +++ /project/elephant/cvsroot/elephant/src/db-acache/acache-collections.lisp 2006/02/20 21:21:41 1.1 (in-package :elephant-acache) ;; BTREE (defclass acache-btree (btree) ()) (defmethod build-btree ((sc acache-store-controller)) (make-instance 'acache-btree :sc sc)) (defmethod get-value (key (bt acache-btree)) (map-value (controller-btrees (get-con bt)) (cons (oid bt) key))) (defmethod (setf get-value) (value key (bt acache-btree)) (setf (map-value (controller-btrees (get-con bt)) (cons (oid bt) key)) value)) (defmethod existsp (key (bt acache-btree)) (when (get-value key bt) t)) (defmethod remove-kv (key (bt acache-btree)) (remove-from-map (controller-btrees (get-con bt)) (cons (oid bt) key))) (defmethod map-btree (fn (bt acache-btree)) (map-map fn bt)) ;; ;; Cursors need to have their own model of where they are ;; ;; INDEXED BTREE ;; How to handle add-index? Have to hack it up on btrees just like slot ;; values...which means solving the complex key problem--- /project/elephant/cvsroot/elephant/src/db-acache/acache-controller.lisp 2006/02/20 21:21:41 NONE +++ /project/elephant/cvsroot/elephant/src/db-acache/acache-controller.lisp 2006/02/20 21:21:41 1.1 (in-package :elephant-acache) (defclass acache-store-controller (store-controller) ((db :accessor controller-db :initform nil) (slots :accessor controller-slots :initform nil) (btrees :accessor controller-btrees :initform nil) (oidrec :accessor controller-oidrec :initform nil))) (defun acache-constructor (spec) (make-instance 'acache-store-controller :spec spec)) (eval-when (:compile-toplevel :load-toplevel) (register-backend-con-init :acache 'acache-constructor)) (defclass oid-record () ((counter :accessor oid-record-counter :initform 0)) (:metaclass db.allegrocache:persistent-class)) (defmethod open-controller ((sc acache-store-controller) &key (recover t) (recover-fatal nil) (thread nil)) (declare (ignore recover thread recover-fatal)) (let ((db (db.allegrocache:open-file-database (second (controller-spec sc)) :if-does-not-exist :create :if-exists :open :use :memory))) (when (not db) (error "Unable to open astore database for ~A" (controller-spec sc))) ;; Main DB ref (setf (controller-db sc) db) ;; Slots and Btree storage (let ((slotmap (retrieve-from-index 'ac-map 'ac-map-name "slots"))) (setf (controller-slots sc) (if slotmap slotmap (make-instance 'db.allegrocache:ac-map :ac-map-name "slots")))) (let ((btreemap (retrieve-from-index 'ac-map 'ac-map-name "btrees"))) (setf (controller-btrees sc) (if btreemap btreemap (make-instance 'db.allegrocache:ac-map :ac-map-name "btrees")))) ;; OIDS (let ((oidrec (doclass (inst (find-class 'oid-record) :db db) (when inst (return inst))))) (setf (controller-oidrec sc) (if oidrec oidrec (make-instance 'oid-record)))) ;; Construct the roots (setf (slot-value sc 'root) (make-instance 'acache-btree :from-oid -1)) (setf (slot-value sc 'class-root) (make-instance 'acache-btree :from-oid -2)) sc)) (defmethod next-oid ((sc acache-store-controller)) (db.allegrocache:with-transaction-restart () (incf (oid-record-counter (controller-oidrec sc))) (commit))) (defmethod close-controller ((sc acache-store-controller)) ;; Ensure deletion of common (setf (slot-value sc 'class-root) nil) (setf (slot-value sc 'root) nil) (db.allegrocache:close-database :db (controller-db sc))) (defmethod connection-is-indeed-open ((sc acache-store-controller)) (db.allegrocache::database-open-p (controller-db sc))) ;; Slot writing ;; This is not thread-safe, but could be a thread-local when we fix that... ;; to avoid extra consing. Is consing less/more expensive than dynamic ;; var lookups? (defvar *index-cons* (cons nil nil)) (defmacro fast-key (oid name) `(rplacd (rplaca *index-cons* ,oid) ,name)) (defmethod persistent-slot-reader ((sc acache-store-controller) instance name) (declare (optimize (speed 3) (safety 1))) (multiple-value-bind (val valid?) (map-value (controller-slots sc) (fast-key (oid instance) name)) (if valid? val (error "Slot ~A unbound in ~A" name instance)))) (defmethod persistent-slot-writer ((sc acache-store-controller) value instance name) (declare (optimize (speed 3) (safety 1))) (setf (map-value (controller-slots sc) (fast-key (oid instance) name)) value)) (defmethod persistent-slot-boundp ((sc acache-store-controller) instance name) (declare (optimize (speed 3) (safety 1))) (when (map-value (controller-slots sc) (fast-key (oid instance) name)) t)) (defmethod persistent-slot-makunbound ((sc acache-store-controller) instance name) (declare (optimize (speed 3) (safety 1))) (remove-from-map (controller-slots sc) (fast-key (oid instance) name))) --- /project/elephant/cvsroot/elephant/src/db-acache/acache-transactions.lisp 2006/02/20 21:21:41 NONE +++ /project/elephant/cvsroot/elephant/src/db-acache/acache-transactions.lisp 2006/02/20 21:21:41 1.1 (in-package :elephant-acache) (defmethod controller-start-transaction ((sc acache-store-controller) &key parent &allow-other-keys) "Allegrocache has implicit transactions whenever there's a write" (when parent (error "ACache backend does not allow nested transactions...a commit will commit everything since the last commit")) t) (defmethod controller-commit-transaction ((sc acache-store-controller) &key &allow-other-keys) (db.allegrocache:commit :db (controller-db sc))) (defmethod controller-abort-transaction ((sc acache-store-controller) &key &allow-other-keys) (db.allegrocache:rollback :db (controller-db sc))) (defmethod execute-transaction ((sc acache-store-controller) closure &key parent retries &allow-other-keys) (db.allegrocache:with-transaction-restart (:count retries) (funcall closure) (db.allegrocache:commit :db sc)))--- /project/elephant/cvsroot/elephant/src/db-acache/package.lisp 2006/02/20 21:21:41 NONE +++ /project/elephant/cvsroot/elephant/src/db-acache/package.lisp 2006/02/20 21:21:41 1.1 (in-package :cl-user) (eval-when (:load-toplevel :compile-toplevel) (require :acache)) (eval-when (:load-toplevel) (warn "Allegrocache support is incomplete and should be considered as an example only")) (defpackage elephant-acache (:documentation "A low-level UFFI-based interface to Berkeley DB / Sleepycat to implement the elephant front-end framework. Uses the libsleepycat.c wrapper. Partly intended to be usable outside Elephant, but with some magic for Elephant. In general there is a 1-1 mapping from functions here and functions in Sleepycat, so refer to their documentation for details.") (:use common-lisp elephant elephant-backend) (:import-from #:db.allegrocache #:ac-map #:ac-map-name #:doclass #:commit #:retrieve-from-index #:map-map #:map-value #:remove-from-map))

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 20 Feb '06

20 Feb '06

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory common-lisp:/tmp/cvs-serv10634/src/db-bdb Modified Files: bdb-transactions.lisp Log Message: A quick AllegroCache backend based on the allegrocache map and compound keys - functionality is only partial but the basics work --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2006/02/20 21:21:41 1.2 @@ -79,7 +79,7 @@ dirty-read degree-2 &allow-other-keys) - (db-transaction-begin (controller-environment sc) + (db-transaction-begin (controller-environment sc) :parent parent :txn-nosync txn-nosync :txn-nowait txn-nowait

1 0

[elephant-cvs] CVS elephant/src/db-clsql
by ieslick 20 Feb '06

20 Feb '06

Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory common-lisp:/tmp/cvs-serv10634/src/db-clsql Modified Files: sql-controller.lisp Log Message: A quick AllegroCache backend based on the allegrocache map and compound keys - functionality is only partial but the basics work --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/20 15:45:37 1.5 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/20 21:21:41 1.6 @@ -24,6 +24,15 @@ (in-package "ELEPHANT-CLSQL") +;; ISE NOTE: Putting this here results in users having to +;; modify source code to run which is inadvisable. My strategy +;; is to asdf resolve references to local libraries and require +;; that the user properly install clsql for their chosen SQL +;; backend. If you really want to allow local configuration +;; for SQL then stick it into ele-sql.asd just as we did for +;; BDB in ele-bdb.asd. This note and code should get removed +;; in 0.6.1 if we have a reasonable strategy +;; ;;; other clsql packages would have to be added for ;;; non-postgresql databases, see the CL-SQL documentation ;; (eval-when (:compile-toplevel :load-toplevel) @@ -33,7 +42,6 @@ ;; (clsql:push-library-path *clsql-foreign-lib-path*) ;; (clsql:push-library-path *elephant-lib-path*)) - ;; ;; The main SQL Controller Class ;;

1 0

[elephant-cvs] CVS elephant
by ieslick 20 Feb '06

20 Feb '06

Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv10634 Modified Files: TODO Added Files: ele-acache.asd Log Message: A quick AllegroCache backend based on the allegrocache map and compound keys - functionality is only partial but the basics work --- /project/elephant/cvsroot/elephant/TODO 2006/02/19 20:06:03 1.14 +++ /project/elephant/cvsroot/elephant/TODO 2006/02/20 21:21:40 1.15 @@ -6,15 +6,16 @@ 0.6.0 - Adding default class/slot indexing - Finish indexing tests (Ian) +- Finish migration (Ian) - Documentation update (Robert) -* Make sure library path push happens in build - process and not sql-controller... -* Finish CLSQL debug -* Finish migration port and tests -? Make elephant thread bound variables dynamic and modifiable by backends +- Finish CLSQL backend debug (Robert) 0.6.1 - performance, safety and portability +Multi-threading operation: +- Make elephant thread bound variables dynamic and modifiable by backends +- Verify that operations such as indexing are thread safe + Stability: - Think about dynamic vs. object based store & transaction resolution? - Error checking when mixed --- /project/elephant/cvsroot/elephant/ele-acache.asd 2006/02/20 21:21:40 NONE +++ /project/elephant/cvsroot/elephant/ele-acache.asd 2006/02/20 21:21:40 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; ele-acache.asd -- ASDF file for allegrocache backend ;;; ;;; Initial version 2/18/2006 by Ian Eslick ;;; <ieslick(a)common-lisp.net> ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; <ablumberg(a)common-lisp.net> <blee(a)common-lisp.net> ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. (defsystem ele-acache :name "elephant" :author "Ben Lee <blee(a)common-lisp.net>" :version "0.6.0" :maintainer "Ben Lee <blee(a)common-lisp.net>" :licence "LLGPL" :description "Allegro cache backend for elephant" :components ((:module :src :components ((:module :db-acache :components ((:file "package") (:file "acache-controller") (:file "acache-transactions") (:file "acache-collections")) :serial t)))) :depends-on (:elephant))

1 0

[elephant-cvs] CVS elephant/src/db-acache
by ieslick 20 Feb '06

20 Feb '06

Update of /project/elephant/cvsroot/elephant/src/db-acache In directory common-lisp:/tmp/cvs-serv10513/db-acache Log Message: Directory /project/elephant/cvsroot/elephant/src/db-acache added to the repository

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 20 Feb '06

20 Feb '06

Update of /project/elephant/cvsroot/elephant/src/elephant In directory common-lisp:/tmp/cvs-serv24854/src/elephant Modified Files: backend.lisp collections.lisp controller.lisp migrate.lisp Log Message: Migration implementation; indexed class migration is broken but all else passes basic tests --- /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2006/02/19 20:06:04 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2006/02/20 15:45:37 1.4 @@ -36,6 +36,7 @@ #:persistent-slot-boundp #:persistent-slot-makunbound ;; Controllers + #:store-controller #:open-controller #:close-controller #:controller-spec @@ -44,12 +45,15 @@ #:root #:spec #:class-root #:flush-instance-cache ;; Collection generic functions + #:btree #:btree-index #:indexed-btree #:build-indexed-btree #:build-btree #:existsp + #:map-indices ;; Serialization #:deserialize #:serialize #:deserialize-from-base64-string #:serialize-to-base64-string ;; Cursor accessors + #:cursor #:cursor-btree #:cursor-oid #:cursor-initialized-p @@ -77,6 +81,7 @@ #:persistent-slot-boundp #:persistent-slot-makunbound ;; Controllers + #:store-controller #:open-controller #:close-controller #:controller-spec @@ -85,12 +90,15 @@ #:root #:spec #:class-root #:flush-instance-cache ;; Collection generic functions + #:btree #:btree-index #:indexed-btree #:build-indexed-btree #:build-btree #:existsp + #:map-indices ;; Serialization #:deserialize #:serialize #:deserialize-from-base64-string #:serialize-to-base64-string ;; Cursor accessors + #:cursor #:cursor-btree #:cursor-oid #:cursor-initialized-p --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2006/02/20 15:45:37 1.2 @@ -324,13 +324,13 @@ (progn ,@body) (cursor-close ,var)))) -(defun map-btree (fn bt) +(defun map-btree (fn btree) "Like maphash." - (with-btree-cursor (curs bt) + (with-btree-cursor (curs btree) (loop (multiple-value-bind (more k v) (cursor-next curs) (unless more (return nil)) - (funcall fn k v))))) + (funcall fn k v))))) (defun dump-btree (bt) (format t "DUMP ~A~%" bt) --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/19 20:06:04 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/20 15:45:37 1.4 @@ -102,12 +102,12 @@ (open-controller *store-controller* :recover recover :recover-fatal recover-fatal :thread thread)) -(defun close-store () +(defun close-store (&optional sc) "Conveniently close the store controller." (declare (special *store-controller*)) - (if *store-controller* + (if (or sc *store-controller*) (progn - (close-controller *store-controller*) + (close-controller (or sc *store-controller*)) (setf *store-controller* nil)))) (defmacro with-open-store ((spec) &body body) --- /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2006/02/20 15:45:37 1.2 @@ -2,8 +2,8 @@ ;;; ;;; migrate.lisp -- Migrate between repositories ;;; -;;; Initial version 8/26/2004 by Ben Lee -;;; <blee(a)common-lisp.net> +;;; New Version 2/19/2006 by Ian Eslick +;;; <ieslick(a)common-lisp.net> ;;; ;;; part of ;;; @@ -20,79 +20,233 @@ (in-package "ELEPHANT") ;; -;; MULTI-STORE OPERATION API +;; The generic function Migrate provides an interface to moving objects between +;; repositories +;; + +;; NOTES AND LIMITATIONS: +;; - Migrate currently will not handle circular list objects +;; - Migrate does not support arrays with nested persistent objects +;; - Migrate assumes that after migration, indexed classes belong to the +;; target store. +;; - In general, migration is a one-time activity and afterwards (or after +;; a validation test) the source store should be closed. Any failures +;; in migration should then be easy to catch +;; - Each call to migration will be good about keeping track of already +;; copied objects to avoid duplication. Duplication _shouldn't_ screw +;; up the semantics, just cost storage but is to be avoided. However +;; this information is not saved between calls and there's no other +;; way to do comparisons between objects across stores (different oid +;; namespaces) so user beware of the pitfalls of partial migrations... ;; +;; CUSTOMIZE MIGRATION: +;; - To customize migration overload a version of migrate to specialize on +;; your specific persistent class type. +;; +;; (defmethod migrate ((dst store-controller) (src my-class))) +;; +;; In the body of this method you can call (call-next-method) +;; to get a destination repository object with all the slots copied over +;; to the target repository which you can then overwrite. To avoid the +;; slot copying, bind the dynamic variable *inhibit-slot-writes* in your +;; user method using (with-inhibited-slot-copy () ...) a convenience macro +;; + (defgeneric migrate (dst src) (:documentation "Migrate an object from the src object, collection or controller - to the dst controller")) + to the dst controller. Returns a copy of the object in the new + store so you can drop it into a parent object or the root of + the dst controller")) -(defmethod migrate ((dst store-controller) (src t)) - (error "Cannot migrate object ~A of type ~A" dst (type-of dst))) +;; DEFAULT HANDLERS (defmethod migrate ((dst t) (src t)) (error "Cannot migrate ~A of type ~A to destination of type ~A" src (type-of src) (type-of dst))) +(defmethod migrate ((dst store-controller) (src t)) + "Default: standard objects are automatically migrated" + src) + +;; Avoiding Duplication Semantics + +(defvar *migrate-copied-oids* (make-hash-table)) +(defvar *migrating* nil) + +;; ERROR CHECKING + +(defmethod migrate :around ((dst store-controller) (src t)) + "This method ensures that we wipe our duplication detection + around any top level call to migrate" + (if *migrating* + (call-next-method) + (let ((*migrating* t)) + (declare (special *migrating*)) + (reset-migrate-duplicate-detection) + (call-next-method)))) + +(defmethod migrate :before ((dst store-controller) (src persistent)) + "This provides some sanity checking that we aren't trying to copy + to the same controller. We also need to be careful about deadlocking + our transactions among the two gets/puts. Each leaf migration should + be in its own transaction to avoid too many write locks. " + (let ((dst-spec (controller-spec dst))) + (unless (object-was-copied-p src) + (typecase src + (store-controller (assert (not (equal dst-spec (controller-spec src))))) + (persistent (assert (not (equal dst-spec (:dbcn-spc-pst src))))))))) + +;; WHOLE STORE MIGRATION + (defmethod migrate ((dst store-controller) (src store-controller)) "Perform a wholesale repository migration from the root. - Also a poor man's GC!" - (migrate-btree-contents (controller-root dst) (controller-root src)) - ;; NOTE: we have to migrate class indexes also and update the class objects. - ) + Also acts as a poor man's GC if you copy to another store + of the same type!" + (map-btree (lambda (key value) + (let ((newval (migrate dst value))) + (with-transaction (:store-controller dst :txn-nosync t) + (add-to-root key newval :store-controller dst)))) + (controller-root src)) + (map-btree (lambda (classname classidx) + (declare (ignore classidx)) + (when (find-class classname nil) + (migrate dst (find-class classname)))) + (controller-class-root src)) + dst) + +;; PERSISTENT OBJECTS THAT AREN'T INDICES + +(defvar *inhibit-slot-copy* nil) + +(defmacro with-inhibited-slot-copy ((&key &allow-other-keys) &body body) + `(let ((*inhibit-slot-copy* t)) + (declare (special *inhibit-slot-copy*) + (dynamic-extent *inhibit-slot-copy*)) + ,@body)) + +(defmethod migrate ((dst store-controller) (src persistent)) + "Migrate a persistent object and apply a binary (lambda (dst src) ...) + + function to the new object. Users can override migrate by creating + a function that calls the default copy and then does stuff with the + slot values. A dynamic variable: *inhibit-slot-copy* can be bound + in the caller to keep the new object from having it's slots copied" + (let ((class (class-of src))) + (migrate dst class) + ;; Copy or lookup persistent object + (if (object-was-copied-p src) + (retrieve-copied-object src) + (copy-persistent-object dst src)))) + +(defmethod migrate ((dst store-controller) (class persistent-metaclass)) + ;; Migrate classes with indices + (return-from migrate) + (unless (or (not (indexed class)) + (equal (controller-spec dst) + (:dbcn-spc-pst (%index-cache class)))) + (format t "Migrating class~A~%" (class-name class)) + (let ((new-cidx (migrate dst (%index-cache class)))) + (setf (get-value (class-name class) (controller-class-root dst)) new-cidx) + (setf (%index-cache class) new-cidx))) + class) + +(defun reset-migrate-duplicate-detection () + (setf *migrate-copied-oids* (make-hash-table))) + +(defun object-was-copied-p (src) + (and (subtypep (type-of src) 'persistent) + (gethash (oid src) *migrate-copied-oids*))) + +(defun register-copied-object (src dst) + (assert (not (equal (:dbcn-spc-pst src) (:dbcn-spc-pst dst)))) + (setf (gethash (oid src) *migrate-copied-oids*) dst)) + +(defun retrieve-copied-object (src) + (gethash (oid src) *migrate-copied-oids*)) +;; (make-instance (class-of src) +;; :sc dstsc +;; :from-oid (gethash (oid src) *migrate-copied-oids*))) + +(defun copy-persistent-object (dstsc src) + (let ((dst (make-instance (class-of src) :sc dstsc))) + (register-copied-object src dst) + (unless *inhibit-slot-copy* + (copy-persistent-slots dstsc (class-of src) src dst)) + dst)) + +(defun copy-persistent-slots (dstsc class src dst) + "Copy all slots from src to dst - transient and persistent + so we maintain any active data" + (loop for slot-def in (class-slots class) do + (when (slot-boundp-using-class class src slot-def) + (setf (slot-value-using-class class dst slot-def) + (migrate dstsc (slot-value-using-class class src slot-def)))))) + + +;; MIGRATE INDICES (Override normal persistent copies) (defmethod migrate ((dst store-controller) (src btree)) - "Copy a currently persistent object to a new repository." - (let ((newbtree (build-btree dst))) - newbtree)) + "Copy an index and it's contents to the target repository" + (if (object-was-copied-p src) + (retrieve-copied-object src) + (let ((newbtree (build-btree dst))) + (copy-btree-contents dst newbtree src) + (register-copied-object src newbtree) + newbtree))) + +(defmethod migrate ((dst store-controller) (src indexed-btree)) + "Also copy the inverse indices for indexed btrees" + (if (object-was-copied-p src) + (retrieve-copied-object src) + (let ((newbtree (build-indexed-btree dst))) + (copy-btree-contents dst newbtree src) + (map-indices (lambda (name srciidx) + (add-index newbtree :index-name name :key-form (key-form srciidx) :populate t)) + newbtree) + (register-copied-object src newbtree) + newbtree))) -(defun migrate-btree-contents (dst src) +(defmethod copy-btree-contents ((sc store-controller) dst src) (map-btree (lambda (key value) - (setf (get-value key dst) value)) + (let ((newval (migrate sc value))) + (with-transaction (:store-controller sc :txn-nosync t) + (setf (get-value key dst) newval)))) src)) -(defmethod migrate ((dst store-controller) (btree indexed-btree)) - "Copy indexes and then copy contents and update indices" - (let ((newbtree (build-indexed-btree dst))) - (map-indices (lambda (name idx) - (add-index newbtree :index-name name :key-form (key-form idx) :populate nil)) - btree) - (migrate-btree-contents newbtree btree) - newbtree)) - -;; NOTE: These functions should get rolled into migrate GF - -(defun copy-from-key (key src dst) - "Move the object identified by key on the root in the src to the dst." - (let ((v (get-from-root key :store-controller src))) - (if v - (add-to-root key v :store-controller dst) - v))) - -;; 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)) - -;; ;; 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)) - ) - ) + +;; SUPPORT LISP COLLECTIONS TO HANDLE NESTED PERSISTENT OBJECTS +;; CLEANLY + +;; If we don't do this, then a nested persistent object may be +;; of the source store's class and fail to copy slots on a write +;; and we'll silently lose data... + +(defmethod migrate ((dst store-controller) (src hash-table)) + "Copy the hash elements one at a time" + (let ((newhash (make-hash-table + :test (hash-table-test src) + :size (hash-table-size src) + :rehash-size (hash-table-rehash-size src) + :rehash-threshold (hash-table-rehash-threshold src)))) + (maphash (lambda (key value) + (setf (gethash key newhash) (migrate dst value))) + src))) + +(defmethod migrate ((dst store-controller) (src cons)) + "WARNING: This assumes a standard list or tree-of-lists, but doesn't + work for circular lists!" + (cons (migrate dst (car src)) + (migrate dst (cdr src)))) + +(defmethod migrate ((dst store-controller) (src string)) + "Strings are fine to copy as is" + src) + +(defmethod migrate ((dst store-controller) (src array)) + "NOTE: We need to handle arrays that might contain persistent objects!" + (warn "Arrays with persistent objects will fail migration!") + src) +

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 20 Feb '06

20 Feb '06

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv24854/tests Modified Files: elephant-tests.lisp testmigration.lisp Log Message: Migration implementation; indexed class migration is broken but all else passes basic tests --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/19 17:25:53 1.15 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/20 15:45:38 1.16 @@ -129,12 +129,17 @@ (*test-spec-secondary* spec2)) (declare (special *test-spec-primary* *test-spec-secondary*)) (print (do-test 'remove-element)) - (print (do-test 'migrate1)) - (print (do-test 'migrate2)) - (print (do-test 'migrate3)) - (print (do-test 'migrate4)) - (print (do-test 'migrate5)))) + (print (do-test 'migrate-basic)) + (print (do-test 'migrate-btree)) + (print (do-test 'migrate-idx-btree)) + (print (do-test 'migrate-pclass)))) +;; (print (do-test 'migrate-ipclass)))) +(defun do-migration-test-spec (test spec1 spec2) + (let ((*test-spec-primary* spec1) + (*test-spec-secondary* spec2)) + (declare (special *test-spec-primary* *test-spec-secondary*)) + (print (do-test test)))) ;; --- /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/19 04:53:02 1.7 +++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/20 15:45:38 1.8 @@ -13,6 +13,14 @@ (in-package :ele-tests) +;; TEST TODO: +;; - inhibited slot copy & user overloading of migrate methodss +;; - proper use of clearing the tracking of copies +;; (oids not same over two copys of same object) +;; - whole repository migration (write comparison method to sanity check) +;; - transient slot migration is correct (online transfer of state to new repos) +;; - + (deftest remove-element (if (or (not (boundp '*test-spec-secondary*)) (null *test-spec-secondary*)) @@ -27,7 +35,8 @@ (equal (length a) (length ans))))) t) -(deftest migrate1 +;; Simple root element copy +(deftest migrate-basic (if (or (not (boundp '*test-spec-secondary*) ) (null *test-spec-secondary*)) (progn @@ -41,10 +50,10 @@ (sc2 nil)) (unwind-protect (progn - (setf sc1 (open-store *test-spec-primary*)) - (setf sc2 (open-store *test-spec-secondary*)) + (setf sc1 (open-store *test-spec-primary* :recover t)) + (setf sc2 (open-store *test-spec-secondary* :recover t)) (add-to-root "x" "y" :store-controller sc1) - (copy-from-key "x" sc1 sc2) + (migrate sc2 sc1) (setf rv (equal (get-from-root "x" :store-controller sc1) (get-from-root "x" :store-controller sc2)))) (progn @@ -55,8 +64,8 @@ rv)) t) - -(deftest migrate2 +;; Simple test of a btree +(deftest migrate-btree (if (or (not (boundp '*test-spec-secondary*) ) (null *test-spec-secondary*)) (progn @@ -70,7 +79,7 @@ (let ((sc1 (open-store *test-spec-primary*)) (sc2 (open-store *test-spec-secondary*))) - (let ((ibt (build-btree sc1))) + (let ((ibt (make-btree sc1))) (loop for i from 0 to 10 do (setf (get-value i ibt) (* i i))) @@ -81,8 +90,8 @@ (setq *auto-commit* *prev-commit*))))) nil) - -(deftest migrate3 +;; Simple test of indexed btrees +(deftest migrate-idx-btree (if (or (not (boundp '*test-spec-secondary*) ) (null *test-spec-secondary*)) (progn @@ -96,23 +105,21 @@ (let ((sc1 (open-store *test-spec-primary*)) (sc2 (open-store *test-spec-secondary*)) ) - (let* ((ibt (build-indexed-btree sc1))) - (let ( - (index + (let* ((ibt (make-indexed-btree sc1))) + (let ((index (add-index ibt :index-name 'crunch :key-form 'crunch - :populate t)) - ) + :populate t))) (loop for i from 0 to 10 do (setf (get-value i ibt) (* i i))) (let* ((mig (migrate sc2 ibt)) - (nindex (gethash 'crunch (indices ibt)))) + (nindex (get-index ibt 'crunch))) (loop for i from 0 to 10 do (if (not (equal (get-value i index) - (get-value i nindex) + (get-value i nindex) )) (progn (format t "YIKES ~A ~%" i) @@ -126,79 +133,72 @@ )) t) - -(deftest migrate4 +;; Simple test of persistent classes +(deftest migrate-pclass (if (or (not (boundp '*test-spec-secondary*) ) (null *test-spec-secondary*)) (progn (format t "~%Single store mode: ignoring") t) - (finishes - (let ((old-store *store-controller*) - (*prev-commit* *auto-commit*) - (*auto-commit* t) - (rv nil)) - (unwind-protect - (let* ( - (sc1 (open-store *test-spec-primary*)) - (sc2 (open-store *test-spec-secondary*)) - ) - (let* ((ibt (build-indexed-btree sc1))) - (let ( - (index - (add-index ibt :index-name 'crunch :key-form 'crunch - :populate t)) - (x 0) - ) - (loop for i from 0 to 10 - do - (setf (get-value i ibt) (* i i))) - ))) - (progn - (setq *store-controller* old-store) - (setq *auto-commit* *prev-commit*))) - ))) + (let ((*prev-commit* *auto-commit*)) + (unwind-protect + (prog2 + (setq *auto-commit* t) + (let ( + (sc1 (open-store *test-spec-primary*)) + (sc2 (open-store *test-spec-secondary*))) + (let* ((f1 (make-instance 'pfoo :sc sc1)) + (f2 (make-instance 'pfoo :slot1 "this is a string" :sc sc1)) + (b1 (make-instance 'pbar :slot2 "another string" :sc sc1)) + ) + (let ((fm1 (migrate sc2 f1)) + (fm2 (migrate sc2 f2)) + (bm1 (migrate sc2 b1))) + (and + (and (not (slot-boundp fm1 'slot1)) + (not (slot-boundp f1 'slot1))) + (equal (slot1 fm2) (slot1 f2)) + (equal (slot2 bm1) (slot2 b1))) + )))) + (setq *auto-commit* *prev-commit*)))) t) -(deftest migrate5 +(defpclass ipfoo () + ((slot1 :accessor slot1 :initarg :slot1 :index t))) + +;; Simple test of persistent classes with indexed slots +(deftest migrate-ipclass (if (or (not (boundp '*test-spec-secondary*) ) (null *test-spec-secondary*)) (progn (format t "~%Single store mode: ignoring") t) (let ((*prev-commit* *auto-commit*)) - (prog2 - (setq *auto-commit* t) - (let ( - (sc1 (open-store *test-spec-primary*)) - (sc2 (open-store *test-spec-secondary*))) - (let* ((f1 (make-instance 'pfoo :sc sc1)) - (f2 (make-instance 'pfoo :slot1 "this is a string" :sc sc1)) - (b1 (make-instance 'pbar :slot2 "another string" :sc sc1)) - ) - (let ((fm1 - (migrate ;; (ele::migraten-pobj - sc2 f1 - #'(lambda (dst src) - (if (slot-boundp src 'slot1) - (setf (slot1 dst) (slot1 src)))))) - (fm2 - (migrate ;; (ele::migraten-pobj - sc2 f2 - #'(lambda (dst src) - (if (slot-boundp src 'slot1) - (setf (slot1 dst) (slot1 src)))))) - (bm1 (migrate ;; (ele::migraten-pobj - sc2 b1 - #'(lambda (dst src) - (if (slot-boundp src 'slot2) - (setf (slot2 dst) (slot2 src)))))) - ) - (and - (and (not (slot-boundp fm1 'slot1)) - (not (slot-boundp f1 'slot1))) -;; (equal (slot1 fm2) (slot1 f2)) -;; (equal (slot2 bm1) (slot2 b1)) - )))) - (setq *auto-commit* *prev-commit*)))) - t) + (unwind-protect + (prog2 + (setq *auto-commit* t) + (let ((sc1 (open-store *test-spec-primary*)) + (sc2 (open-store *test-spec-secondary*))) + ;; ensure class index is initialized in sc1 + (find-class-index 'ipfoo :sc sc1) + (let* ((f1 (make-instance 'ipfoo :sc sc1)) + (f2 (make-instance 'ipfoo :slot1 10)) + (f3 (make-instance 'ipfoo :slot1 20))) + (format t "Made instances") + (let ((fm1 (migrate sc2 f1)) + (fm2 (migrate sc2 f2)) + (fm3 (migrate sc2 f3))) + (format t "Migrated instances") + (values + (and + (and (not (slot-boundp fm1 'slot1)) + (not (slot-boundp f1 'slot1))) + (equal (slot1 fm2) (slot1 f2)) + (equal (slot2 fm3) (slot2 f3))) + (length (get-instances-by-class 'ipfoo))) + )))) + (setq *auto-commit* *prev-commit*)))) + t 2 ) + + +

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 20 Feb '06

20 Feb '06

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory common-lisp:/tmp/cvs-serv24854/src/db-bdb Modified Files: bdb-controller.lisp Log Message: Migration implementation; indexed class migration is broken but all else passes basic tests --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/02/19 20:06:03 1.2 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/02/20 15:45:37 1.3 @@ -135,7 +135,7 @@ (setf (controller-environment sc) nil) nil) ;; Delete connection spec so object ops on cached db info fail - (remhash (controller-spec *store-controller*) *dbconnection-spec*)) + (remhash (controller-spec sc) *dbconnection-spec*)) (defmethod next-oid ((sc bdb-store-controller))

1 0

[elephant-cvs] CVS elephant/src/db-clsql
by ieslick 20 Feb '06

20 Feb '06

Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory common-lisp:/tmp/cvs-serv24854/src/db-clsql Modified Files: sql-controller.lisp Log Message: Migration implementation; indexed class migration is broken but all else passes basic tests --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/19 20:06:03 1.4 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/20 15:45:37 1.5 @@ -314,20 +314,14 @@ (the sql-store-controller (let* ((dbtype (car (second (controller-spec sc)))) (con (clsql:connect (cdr (second (controller-spec sc))) -;; WARNING: This line of code forces us to use postgresql. -;; If this were parametrized upwards we could concievably try -;; other backends. :database-type dbtype -;; DNK :postgresql -;; :database-type :postgresql :if-exists :old))) (setf (slot-value sc 'db) con) ;; Now we should make sure that the KEYVALUE table exists, and, if ;; it does not, we need to create it.. - ;; This kind of thing is typically database-specific, but at least we - ;; can put it in a function.... (unless (keyvalue-table-exists con) - (create-keyvalue-table con)) + (with-transaction (:store-controller sc) + (create-keyvalue-table con))) ;; These should get oid 0 and 1 respectively (setf (slot-value sc 'root) (make-instance 'sql-btree :sc sc :from-oid 0)) (setf (slot-value sc 'class-root) (make-instance 'sql-indexed-btree :sc sc :from-oid 1))

1 0

[elephant-cvs] CVS elephant
by ieslick 20 Feb '06

20 Feb '06

Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv24854 Modified Files: INSTALL Removed Files: functions.lisp Log Message: Migration implementation; indexed class migration is broken but all else passes basic tests --- /project/elephant/cvsroot/elephant/INSTALL 2006/02/19 17:25:52 1.15 +++ /project/elephant/cvsroot/elephant/INSTALL 2006/02/20 15:45:36 1.16 @@ -3,25 +3,22 @@ Requirements ------------ -CMUCL 19a, SBCL 0.9.5, OpemMCL 0.14.2, or Allegro CL 6.2. -This version ahs been tested under Linux and SBCL 0.9.5, but -Dan Knapp has also run something very closed under Darwin. -can't personally test Win32 but I've compiled under Visual -Studio .NET and a user has gotten it to work with Visual -Studio 6. A Lispworks version will come if requested. - -ASDF - http://www.cliki.net/asdf - -UFFI 1.4.24+ - http://uffi.b9.com -(I have been testing with UFFI 1.5.4 and I recommend you use that.) - -I've patched src/functions.lisp to support some kinds of -:out arguments. it is backwards-compatible so shouldn't -interfere with your existing work. It is included in -1.4.25+, but just in case you have 1.4.24 I have included -it. - -Sleepycat Berkeley DB 4.3 - http://www.sleepycat.com +Support Lisps: +CMUCL 19a Linux +SBCL 0.9.6/0.9.9 Linux / Mac OSX +Allegro CL 6.2/7.0/8.0 Linux / Mac OSX +OpenMCL 0.14.2 +LispWorks (port in-progress) + +Lisp libraries: +ASDF - http://www.cliki.net/asdf +UFFI 1.5.4+ - http://uffi.b9.com/ + +Backends: +1) Sleepycat Berkeley DB 4.3 - http://www.sleepycat.com +2) CLSQL - http://clsql.b9.com/ + And an appropriate SQL installation. + Tested with SQlite3 and Postgresql so far A C compiler, probably gcc or Visual Studio. Presumably you have this if you installed Sleepycat. @@ -55,21 +52,14 @@ /usr/local/share/common-lisp/elephant-0.3/ - -1) Install UFFI. If you're using 1.4.24 replace - - path-to-uffi/src/functions.lisp - - with the provided file. - - -2) Install ASDF. +1) Install ASDF. Ensure that you have a recent version of ASDF installed as the load process now depends upon it. +2) Install UFFI. -3) Install a backend: Either Berkeley DB 4.3, PostGresql, or SQLite 3. +3) Install a backend: Either Berkeley DB 4.3, PostGresql, or SQLite 3. ------- SQL

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 19 Feb '06

19 Feb '06

Update of /project/elephant/cvsroot/elephant/src/elephant In directory common-lisp:/tmp/cvs-serv14267/src/elephant Modified Files: backend.lisp controller.lisp metaclasses.lisp Log Message: Includes most SQL fixes - works under SBCL/ACL. Two problems remain in indexing under SQL for both SBCL/ACL --- /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2006/02/19 16:22:43 1.2 +++ /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2006/02/19 20:06:04 1.3 @@ -41,8 +41,7 @@ #:controller-spec #:controller-root #:controller-class-root - #:root - #:class-root + #:root #:spec #:class-root #:flush-instance-cache ;; Collection generic functions #:build-indexed-btree #:build-btree #:existsp @@ -64,7 +63,6 @@ #:remove-indexed-element-and-adjust #:register-backend-con-init #:lookup-backend-con-init - #:form-slot-key ) (:export ;; Variables @@ -84,8 +82,7 @@ #:controller-spec #:controller-root #:controller-class-root - #:root - #:class-root + #:root #:spec #:class-root #:flush-instance-cache ;; Collection generic functions #:build-indexed-btree #:build-btree #:existsp @@ -107,6 +104,5 @@ #:remove-indexed-element-and-adjust #:register-backend-con-init #:lookup-backend-con-init - #:form-slot-key )) \ No newline at end of file --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/19 05:13:02 1.2 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/19 20:06:04 1.3 @@ -120,22 +120,6 @@ (progn ,@body) (close-controller *store-controller*)))) -;; ISE: 2/17 - Removing this as it's not clear what usage model requires -;; it unless your often closing a controller while keeping -;; the object around. Usage should be to toss a closed -;; controller so you don't end up with two! -;; -;; (defmacro with-open-controller ((&optional (sc '*store-controller*)) -;; &body body) -;; "Executes body with the specified controller open, closing -;; the controller unconditionally on exit." -;; `(unwind-protect -;; (progn -;; (let ((*store-controller* (open-controller ,sc))) -;; (declare (special *store-controller*)) -;; ,@body)) -;; (close-controller ,sc))) - ;; ;; COMMON STORE CONTROLLER FUNCTIONALITY ;; --- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/19 20:06:04 1.2 @@ -326,11 +326,6 @@ when (eq (slot-definition-name slot-def) slot-name) do (return slot-def))) -;; This this is not a good way to form a key... -(defun form-slot-key (oid name) - (format nil "~A ~A" oid name) - ) - #+(or cmu sbcl) (defun make-persistent-reader (name) (lambda (instance)

1 0

[elephant-cvs] CVS elephant/src/memutil
by ieslick 19 Feb '06

19 Feb '06

Update of /project/elephant/cvsroot/elephant/src/memutil In directory common-lisp:/tmp/cvs-serv14267/src/memutil Modified Files: memutil.lisp Log Message: Includes most SQL fixes - works under SBCL/ACL. Two problems remain in indexing under SQL for both SBCL/ACL --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/02/19 17:25:53 1.3 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/02/19 20:06:04 1.4 @@ -71,7 +71,7 @@ (uffi:load-foreign-library (merge-pathnames (make-pathname :name "libmemutil" :type *c-library-extension* ) - (merge-pathnames (make-pathname :directory "src/memutil") + (merge-pathnames "src/memutil/" (asdf:component-pathname (asdf:find-system 'elephant)))) :module "libmemutil") (error "Couldn't load src/memutil/libmemutil.~A in!" *c-library-extension*))

1 0

[elephant-cvs] CVS elephant
by ieslick 19 Feb '06

19 Feb '06

Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv14267 Modified Files: TODO ele-bdb.asd ele-sqlite3.asd elephant.asd Log Message: Includes most SQL fixes - works under SBCL/ACL. Two problems remain in indexing under SQL for both SBCL/ACL --- /project/elephant/cvsroot/elephant/TODO 2006/02/19 04:52:58 1.13 +++ /project/elephant/cvsroot/elephant/TODO 2006/02/19 20:06:03 1.14 @@ -7,17 +7,19 @@ 0.6.0 - Adding default class/slot indexing - Finish indexing tests (Ian) - Documentation update (Robert) -* Add clsql like support for building .so/.dylib from asdf loader on most systems -* Make elephant thread bound variables dynamic and modifiable by backends +* Make sure library path push happens in build + process and not sql-controller... +* Finish CLSQL debug * Finish migration port and tests -- Think about dynamic vs. object based store & transaction resolution? - - Error checking when mixed - - Current store specific *current-transaction* stack -- Throw condition when store spec is invalid, etc +? Make elephant thread bound variables dynamic and modifiable by backends 0.6.1 - performance, safety and portability Stability: +- Think about dynamic vs. object based store & transaction resolution? + - Error checking when mixed + - Current store specific *current-transaction* stack +- Throw condition when store spec is invalid, etc - Think through default vs. explicit store referencing all over the APIs (Both) - Cleaner failure modes if operations are performed without repository or without transaction or auto-commit (Both) --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/02/19 17:25:52 1.7 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/02/19 20:06:03 1.8 @@ -94,8 +94,9 @@ (defmethod operation-done-p ((o load-op) (c bdb-c-source)) "Operation is done when the foreign library is loaded which should happen when we compile the interface lisp file" - (and (symbol-function (intern (symbol-name '#:%db-strerror) - (find-package '#:sleepycat))) + (and (and (find-package '#:sleepycat) + (symbol-function (intern (symbol-name '#:%db-strerror) + (find-package '#:sleepycat)))) t)) --- /project/elephant/cvsroot/elephant/ele-sqlite3.asd 2006/02/19 04:52:58 1.5 +++ /project/elephant/cvsroot/elephant/ele-sqlite3.asd 2006/02/19 20:06:03 1.6 @@ -56,4 +56,4 @@ ( ) :serial t)) - :depends-on (:ele-sql :clsql-sqlite3)) + :depends-on (:ele-clsql :clsql-sqlite3)) --- /project/elephant/cvsroot/elephant/elephant.asd 2006/02/19 16:22:39 1.14 +++ /project/elephant/cvsroot/elephant/elephant.asd 2006/02/19 20:06:03 1.15 @@ -71,8 +71,9 @@ (defmethod operation-done-p ((o load-op) (c elephant-util-c-source)) "Operation is done when the foreign library is loaded which should happen when we compile the interface lisp file" - (and (symbol-function (intern (symbol-name '#:copy-bufs) - (find-package '#:elephant-memutil))) + (and (find-package "ELEPHANT-MEMUTIL") + (symbol-function (intern "COPY-BUFS" + (find-package "ELEPHANT-MEMUTIL"))) t)) (defsystem elephant

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 19 Feb '06

19 Feb '06

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory common-lisp:/tmp/cvs-serv14267/src/db-bdb Modified Files: bdb-collections.lisp bdb-controller.lisp sleepycat.lisp Log Message: Includes most SQL fixes - works under SBCL/ACL. Two problems remain in indexing under SQL for both SBCL/ACL --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/19 20:06:03 1.2 @@ -76,11 +76,9 @@ ;; Secondary indices (defclass bdb-indexed-btree (indexed-btree bdb-btree) - ( - (indices :accessor indices :initform (make-hash-table)) + ((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 BDB-based BTree supports secondary indices.")) @@ -90,20 +88,10 @@ (setf (indices-cache instance) (indices instance))) (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)) + (make-instance 'bdb-indexed-btree :sc sc)) (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)) + (make-instance 'bdb-btree-index :primary primary :key-form key-form :sc sc)) (defmethod add-index ((bt bdb-indexed-btree) &key index-name key-form populate) (let ((sc (get-con bt))) @@ -221,8 +209,6 @@ (:metaclass persistent-metaclass) (:documentation "A BDB-based BTree supports secondary indices.")) -;; 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))) @@ -248,13 +234,6 @@ (values (deserialize buf :sc (get-con bt)) oid)) (values nil nil))))) - -;; 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 bdb-cursor (cursor) ((handle :accessor cursor-handle :initarg :handle)) (:documentation "A cursor for traversing (primary) BDB-BTrees.")) @@ -507,8 +486,8 @@ (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) (values t -(deserialize key :sc (get-con (cursor-btree cursor))) -(deserialize val :sc (get-con (cursor-btree cursor))) + (deserialize key :sc (get-con (cursor-btree cursor))) + (deserialize val :sc (get-con (cursor-btree cursor))) (progn (buffer-read-int pkey) (deserialize pkey)))) (setf (cursor-initialized-p cursor) nil))))) --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/02/19 20:06:03 1.2 @@ -38,14 +38,14 @@ ;; Backend Registry Support ;; -(eval-when (:compile-toplevel :load-toplevel) - (register-backend-con-init :bdb 'bdb-test-and-construct)) - (defun bdb-test-and-construct (spec) (if (bdb-store-spec-p spec) - (open-store-bdb spec) + (make-instance 'bdb-store-controller :spec spec) (error (format nil "uninterpretable spec specifier: ~A" spec)))) +(eval-when (:compile-toplevel :load-toplevel) + (register-backend-con-init :bdb 'bdb-test-and-construct)) + (defun bdb-store-spec-p (spec) (and (eq (first spec) :bdb) (typecase (second spec) @@ -53,13 +53,6 @@ (string t) (otherwise nil)))) -(defmethod next-oid ((sc bdb-store-controller)) - "Get the next OID." - (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 bdb-store-controller) &key (recover t) (recover-fatal nil) (thread t)) @@ -144,12 +137,12 @@ ;; Delete connection spec so object ops on cached db info fail (remhash (controller-spec *store-controller*) *dbconnection-spec*)) -(defun open-store-bdb (spec &key (recover nil) (recover-fatal nil) (thread t)) - "Conveniently open a store controller." - (setq *store-controller* - (make-instance 'bdb-store-controller :spec spec)) - (open-controller *store-controller* :recover recover - :recover-fatal recover-fatal :thread thread)) + +(defmethod next-oid ((sc bdb-store-controller)) + "Get the next OID." + (declare (type bdb-store-controller sc)) + (db-sequence-get-fixnum (controller-oid-seq sc) 1 :transaction +NULL-VOID+ + :auto-commit t :txn-nosync t)) ;; --- /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat.lisp 2006/02/19 17:25:53 1.2 +++ /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat.lisp 2006/02/19 20:06:03 1.3 @@ -78,7 +78,7 @@ (uffi:load-foreign-library (merge-pathnames (make-pathname :name "libsleepycat" :type *c-library-extension*) - (merge-pathnames (make-pathname :directory "src/db-bdb") + (merge-pathnames "src/db-bdb/" (asdf:component-pathname (asdf:find-system 'elephant)))) :module "libsleepycat") (error "Couldn't load src/db-bdb/libsleepycat.~A!" elephant-memutil::*c-library-extension*))

1 0

[elephant-cvs] CVS elephant/src/db-clsql
by ieslick 19 Feb '06

19 Feb '06

Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory common-lisp:/tmp/cvs-serv14267/src/db-clsql Modified Files: sql-collections.lisp sql-controller.lisp Log Message: Includes most SQL fixes - works under SBCL/ACL. Two problems remain in indexing under SQL for both SBCL/ACL --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2006/02/19 16:22:40 1.2 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2006/02/19 20:06:03 1.3 @@ -19,11 +19,6 @@ (in-package "ELEPHANT-CLSQL") -(defclass sql-btree-index (btree-index sql-btree) - () - (:metaclass persistent-metaclass) - (:documentation "A SQL-based BTree supports secondary indices.")) - (defmethod get-value (key (bt sql-btree-index)) "Get the value in the primary DB from a secondary key." (declare (optimize (speed 3))) @@ -234,6 +229,7 @@ (progn (multiple-value-bind (h k v) (cursor-next cursor) + (declare (ignore h v)) (when (my-generic-less-than key k) (setf vs t)) ) @@ -285,7 +281,8 @@ "Put by cursor. Not particularly useful since primaries don't support duplicates. Currently doesn't properly move the cursor." - (declare (optimize (speed 3))) + (declare (optimize (speed 3)) + (ignore key value key-specified-p)) (error "Puts on sql-cursors are not yet implemented, because I can't get them to work on BDB cursors!")) ;; Secondary Cursors @@ -451,7 +448,7 @@ (remove-kv p (primary (cursor-btree cursor))) (let ((ck (:sql-crsr-ck cursor)) (dp (:dp-nmbr cursor))) - + (declare (ignorable dp)) (cursor-next cursor) ;; Now that we point to the old slot, remove the old slot from the array... (setf (:sql-crsr-ks cursor) @@ -466,20 +463,20 @@ (defmethod cursor-get-both ((cursor sql-secondary-cursor) key value) "cursor-get-both not implemented for secondary indices. Use cursor-pget-both." - (declare (ignore cursor key value)) + (declare (ignore key value)) (error "cursor-get-both not implemented on secondary indices. Use cursor-pget-both.")) (defmethod cursor-get-both-range ((cursor sql-secondary-cursor) key value) "cursor-get-both-range not implemented for secondary indices. Use cursor-pget-both-range." - (declare (ignore cursor key value)) + (declare (ignore key value)) (error "cursor-get-both-range not implemented on secondary indices. Use cursor-pget-both-range.")) (defmethod cursor-put ((cursor sql-secondary-cursor) value &rest rest) "Puts are forbidden on secondary indices. Try adding to the primary." - (declare (ignore rest value cursor)) + (declare (ignore rest value)) (error "Puts are forbidden on secondary indices. Try adding to the primary.")) --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/19 16:22:40 1.3 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/19 20:06:03 1.4 @@ -26,91 +26,75 @@ ;;; other clsql packages would have to be added for ;;; non-postgresql databases, see the CL-SQL documentation -(eval-when (:compile-toplevel :load-toplevel) - ;; NOTE: Integrate into load process - ;; Probably must be customized ... see documentation on installin postgres. - (defvar *clsql-foreign-lib-path* "/usr/lib") - (clsql:push-library-path *clsql-foreign-lib-path*) - (clsql:push-library-path *elephant-lib-path*)) +;; (eval-when (:compile-toplevel :load-toplevel) +;; ;; NOTE: Integrate into load process +;; ;; Probably must be customized ... see documentation on installin postgres. +;; (defvar *clsql-foreign-lib-path* "/usr/lib") +;; (clsql:push-library-path *clsql-foreign-lib-path*) +;; (clsql:push-library-path *elephant-lib-path*)) + + +;; +;; The main SQL Controller Class +;; + (defclass sql-store-controller (store-controller) - ((dbonnection-spec :type list :accessor :dbcn-spc :initarg :dbconnection-spec - ;; for postgres, this is host, db, user, password - ;; If you can't get the lisp system to connect with - ;; this default information, make sure you can connect - ;; to the database called "test" under the user postgress - ;; with the psql console first. Then study the authorization - ;; and configuration files. - :initform '("localhost.localdomain" "test" "postgres" "")) - (db :accessor controller-db :initarg :db :initform nil)) + ((db :accessor controller-db :initarg :db :initform nil)) (: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. This is the Postgresql-specific subclass of store-controller.")) -(defmethod build-btree ((sc sql-store-controller)) - (make-sql-btree sc)) +(eval-when (:compile-toplevel :load-toplevel) + (register-backend-con-init :clsql 'sql-test-and-construct)) + +(defun sql-test-and-construct (spec) + "Entry function for making SQL backend controllers" + (if (sql-store-spec-p spec) + (make-instance 'sql-store-controller + :spec (if spec spec + '("localhost.localdomain" "test" "postgres" ""))) + (error (format nil "uninterpretable path/spec specifier: ~A" spec)))) (defun sql-store-spec-p (spec) (and (listp spec) (eq (first spec) :clsql))) -(defun sql-test-and-construct (spec) - (if (sql-store-spec-p spec) - (open-store-sql spec) - nil)) - -(eval-when (:load-toplevel) - (register-backend-con-init :clsql 'sql-test-and-construct)) +;; +;; Controller Indices +;; -(defmacro with-open-store-sql ((spec) &body body) - "Executes the body with an open controller, -unconditionally closing the controller on exit." - `(let ((*store-controller* - (make-instance 'sql-store-controller :dbconnection-spec ,spec))) - (declare (special *store-controller*)) - (open-controller *store-controller*) - (unwind-protect - (progn ,@body) - (close-controller *store-controller*)))) - -(defun open-store-sql (spec &key (recover nil) - (recover-fatal nil) (thread t)) - "Conveniently open a store controller." - (setq *store-controller* - (if (sql-store-spec-p spec) - (make-instance 'sql-store-controller :dbconnection-spec spec) - (error (format nil "uninterpretable path/spec specifier: ~A" spec))) - ) - (open-controller *store-controller* :recover recover - :recover-fatal recover-fatal :thread thread) - ) ;; When you build one of these, you have to put in the connection spec. -(defclass sql-btree (btree) - ( - ) +(defclass sql-btree (btree) () (:documentation "A SQL implementation of a BTree")) +(defmethod build-btree ((sc sql-store-controller)) + (make-instance 'sql-btree :sc sc) + ) + (defmethod get-value (key (bt sql-btree)) (let* ((sc (get-con bt)) (con (controller-db sc))) - (sql-get-from-clcn (oid bt) key sc con))) - + (sql-get-from-clcn (oid bt) key sc con) + ) + ) -(defmethod existsp (key (bt sql-btree)) +(defmethod (setf get-value) (value key (bt sql-btree)) (let* ((sc (get-con bt)) (con (controller-db sc))) - (sql-from-clcn-existsp (oid bt) key con) + (sql-add-to-clcn (oid bt) key value sc con) ) ) -(defmethod (setf get-value) (value key (bt sql-btree)) +(defmethod existsp (key (bt sql-btree)) (let* ((sc (get-con bt)) (con (controller-db sc))) - (sql-add-to-clcn (oid bt) key value sc con) + (sql-from-clcn-existsp (oid bt) key con) ) ) + (defmethod remove-kv (key (bt sql-btree)) (let* ((sc (get-con bt)) (con (controller-db sc))) @@ -125,40 +109,47 @@ ;; directly into the class above. I am not sure how best to ;; handle this problem. (defclass sql-indexed-btree (indexed-btree sql-btree ) - ( - (indices :accessor indices :initform (make-hash-table) - ) + ((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 SQL-based BTree that supports secondary indices.")) +(defmethod shared-initialize :after ((instance sql-indexed-btree) slot-names + &rest rest) + (declare (ignore slot-names rest)) + (setf (indices-cache instance) (indices instance))) + (defmethod build-indexed-btree ((sc sql-store-controller)) - (let ((bt (make-instance 'sql-indexed-btree :sc sc))) - (setf (:dbcn-spc-pst bt) (:dbcn-spc sc)) - bt - )) + (make-instance 'sql-indexed-btree :sc sc)) (defmethod build-btree-index ((sc sql-store-controller) &key primary key-form) - (let ((bt (make-instance 'sql-btree-index :primary primary :key-form key-form :sc sc))) - (setf (:dbcn-spc-pst bt) (:dbcn-spc sc)) - bt - )) + (make-instance 'sql-btree-index :primary primary :key-form key-form :sc sc)) -;; I need some way to get to the store-controller here... -;; I could be the store controller in the hash table, that's probably -;; the simplest thing to do.. +;; ISE NOTE: Much of the index management functionality is common between +;; bdb and sql - we could lift this along with indices and indices-cache +;; up to the main elephant code base and introduce a new update-index +;; generic function to handle the backend specific method for updating +(defmethod map-indices (fn (bt sql-indexed-btree)) + (maphash fn (indices-cache bt))) + +(defmethod get-index ((bt sql-indexed-btree) index-name) + (gethash index-name (indices-cache bt))) + +(defmethod remove-index ((bt sql-indexed-btree) index-name) + (remhash index-name (indices-cache bt)) + (let ((indices (indices bt))) + (remhash index-name indices) + (setf (indices bt) indices))) + (defmethod add-index ((bt sql-indexed-btree) &key index-name key-form populate) (let* ((sc (get-con bt)) - (con (controller-db sc))) + (con (controller-db sc))) (if (and (not (null index-name)) (symbolp index-name) (or (symbolp key-form) (listp key-form))) (let ((indices (indices bt)) - (index (make-instance 'sql-btree-index :primary bt - :key-form key-form - :sc sc))) + (index (build-btree-index sc :primary bt :key-form key-form))) (setf (gethash index-name (indices-cache bt)) index) (setf (gethash index-name indices) index) (setf (indices bt) indices) @@ -190,6 +181,7 @@ (with-transaction (:store-controller sc) (maphash #'(lambda (k index) + (declare (ignore k)) (multiple-value-bind (index? secondary-key) (funcall (key-fn index) index key value) (when index? @@ -216,6 +208,7 @@ (let ((indices (indices-cache bt))) (maphash #'(lambda (k index) + (declare (ignore k)) (multiple-value-bind (index? secondary-key) (funcall (key-fn index) index key value) (when index? @@ -237,7 +230,6 @@ value)))) - (defclass sql-btree-index (btree-index sql-btree) () (:metaclass persistent-metaclass) @@ -290,8 +282,9 @@ ;; apparently in postgres this is failing pretty awfully because ;; sequence-exists-p return nil and then we get an error that the sequence exists! ;; (unless (sequence-exists-p [persistent_seq]) - (clsql::create-sequence [persistent_seq] - :database con) + (clsql::create-sequence [persistent_seq] :database con) + ;; Leave room for root and class-root + (clsql::set-sequence-position [persistent_seq] 2 :database con) ;;) ;; (unless (index-exists-p [idx_clctn_id]) (clsql::create-index [idx_clctn_id] :on [keyvalue] @@ -311,16 +304,16 @@ ;;) ) - (defmethod open-controller ((sc sql-store-controller) ;; At present these three have no meaning &key (recover nil) (recover-fatal nil) (thread t)) + (declare (ignore recover recover-fatal thread)) (the sql-store-controller - (let* ((dbtype (car (second (:dbcn-spc sc)))) - (con (clsql:connect (cdr (second (:dbcn-spc sc))) + (let* ((dbtype (car (second (controller-spec sc)))) + (con (clsql:connect (cdr (second (controller-spec sc))) ;; WARNING: This line of code forces us to use postgresql. ;; If this were parametrized upwards we could concievably try ;; other backends. @@ -328,7 +321,6 @@ ;; DNK :postgresql ;; :database-type :postgresql :if-exists :old))) - (setf (gethash (:dbcn-spc sc) *dbconnection-spec*) sc) (setf (slot-value sc 'db) con) ;; Now we should make sure that the KEYVALUE table exists, and, if ;; it does not, we need to create it.. @@ -336,32 +328,22 @@ ;; can put it in a function.... (unless (keyvalue-table-exists con) (create-keyvalue-table con)) - (setf (slot-value sc 'root) (build-btree sc)) - (setf (slot-value sc 'class-root) (build-indexed-btree sc)) - ;; Actaully, it would seem here that we must further set the oid - ;; of the root tree to 0 to ensure that we read the correct thing - ;; when we next opent he controller... - (setf (oid (slot-value sc 'root)) 0) + ;; These should get oid 0 and 1 respectively + (setf (slot-value sc 'root) (make-instance 'sql-btree :sc sc :from-oid 0)) + (setf (slot-value sc 'class-root) (make-instance 'sql-indexed-btree :sc sc :from-oid 1)) sc) ) ) -(defun make-sql-btree (sc) - (let ((bt (make-instance 'sql-btree :sc sc))) - (setf (:dbcn-spc-pst bt) (:dbcn-spc sc)) - bt) - ) - (defmethod close-controller ((sc sql-store-controller)) (when (slot-value sc 'db) - ;; close the conneciton + ;; close the connection ;; (actually clsql has pooling and other complications, I am not sure ;; that this is complete.) (clsql:disconnect :database (controller-db sc)) (setf (slot-value sc 'root) nil) )) - ;; Because this is part of the public ;; interface that I'm tied to, it has to accept a store-controller... (defmethod next-oid ((sc sql-store-controller )) @@ -370,7 +352,6 @@ :database con)) ) - ;; if add-to-root is a method, then we can make it class dependent... ;; otherwise we have to change the original code. There is ;; almost no way to implement this without either changing the existing @@ -379,15 +360,14 @@ ;; a proper method myself, but I will give it a name so it doesn't ;; conflict with 'add-to-root. 'add-to-root can remain a convenience symbol, ;; that will end up calling this routine! -(defmethod sql-add-to-root (key value (pgsc sql-store-controller ) con) +(defun sql-add-to-root (key value pgsc con) (sql-add-to-clcn 0 key value pgsc con) ) -;;(defmethod sql-add-to-root (key value dbcon) -;; (sql-add-to-clcn 0 key value sc dbcon) -;; ) -(defmethod sql-add-to-clcn ((clcn integer) key value sc con +(defun sql-add-to-clcn (clcn key value sc con &key (insert-only nil)) + (declare (ignore sc)) + (assert (integerp clcn)) (let ( (vbs (serialize-to-base64-string value)) @@ -411,9 +391,9 @@ ) - -(defmethod sql-get-from-root (key sc con) - (sql-get-from-clcn 0 key sc con)) +(defun sql-get-from-root (key sc con) + (sql-get-from-clcn 0 key sc con) + ) ;; This is a major difference betwen SQL and BDB: ;; BDB plans to give you one value and let you iterate, but @@ -431,10 +411,13 @@ ;; To do that I have to read in all of the values and deserialized them ;; This could be a good reason to keep the oids out, and separte, in ;; a separate column. -(defmethod sql-get-from-clcn ((clcn integer) key sc con) +(defun sql-get-from-clcn (clcn key sc con) + (assert (integerp clcn)) (sql-get-from-clcn-nth clcn key sc con 0) ) -(defmethod sql-get-from-clcn-nth ((clcn integer) key sc con (n integer)) + +(defun sql-get-from-clcn-nth (clcn key sc con n) + (assert (and (integerp clcn) (integerp n))) (let* ( (kbs (serialize-to-base64-string key)) @@ -463,7 +446,8 @@ t) (values nil nil)))) -(defmethod sql-get-from-clcn-cnt ((clcn integer) key con) +(defun sql-get-from-clcn-cnt (clcn key con) + (assert (integerp clcn)) (let* ( (kbs (serialize-to-base64-string key)) (tuples @@ -474,7 +458,8 @@ ))) (caar tuples))) -(defmethod sql-dump-clcn ((clcn integer) sc con) +(defun sql-dump-clcn (clcn sc con) + (assert (integerp clcn)) (let* ( (tuples (clsql::select [key] [value] @@ -485,11 +470,12 @@ (mapcar #'(lambda (x) (mapcar #'(lambda (q) (deserialize-from-base64-string q :sc sc)) x)) tuples))) -(defmethod sql-from-root-existsp (key con) +(defun sql-from-root-existsp (key con) (sql-from-clcn-existsp 0 key con) ) -(defmethod sql-from-clcn-existsp ((clcn integer) key con) +(defun sql-from-clcn-existsp (clcn key con) + (assert (integerp clcn)) (let* ( (kbs (with-buffer-streams (out-buf) (serialize-to-base64-string key)) @@ -505,11 +491,14 @@ nil) )) -(defmethod sql-remove-from-root (key sc con) +(defun sql-remove-from-root (key sc con) [53 lines skipped]

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 19 Feb '06

19 Feb '06

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv25268/tests Modified Files: elephant-tests.lisp Log Message: New build process completed & tested for BDB --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/19 04:53:02 1.14 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/19 17:25:53 1.15 @@ -93,7 +93,7 @@ ;; ;; 1) Set *default-spec* to the above spec of your choice ;; 2) Call (do-backend-tests) to test the standard API -;; 3) To test migration: (do-migration *default-spec* <second-spec>) inserting a second +;; 3) To test migration: (do-migration-tests *default-spec* <second-spec>) inserting a second ;; spec, typically a bdb spec or create another instance of a sql db depending on ;; your configuration ;; 4) A backend is green if it passes do-backend-tests and can succesfully be

1 0

[elephant-cvs] CVS elephant
by ieslick 19 Feb '06

19 Feb '06

Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv25268 Modified Files: INSTALL Makefile ele-bdb.asd Log Message: New build process completed & tested for BDB --- /project/elephant/cvsroot/elephant/INSTALL 2006/02/15 01:54:07 1.14 +++ /project/elephant/cvsroot/elephant/INSTALL 2006/02/19 17:25:52 1.15 @@ -26,9 +26,28 @@ A C compiler, probably gcc or Visual Studio. Presumably you have this if you installed Sleepycat. ------------- -Instructions ------------- +------------------ +Short Instructions +------------------ + +The new build system should work out of the box on most Un*x +platforms that have asdf, uffi and either clsql or Berkeley DB +installed in the usual places. + +Try: (asdf:operate 'asdf:load-op :elephant) +Then: (open-store '(<backend> <spec>)) + +Where <backend> = { :bdb | :clsql } + <spec> = { '(:sqlite3 "db path") | '(:postgresql "db path") | "bdb directory" } + +This should load all files, including compiling libraries, on +most systems. For Win32, see the instructions below. + +(We'll improve the build process for Win32 if there is demand) + +----------------- +Long Instructions +----------------- I assume you have a supported lisp with asdf. @@ -36,58 +55,69 @@ /usr/local/share/common-lisp/elephant-0.3/ + 1) Install UFFI. If you're using 1.4.24 replace -path-to-uffi/src/functions.lisp + path-to-uffi/src/functions.lisp + + with the provided file. -with the provided file. -2) Install a backend: Either Berkeley DB 4.3, PostGresql, or SQLite 3. +2) Install ASDF. + +Ensure that you have a recent version of ASDF installed as +the load process now depends upon it. + + +3) Install a backend: Either Berkeley DB 4.3, PostGresql, or SQLite 3. + +------- +SQL +------- For relational database systems, refering the formal documentation other the heading "SQL-BACK-END". -For Berkeley 4.3: -Under Un*x, you may actually -already have this installed, though it may be compiled with -funny options, so if things don't work you may want to try -to start from scratch. FreeBSD has a port for this, as I'm -sure do other BSDs (including Darwin/Fink.) Take note of -where libdb.so and db.h are installed (usually -/usr/local/BerekleyDB.4.3/lib/libdb.so and -/usr/local/BerekleyDB.4.3/include/db.h, or -/usr/local/lib/db42/libdb.so and -/usr/local/include/db42/db.h.) +------------- +Berkeley 4.3: +------------- -Compile and install the libsleepycat shared library. +Under Un*x, you may actually already have this installed, though +it may be compiled with funny options, so if things don't work +you may want to try to start from scratch. FreeBSD has a port +for this, as I'm sure do other BSDs (including Darwin/Fink.) +Take note of where libdb.so and db.h are installed, usually: -Under Un*x, edit Makefile and run (using GNU make, gmake on -BSD) + /usr/local/BerekleyDB.4.3/lib/libdb.so and + /usr/local/BerekleyDB.4.3/include/db.h, or -make + /usr/local/lib/db42/libdb.so and + /usr/local/include/db42/db.h.) -This compiles src/libsleepycat.c and installs it into +a) Edit Makefile variable DB43DIR and DB43INC, DB43LIB if necessary -/usr/local/share/common-lisp/elephant-0.3/ +This makes sure that the build process can find your files. +You can test that the build works by calling: -You probably have to make sure this directory exists before running -make install. +'make bdb'. -If you need to change this path, you will change it in the Makefile -and also in controller.lisp on the line: +b) Also edit the variable *sleepycat-foreign-library-path* in -(defvar *elephant-lib-path* "/usr/local/share/common-lisp/elephant-0.3/") + ele-bdb.asd -or where you specified. On Darwin / OS X you need to have -the developer tools installed. In the Makefile and other places -there are commented-out lines showing settings that some users have used for -OS X; if you are using that I assume you will have to comment out the -appropriate lines and uncomment those examples. +to point to your local distribution of the Berkeley DB libraries -For Win32 (directions courtesy of Bill Clementson): +Darwin / OS X +--------------- +You need to have the developer tools installed. In the Makefile and +ele-bdb.lib there are commented-out lines showing settings that some +users have used for OS X; if you are using that I assume you will +have to comment out the appropriate lines and uncomment those examples. -Create an MSVC dll project and add src/libsleepycat.c, -src/libsleepycat.def and the Berkeley DB libdb43.lib files +For Win32 (directions courtesy of Bill Clementson): +--------------------------------------------------- +Create an MSVC dll project and add src/db-bdb/libsleepycat.c, +src/db-bdb/libsleepycat.def and the Berkeley DB libdb43.lib files to the project (should be in the build_win32/release folder) Add the Berkeley DB dbinc include files directory and the @@ -101,15 +131,28 @@ libsleepycat.c, it may or may not be necessary to load libdb43.dll into Lisp (see below.) -3) Compile and load Elephant: -First, edit src/sleepycat.lisp so that it points to the -correct libraries. If you're using Un*x and ASDF, this is -probably automagic. - -Symlink elephant.asd to your asdf systems directory (mine is -/usr/local/share/common-lisp/systems). Fire up lisp and -depending on your database backend: +4) Compile and load Elephant: + +The new backend load process should work automatically on Un*x +systems but if there are problems with loading foreign libraries, +then you can test your C tools setup with 'make' in the elephant +root directory. This will build the common memutils library +in src/memutil/libmemutil.so/dylib that all backends require. + +There is a new two-phase load process. The first requires that +you use asdf to load the main elephant front-end: + +(asdf:operate 'asdf:load-op :elephant) + +This will load and compile Elephant. This will also automatically +load UFFI. + +When you call (open-store <spec>) inside lisp it will automatically +load the remaining dependencies for the specified backend via ASDF. + +To test the load process explicitly the following asdf files are +provided: if you are using Sleepycat / Berkeley DB, type: (asdf:operate 'asdf:load-op :ele-bdb) @@ -120,16 +163,8 @@ if you are using SQLite3, type: (asdf:operate 'asdf:load-op :ele-sqlite3) -This will load and compile Elephant. This will also -automatically load UFFI. -I can't seem to make OpenMCL not intern default keyword -values of my macros -- something which doesn't happen on -other implementations. I can't reproduce the issue except -for in my code, but expect (use-package "ELE")'s to produce -conflicting symbol warnings. - -4) Make the documentation: +5) Make the documentation: Execute: @@ -137,6 +172,7 @@ In the doc directory should be build the HTML version of the texinfo files. + ------- Testing ------- @@ -145,16 +181,29 @@ http://www.cliki.net/RT -Once RT is installed, edit tests/elephant-tests.lisp to make -*testdb-path* point to somewhere appropriate. Symlink -elephant-tests.asd to your asdf systems directory, then run +Once RT is installed (asdf:operate 'asdf:load-op :elephant-tests) (in-package :ele-tests) -(do-all-tests) +(setf *default-spec* <backend>) + where <backend> = { *testsqlite3-spec* | *testpg-spec* | *testbdb-spec* } +(do-backend-tests) + +This will test the standalone API for your backend. Currently all tests are +passing on 0.6.0. There will be a set of migration tests that will be 'ignored' +but the final message should indicate no failing tests. + +This should take less than 5 minutes on decent hardware. + +Elephant allows migration between repositories. To test this: + +(do-migration-tests *default-spec* <backend>) + where <backend> is a different *testXXXXX-spec* variable to test migration + to that backend. + +This should take less than 2 minutes on decent hardware. + +A backend is considered "green" if it can pass both the backend tests and the +migration tests. -this should take about 5 minutes on decent hardware. Note -that the "no-eval-initform" and "update-class" tests fail, -these are known bugs which will get fixed in a future -release. --- /project/elephant/cvsroot/elephant/Makefile 2006/02/19 16:22:39 1.10 +++ /project/elephant/cvsroot/elephant/Makefile 2006/02/19 17:25:52 1.11 @@ -49,7 +49,7 @@ BDBSRC=src/db-bdb -bdb: libsleepycat.$(EXT) +bdb: $(BDBSRC)/libsleepycat.$(EXT) $(BDBSRC)/libsleepycat.$(EXT): $(BDBSRC)/libsleepycat.c gcc $(SHARED) -Wall -L$(DBLIBDIR) -I$(DBINCDIR) -fPIC -O3 -o $@ $< -ldb -lm --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/02/19 04:52:58 1.6 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/02/19 17:25:52 1.7 @@ -23,6 +23,82 @@ (in-package :ele-bdb-system) +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; We need this dependency satisfied to compute what to do for C files + (unless (find-package 'uffi) + (asdf:operate 'asdf:load-op 'uffi))) + +;; +;; EDIT ME FOR YOUR SYSTEM +;; +;; An attempt at good defaults is here. We should +;; later add a search function that users can add to +;; so they don't have to edit source +;; + +(defparameter *sleepycat-foreign-library-path* + ;; Sleepycat: this works on linux + #+linux +;; "/db/ben/lisp/db43/lib/libdb.so" + "/usr/local/BerkeleyDB.4.3/lib/libdb-4.3.so" + ;; this works on FreeBSD + #+(and (or bsd freebsd) (not (or darwin macosx))) + "/usr/local/lib/db43/libdb.so" + #+(or darwin macosx) + ;; for Fink (OS X) -- but I will assume Linux more common... +;; "/sw/lib/libdb-4.3.dylib" + ;; a possible manual install + "/usr/local/BerkeleyDB.4.3/lib/libdb.dylib") + +(defclass bdb-c-source (c-source-file) + ()) + +(defparameter *root-dir* (pathname-directory *load-truename*)) + +(defparameter *library-file-dir* (append (pathname-directory *load-truename*) + (list "src" "db-bdb"))) + +;; Compile foreign library on non-win32 platforms + +(defmethod output-files ((o compile-op) (c bdb-c-source)) + (let ((library-file-type + (funcall (intern (symbol-name '#:default-foreign-library-type) + (symbol-name '#:uffi))))) + (list (make-pathname :name (component-name c) + :type library-file-type + :directory *library-file-dir*)))) + +(defmethod perform ((o compile-op) (c bdb-c-source)) + (unless (operation-done-p o c) + #-(or win32 windows) + (unless (zerop (uffi:run-shell-command + (format nil + #-freebsd "cd ~A; make bdb" + #+freebds "cd ~A; gmake bdb" + (make-pathname :directory *root-dir*)))) + (format t "Couldn't build library from libsleepycat.c via 'make bdb'~%") + (error 'operation-error :component c :operation o)))) + +(defmethod operation-done-p ((o compile-op) (c bdb-c-source)) + (or (let ((lib (make-pathname :defaults (component-pathname c) + :type (uffi:default-foreign-library-type)))) + (and (probe-file lib) (probe-file (component-pathname c)) + (> (file-write-date lib) (file-write-date (component-pathname c))))))) + +;; Load op - ensure that foreign library is loaded + +(defmethod perform ((o load-op) (c bdb-c-source)) + "Nothing to do!" + t) + +(defmethod operation-done-p ((o load-op) (c bdb-c-source)) + "Operation is done when the foreign library is loaded which should + happen when we compile the interface lisp file" + (and (symbol-function (intern (symbol-name '#:%db-strerror) + (find-package '#:sleepycat))) + t)) + + (defsystem ele-bdb :name "elephant" :author "Ben Lee <blee(a)common-lisp.net>" @@ -37,6 +113,7 @@ ((:module :db-bdb :components ((:file "package") + (:bdb-c-source "libsleepycat") (:file "sleepycat") (:file "bdb-controller") (:file "bdb-transactions")

1 0