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

[elephant-cvs] CVS elephant/src/elephant
by ieslick 26 Apr '06

26 Apr '06

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv9359/src/elephant Modified Files: classindex.lisp serializer.lisp Log Message: Corrections for SBCL serialization and index testing. --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/04/26 19:19:12 1.10 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/04/26 21:41:24 1.11 @@ -423,14 +423,28 @@ (next-in-range skey (cons val nil)) nil))))) + +(defmacro do-subsets ((subset subset-size list) &body body) + (let ((place (gensym)) + (i (gensym))) + `(let ((,place ,list) + (,subset nil)) + (loop while ,place do + (setf ,subset nil) + (loop for ,i from 1 upto ,subset-size do + (if (null ,place) (return) + (push (pop ,place) ,subset))) + ,@body)))) + (defun drop-instances (instances &key (sc *store-controller*)) (when instances - (assert (and (consp instances) (< (length instances) 500))) - (with-transaction (:store-controller sc) - (mapc (lambda (instance) - (remove-kv (oid instance) (find-class-index (class-of instance))) - (drop-pobject instance)) - instances)))) - + (assert (consp instances)) + (do-subsets (subset 500 instances) + (with-transaction (:store-controller sc) + (mapc (lambda (instance) + (remove-kv (oid instance) (find-class-index (class-of instance))) + (drop-pobject instance)) + subset))))) + --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/04/26 17:53:44 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/04/26 21:41:24 1.4 @@ -84,8 +84,7 @@ (string +ucs2-symbol+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase s - (base-string #+sbcl +ucs4-symbol+ #+lispworks +ucs2-symbol+ ) - ;; +ucs1-symbol+) + (base-string +ucs1-symbol+) (string #+sbcl +ucs4-symbol+ #+lispworks +ucs2-symbol+)) #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) +ucs1-symbol+ @@ -105,8 +104,7 @@ (string +ucs2-string+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase frob - (base-string #+sbcl +ucs4-string+ #+lispworks +ucs2-string+ ) - ;; +ucs1-string+ + (base-string +ucs1-string+) (string #+sbcl +ucs4-string+ #+lispworks +ucs2-string+)) #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) +ucs1-string+ @@ -148,8 +146,7 @@ (string +ucs2-pathname+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase s - (base-string #+sbcl +ucs4-pathname+ #+lispwoks +ucs2-pathname+ ) - ;; +ucs1-pathname+ + (base-string +ucs1-pathname+) (string #+sbcl +ucs4-pathname+ #+lispwoks +ucs2-pathname+)) #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) +ucs1-pathname+ @@ -482,8 +479,8 @@ (eval-when (:compile-toplevel :load-toplevel) - (asdf:operate 'asdf:load-op :cl-base64) -) + (asdf:operate 'asdf:load-op :cl-base64)) + (defun ser-deser-equal (x1 &key sc) (let* ( (x1s (serialize-to-base64-string x1))

1 0

[elephant-cvs] CVS elephant/src/memutil
by ieslick 26 Apr '06

26 Apr '06

Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv9359/src/memutil Modified Files: memutil.lisp Log Message: Corrections for SBCL serialization and index testing. --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/04/26 17:53:45 1.5 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/04/26 21:41:24 1.6 @@ -56,10 +56,6 @@ #:*c-library-extension* )) -;; --REMOVE HACK-- -(defpackage elephant - (:use :cl)) - (in-package "ELEPHANT-MEMUTIL") #+cmu @@ -332,8 +328,7 @@ (string (excl:native-string-sizeof ,s :external-format :unicode))) #+(or (and sbcl sb-unicode) lispworks) `(etypecase ,s - (base-string (* (length ,s) #+sbcl 4 #+lispworks 2) ) - ;; (length ,s))) + (base-string (length ,s)) (string (* (length ,s) #+sbcl 4 #+lispworks 2))) #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) `(length ,s)) @@ -592,6 +587,7 @@ (incf (buffer-stream-position bs)) (deref-array (buffer-stream-buffer bs) '(:array :unsigned-byte) position))) + (defun buffer-read-byte-vector (bs) "Read the whole buffer into byte vector." (declare (optimize (speed 3) (safety 0))

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 26 Apr '06

26 Apr '06

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv22948/tests Modified Files: testmigration.lisp Log Message: Fix for a problem during migration of persistent classes from one store to another. 0.6.0 is clean for BDB/Allegro on Mac OS X --- /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/04/26 17:53:45 1.12 +++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/04/26 19:19:12 1.13 @@ -171,12 +171,14 @@ (unwind-protect ;; ensure class index is initialized in sc1 (progn + (with-transaction (:store-controller sc2) + (remove-kv 'ipfoo (elephant::controller-class-root sc2))) (setf (elephant::%index-cache (find-class 'ipfoo)) nil) (find-class-index 'ipfoo :sc sc1) (format t "Making objects~%") - (with-transaction (:store-controller sc2) - (drop-instances (get-instances-by-class 'ipfoo) :sc sc2)) - (with-transaction (:store-controller sc1) +;; (with-transaction (:store-controller sc2) +;; (drop-instances (get-instances-by-class 'ipfoo) :sc sc2)) + (with-transaction (:store-controller sc1 :retries 2) (drop-instances (get-instances-by-class 'ipfoo) :sc sc1) (make-instance 'ipfoo :slot1 1 :sc sc1) (make-instance 'ipfoo :slot1 10 :sc sc1)

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 26 Apr '06

26 Apr '06

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv22948/src/db-bdb Modified Files: bdb-collections.lisp bdb-transactions.lisp Log Message: Fix for a problem during migration of persistent classes from one store to another. 0.6.0 is clean for BDB/Allegro on Mac OS X --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/04/26 17:53:44 1.6 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/04/26 19:19:12 1.7 @@ -159,7 +159,7 @@ (serialize key key-buf) (serialize value value-buf) (with-transaction (:store-controller sc) - (db-put-buffered (controller-btrees sc) + (db-put-buffered (controller-btrees sc) key-buf value-buf) (loop for index being the hash-value of indices do --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2006/02/20 21:21:41 1.2 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2006/04/26 19:19:12 1.3 @@ -44,8 +44,8 @@ (let ((result (let ((*current-transaction* txn) (*auto-commit* nil)) - (declare (special *current-transaction* *auto-commit*) - (dynamic-extent *current-transaction* *auto-commit*)) + (declare (special *current-transaction* *auto-commit*)) +;; (dynamic-extent *current-transaction* *auto-commit*)) (catch 'transaction (unwind-protect (prog1

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 26 Apr '06

26 Apr '06

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv22948/src/elephant Modified Files: classindex.lisp Log Message: Fix for a problem during migration of persistent classes from one store to another. 0.6.0 is clean for BDB/Allegro on Mac OS X --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/04/26 17:53:44 1.9 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/04/26 19:19:12 1.10 @@ -425,7 +425,7 @@ (defun drop-instances (instances &key (sc *store-controller*)) (when instances - (assert (consp instances)) + (assert (and (consp instances) (< (length instances) 500))) (with-transaction (:store-controller sc) (mapc (lambda (instance) (remove-kv (oid instance) (find-class-index (class-of instance)))

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 26 Apr '06

26 Apr '06

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv12311/tests Modified Files: testindexing.lisp testmigration.lisp Log Message: Significant additions to the 0.6.0 release on the trunk. Updates to documentation, 0.5.0 compliance, final on 0.6.0 features. There are one or two BDB interactions on migration to work out but this should be a nearly code complete 0.6.0 release. Please start testing and evaluating this - especially the ability to open and tag 0.5.0 databases. Features: - Database version tagging - Support for 0.5.0 namespaces & databases - New migration system - class indexing without slot indexing - various bug fixes - reverted fast allegro/sbcl string support to allow 0.5.0 databases to work correctly. I couldn't find a good way to work around this without creating infinite headaches - validated that running db_deadlock will stop all lisp freezes that I've encountered. This has to be run each time a DB environment is opened/created so eventually should be made part of the open-controller functionality for the BDB backend --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/03/01 18:57:34 1.15 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/04/26 17:53:45 1.16 @@ -209,7 +209,8 @@ (values (eq (length r1) 1) (signals-error (get-instances-by-value 'idx-five-del 'slot1 1)) - (null (get-value 'idx-five-del (elephant::controller-class-root *store-controller*)))))) + (null (get-index (get-value 'idx-five-del (elephant::controller-class-root *store-controller*)) + 'slot1))))) t t t) (deftest indexing-reconnect-db @@ -368,24 +369,24 @@ ;; create 500 objects, write each object's slots +(defvar normal-index nil) + (defclass stress-normal () ((stress1 :accessor stress1 :initarg :stress1 :initform nil :index nil) (stress2 :accessor stress2 :initarg :stress2 :initform nil :index nil)) (:metaclass persistent-metaclass)) +(defun normal-stress-setup (count class-name &rest inst-args) + (setf normal-index (make-btree)) + (dotimes (i count) + (setf (get-value i normal-index) (apply #'make-instance class-name :stress1 i inst-args)))) + (defclass stress-index () ((stress1 :accessor stress1 :initarg :stress1 :initform nil :index t) (stress2 :accessor stress2 :initarg :stress2 :initform 2 :index t) (stress3 :accessor stress3 :initarg :stress3 :initform 3 :index nil)) (:metaclass persistent-metaclass)) -(defvar normal-index nil) - -(defun normal-stress-setup (count class-name &rest inst-args) - (setf normal-index (make-btree)) - (dotimes (i count) - (setf (get-value i normal-index) (apply #'make-instance class-name :stress1 i inst-args)))) - (defun indexed-stress-setup (count class-name &rest inst-args) (dotimes (i count) (apply #'make-instance class-name :stress1 i inst-args))) --- /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/03/07 14:12:22 1.11 +++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/04/26 17:53:45 1.12 @@ -13,14 +13,6 @@ (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*)) @@ -173,14 +165,15 @@ ;; (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*)) + (sc1 (open-store *test-spec-primary* :recover t)) + (*store-controller* nil)) + (declare (special *auto-commit* *store-controller*)) (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~%") + (format t "Making objects~%") (with-transaction (:store-controller sc2) (drop-instances (get-instances-by-class 'ipfoo) :sc sc2)) (with-transaction (:store-controller sc1) @@ -188,12 +181,12 @@ (make-instance 'ipfoo :slot1 1 :sc sc1) (make-instance 'ipfoo :slot1 10 :sc sc1) (make-instance 'ipfoo :slot1 20 :sc sc1)) -;; (format t "Migrating~%") + (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~%") + (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))

1 0

[elephant-cvs] CVS elephant/src/memutil
by ieslick 26 Apr '06

26 Apr '06

Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv12311/src/memutil Modified Files: memutil.lisp Log Message: Significant additions to the 0.6.0 release on the trunk. Updates to documentation, 0.5.0 compliance, final on 0.6.0 features. There are one or two BDB interactions on migration to work out but this should be a nearly code complete 0.6.0 release. Please start testing and evaluating this - especially the ability to open and tag 0.5.0 databases. Features: - Database version tagging - Support for 0.5.0 namespaces & databases - New migration system - class indexing without slot indexing - various bug fixes - reverted fast allegro/sbcl string support to allow 0.5.0 databases to work correctly. I couldn't find a good way to work around this without creating infinite headaches - validated that running db_deadlock will stop all lisp freezes that I've encountered. This has to be run each time a DB environment is opened/created so eventually should be made part of the open-controller functionality for the BDB backend --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/02/19 20:06:04 1.4 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/04/26 17:53:45 1.5 @@ -56,6 +56,10 @@ #:*c-library-extension* )) +;; --REMOVE HACK-- +(defpackage elephant + (:use :cl)) + (in-package "ELEPHANT-MEMUTIL") #+cmu @@ -323,11 +327,13 @@ #+(and allegro ics) ;; old: `(let ((l (length ,s))) (+ l l)) `(etypecase ,s - (base-string (length ,s)) + (base-string (excl:native-string-sizeof ,s :external-format :unicode)) + ;; fast 0.6.1 (length ,s) (string (excl:native-string-sizeof ,s :external-format :unicode))) #+(or (and sbcl sb-unicode) lispworks) `(etypecase ,s - (base-string (length ,s)) + (base-string (* (length ,s) #+sbcl 4 #+lispworks 2) ) + ;; (length ,s))) (string (* (length ,s) #+sbcl 4 #+lispworks 2))) #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) `(length ,s)) @@ -570,10 +576,11 @@ (resize-buffer-stream bs needed)) ;; I wonder if the basic problem here is that we are using this ;; routine instead of something like "copy-ub8-from-system-area"? -;; #-allegro + #-allegro (copy-str-to-buf buf size s 0 str-bytes) -;; #+allegro -;; (excl:string-to-native s :address (offset-char-pointer buf size) :external-format :unicode) + #+allegro + (excl:string-to-native s :address (offset-char-pointer buf size) :external-format :unicode) + ;; v0.6.0 (copy-str-to-buf buf size s 0 str-bytes) (setf size needed) nil)))

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 26 Apr '06

26 Apr '06

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv12311/src/elephant Modified Files: classes.lisp classindex-utils.lisp classindex.lisp collections.lisp controller.lisp metaclasses.lisp migrate.lisp serializer.lisp transactions.lisp variables.lisp Added Files: package.lisp Removed Files: elephant.lisp Log Message: Significant additions to the 0.6.0 release on the trunk. Updates to documentation, 0.5.0 compliance, final on 0.6.0 features. There are one or two BDB interactions on migration to work out but this should be a nearly code complete 0.6.0 release. Please start testing and evaluating this - especially the ability to open and tag 0.5.0 databases. Features: - Database version tagging - Support for 0.5.0 namespaces & databases - New migration system - class indexing without slot indexing - various bug fixes - reverted fast allegro/sbcl string support to allow 0.5.0 databases to work correctly. I couldn't find a good way to work around this without creating infinite headaches - validated that running db_deadlock will stop all lisp freezes that I've encountered. This has to be run each time a DB environment is opened/created so eventually should be made part of the open-controller functionality for the BDB backend --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/03/01 18:57:34 1.8 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/04/26 17:53:44 1.9 @@ -45,6 +45,28 @@ ;; METACLASS INITIALIZATION AND CHANGES ;; ================================================ +(defmethod ensure-class-using-class :around ((class (eql nil)) name &rest args &key index) + "Support the :index class option" + (let ((result (apply #'call-next-method class name (remove-index-keyword args)))) + (when (and index (subtypep (type-of result) 'persistent-metaclass)) + (update-indexed-record result nil :class-indexed t)) + result)) + +(defmethod ensure-class-using-class :around ((class persistent-metaclass) name &rest args &key index) + "Support the :index class option on redefinition" + (let ((result (apply #'call-next-method class name (remove-index-keyword args)))) + (when index + (update-indexed-record result nil :class-indexed t)) + result)) + +(defun remove-index-keyword (list) + (cond ((null list) + nil) + ((eq (car list) :index) + (cddr list)) + (t + (cons (car list) (remove-index-keyword (cdr list)))))) + (defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses) "Ensures we inherit from persistent-object." (let* ((persistent-metaclass (find-class 'persistent-metaclass)) @@ -58,14 +80,13 @@ (call-next-method)))) (defmethod finalize-inheritance :around ((instance persistent-metaclass)) - "Update the persistent slot records in the metaclass" + "Update the persistent slot records in the metaclass." (prog1 (call-next-method) (when (not (slot-boundp instance '%persistent-slots)) (setf (%persistent-slots instance) (cons (persistent-slot-names instance) nil))) - (when (not (slot-boundp instance '%indexed-slots)) - (update-indexed-record instance (indexed-slot-names-from-defs instance))))) + (update-indexed-record instance (indexed-slot-names-from-defs instance)))) (defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) @@ -130,7 +151,6 @@ ;; situation where we write the class or index page that we are currently reading ;; via a cursor without going through the cursor abstraction. There has to be a ;; better way to do this. - (when (and (indexed class) (not from-oid)) (let ((class-index (find-class-index class))) (when class-index --- /project/elephant/cvsroot/elephant/src/elephant/classindex-utils.lisp 2006/03/01 18:57:34 1.2 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex-utils.lisp 2006/04/26 17:53:44 1.3 @@ -1,4 +1,14 @@ - +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; +;;; classindex-untils.lisp -- support for classindex.lisp and +;;; class re-definition synchronization +;;; +;;; Initial version 1/24/2006 Ian Eslick +;;; eslick at alum mit edu +;;; +;;; License: Lisp Limited General Public License +;;; http://www.franz.com/preamble.html +;;; (in-package :elephant) @@ -46,7 +56,7 @@ ;; Differentiate derived indices from slot-based ones ;; -(defparameter *derived-index-marker* "%%derived%%-") +(defparameter *derived-index-marker* "%%DERIVED%%-") (defun make-derived-name (name) (intern (format nil "~A~A" *derived-index-marker* name))) @@ -58,7 +68,8 @@ *derived-index-marker*)) (defun get-derived-name-root (dname) - (when (symbolp dname) (symbol-name dname)) + (when (symbolp dname) + (setf dname (symbol-name dname))) (intern (subseq dname (length *derived-index-marker*)))) ;; @@ -116,6 +127,180 @@ (error (e) (warn "Error ~A computing derived index for on instance ~A" e instance) (values nil nil)))) + + +;; ============================= +;; CLASS / DB SYNCHRONIZATION +;; ============================= + +;; TO READER: I got really tired of trying to figure out all +;; the messy conditionals and I figure default behaviors are something +;; others might want to modify, so here's what determines the rule +;; behavior.. +;; +;; Rules match on the following states of the metaclass and current +;; database class-index for each slotname currently in either of +;; those sources. Actions are taken, typically when a slot exists +;; in one but not the other or features like indexed/persistent +;; differ between the slots +;; +;; class state: +;; class-indexed - the slot is marked as indexed +;; class-persistent - the slot is marked as persistent (not indexed) +;; class-transient - the slot is marked transient +;; class-derived - the slot is in the derived list of the class +;; +;; database +;; db-slot - the database has a slot index +;; db-derived - the database has a derived index +;; +;; The inversions of any of these terms are also available as +;; (not indexed-slot) for example, to cover more than one feature +;; combination +;; +;; Each rule should apply uniquely to a given feature set. +;; +;; Actions taken when rules match can include: +;; +;; add-slot-index - add a new index with the slotname to the db +;; remove-slot-index - remove a slot with the slotname from the db +;; add-derived-index - xxx this makes no sense! xxx +;; remove-derived-index - remove a derived index from the db +;; unregister-indexed-slot - remove an indexed slot from the class metaobject +;; unregister-derived - remove a derived index from the class metaobject +;; register-indexed-slot - register a slot with the class metaobject +;; register-derived-index - register a derived index with the class metaobject +;; + +;; DEFINE THE SYNCHRONIZATION RULES +(eval-when (:compile-toplevel :load-toplevel) + + (defclass synch-rule () + ((lhs :accessor synch-rule-lhs :initarg :lhs :initform nil) + (rhs :accessor synch-rule-rhs :initarg :rhs :initform nil))) + + (defun make-synch-rule (rule-spec) + (let ((lhs (subseq rule-spec 0 (position '=> rule-spec))) + (rhs (subseq rule-spec (1+ (position '=> rule-spec))))) + (make-instance 'synch-rule :lhs lhs :rhs rhs))) + + (defparameter *synchronize-rules* + (mapcar #'(lambda (rule-specs) + (cons (car rule-specs) + (mapcar #'make-synch-rule (cdr rule-specs)))) + '((:class ;; class changes db + ((not db-slot) class-indexed => add-slot-index) + (db-slot (not class-indexed) => remove-slot-index) + (db-derived (not class-indexed) (not class-persistent) + (not class-transient) => register-derived-index)) + (:union ;; merge both sides + (db-slot (not class-indexed) => register-indexed-slot) + ((not db-slot) class-indexed => add-slot-index) + (db-derived (not class-derived) => register-derived-index) + (db-derived class-persistent => remove-derived-index warn)) + ;; NOTE: What about cases where we need to remove things as below? + (:db ;; db changes class + ((not db-slot) class-indexed => unregister-indexed-slot) + ((not db-derived) class-derived => unregister-derived-index) + (db-slot class-persistent => register-indexed-slot) + (db-slot class-transient => remove-indexed-slot) + (db-derived class-transient => remove-derived-index warn) + (db-derived class-persistent => remove-derived-index warn) + (db-derived class-indexed => remove-derived-index warn) + (db-derived (not class-derived) (not class-indexed) + (not class-persistent) (not class-transient) + => register-derived-index))))) + ) + +;; TOP LEVEL METHOD + +(defun synchronize-class-to-store (class &key (sc *store-controller*) + (method *default-indexed-class-synch-policy*)) + (let ((slot-records (compute-class-and-ele-status class sc)) + (rule-set (cdr (assoc method *synchronize-rules*)))) + (apply-synch-rules class slot-records rule-set))) + +;; COMPUTING RULE APPLICABILITY AND FIRING + +(defun synch-rule-applicable? (rule features) + (simple-match-set (synch-rule-lhs rule) features)) + +(defun simple-match-set (a b) + (declare (optimize (speed 3) (safety 1))) + (cond ((null a) t) + ((and (not (null a)) (null b)) nil) + ((member (first a) b :test #'equal) + (simple-match-set (cdr a) (remove (first a) b :test #'equal))) + (t nil))) + +(defparameter *print-synch-messages* nil) + +(defun apply-synch-rule (rule class name) + (when *print-synch-messages* + (format t "Class/DB Synch: converting state ~A using ~A for ~A~%" + (synch-rule-lhs rule) (synch-rule-rhs rule) name)) + (loop for action in (synch-rule-rhs rule) do + (case action + (add-slot-index (add-class-slot-index class name :update-class nil)) + (remove-slot-index (remove-class-slot-index class name :update-class nil)) + (add-derived-index (add-class-derived-index class name :update-class nil)) + (remove-derived-index (remove-class-derived-index class name :update-class nil)) + (unregister-indexed-slot (unregister-indexed-slot class name)) + (unregister-derived-index (unregister-derived-index class name)) + (register-indexed-slot (register-indexed-slot class name)) + (register-derived-index (register-derived-index class name)) + (warn (warn "Performing slot synchronization actions: ~A" (synch-rule-rhs rule)))))) + +(defun apply-synch-rules (class records rule-set) + (declare (optimize (speed 3) (safety 1))) + (labels ((slotname (rec) (car rec)) + (feature-set (rec) (cdr rec))) + (loop for record in records do + (loop for rule in rule-set + when (synch-rule-applicable? rule (feature-set record)) + do + (apply-synch-rule rule class (slotname record)))))) + +;; COMPUTE CURRENT STATE OF CLASS OBJECT AND DATABASE AFTER CHANGES + +(defun compute-class-and-ele-status (class &optional (store-controller *store-controller*)) + (let* ((*store-controller* store-controller) + ;; db info + (db-indices (find-inverted-index-names class)) + (db-derived (mapcar #'get-derived-name-root + (remove-if-not #'derived-name? db-indices))) + (db-slot (set-difference db-indices db-derived)) + ;; class info + (marked-slots (indexing-record-slots (indexed-record class))) + (marked-derived (indexing-record-derived (indexed-record class))) + (persistent-slots (set-difference (persistent-slots class) marked-slots)) + (other-slots (set-difference + (set-difference (class-slots class) persistent-slots) + marked-slots)) + (all-names (union (mapcar #'slot-definition-name (class-slots class)) db-indices)) + ;; [order matters in traversal] + (all-sets `((class-indexed . ,marked-slots) + (class-derived . ,marked-derived) + (class-persistent . ,persistent-slots) + (class-transient . ,other-slots) + (db-slot . ,db-slot) + (db-derived . ,db-derived)))) + (labels ((compute-features (slotname) + (let ((features nil)) + (loop for set in all-sets do + (push (compute-feature slotname (cdr set) (car set)) + features)) + (cons slotname features))) + (compute-feature (name set label) + (if (member name set) + label + `(not ,label)))) + (mapcar #'compute-features all-names)))) + +;; ================================== +;; TOOLS +;; ================================== + ;; ;; This has turned out to be useful for debugging @@ -139,10 +324,10 @@ (disable-class-indexing name) (flush-instance-cache *store-controller*) (setf (find-class name) nil))) - - + + ;; Rob created this just for some debugging. -;; It seesm theoretically possible that we could make +;; It seems theoretically possible that we could make ;; a function that fully checks the consinstency of the index; ;; that is, that the indexed classes indeed exist in the store. (defun dump-class-index (c) @@ -150,7 +335,8 @@ (dump-btree idx) ) -) + ) + (defun report-indexed-classes (&key (class nil) (sc *store-controller*)) (format t "indexed-classes:~%") (let ((bt (controller-class-root sc))) --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/03/27 20:36:27 1.8 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/04/26 17:53:44 1.9 @@ -1,7 +1,7 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; classindex.lisp -- use btree collections to track objects by slot values -;;; via metaclass options or accessor :after methods +;;; via metaclass options or accessor :after methods ;;; ;;; Initial version 1/24/2006 Ian Eslick ;;; eslick at alum mit edu @@ -98,7 +98,7 @@ (defmethod find-class-index ((class-name symbol) &key (sc *store-controller*) (errorp t)) (find-class-index (find-class class-name) :sc sc :errorp errorp)) -(defmethod class-indexedp-by-name ((class-name symbol) &key (sc *store-controller*) (errorp t)) +(defmethod class-indexedp-by-name ((class-name symbol) &key (sc *store-controller*)) (get-value class-name (controller-class-root sc))) (defmethod find-class-index ((class persistent-metaclass) &key (sc *store-controller*) (errorp t)) @@ -145,9 +145,8 @@ (defmethod find-inverted-index ((class persistent-metaclass) slot &key (null-on-fail nil)) (let* ((cidx (find-class-index class)) - (dslot (make-derived-name slot)) (idx (or (get-index cidx slot) - (get-index cidx dslot)))) + (get-index cidx (make-derived-name slot))))) (if idx idx (if null-on-fail @@ -166,26 +165,27 @@ (defmethod close-controller :before ((sc store-controller)) "Ensure the classes don't have stale references to closed stores!" (when (controller-class-root sc) - (map-btree (lambda (class-name index) - (declare (ignore index)) - (let ((class (find-class class-name nil))) - (when class - (setf (%index-cache class) nil)))) - (controller-class-root sc)))) + (with-transaction (:store-controller sc :txn-sync t :retries 2) + (map-btree (lambda (class-name index) + (declare (ignore index)) + (let ((class (find-class class-name nil))) + (when class + (setf (%index-cache class) nil)))) + (controller-class-root sc))))) + ;; ============================= ;; INDEXING INTERFACE ;; ============================= (defmethod enable-class-indexing ((class persistent-metaclass) indexed-slot-names &key (sc *store-controller*)) - (assert (not (= 0 (length indexed-slot-names)))) (let ((croot (controller-class-root sc))) (multiple-value-bind (btree found) (get-value (class-name class) croot) (declare (ignore btree)) (when found (error "Class is already enabled for indexing! Run disable class indexing to clean up."))) ;; Put class instance index into the class root & cache it in the class object - (update-indexed-record class indexed-slot-names) + (update-indexed-record class indexed-slot-names :class-indexed t) (with-transaction (:store-controller sc) (let ((class-idx (build-indexed-btree sc))) (setf (get-value (class-name class) croot) class-idx) @@ -283,7 +283,7 @@ (when update-class (register-derived-index class name)) (with-transaction (:store-controller sc) (add-index class-idx - :index-name name + :index-name (make-derived-name name) :key-form (make-derived-key-form derived-defun) :populate populate)))))) @@ -340,6 +340,7 @@ ;; ========================= (defgeneric get-instances-by-class (persistent-metaclass)) +(defgeneric get-instance-by-value (persistent-metaclass slot-name value)) (defgeneric get-instances-by-value (persistent-metaclass slot-name value)) (defgeneric get-instances-by-range (persistent-metaclass slot-name start end)) @@ -384,6 +385,16 @@ (push val instances) (return-from get-instances-by-value instances))))))))) +(defmethod get-instance-by-value ((class symbol) slot-name value) + (let ((list (get-instances-by-value (find-class class) slot-name value))) + (when (consp list) + (car list)))) + +(defmethod get-instance-by-value ((class persistent-metaclass) slot-name value) + (let ((list (get-instances-by-value class slot-name value))) + (when (consp list) + (car list)))) + (defmethod get-instances-by-range ((class symbol) slot-name start end) (get-instances-by-range (find-class class) slot-name start end)) @@ -417,174 +428,9 @@ (assert (consp instances)) (with-transaction (:store-controller sc) (mapc (lambda (instance) - (remove-kv (oid instance) (find-class-index (class-of instance)))) + (remove-kv (oid instance) (find-class-index (class-of instance))) + (drop-pobject instance)) instances)))) -;; ============================= -;; CLASS / DB SYNCHRONIZATION -;; ============================= - -;; TO READER: I got really tired of trying to figure out all -;; the messy conditionals and I figure default behaviors are something -;; others might want to modify, so here's what determines the rule -;; behavior. -;; -;; Rules match on the following states of the metaclass and current -;; database class-index for each slotname currently in either of -;; those sources. Actions are taken, typically when a slot exists -;; in one but not the other or features like indexed/persistent -;; differ between the slots -;; -;; class state: -;; class-indexed - the slot is marked as indexed -;; class-persistent - the slot is marked as persistent (not indexed) -;; class-transient - the slot is marked transient -;; class-derived - the slot is in the derived list of the class -;; -;; database -;; db-slot - the database has a slot index -;; db-derived - the database has a derived index -;; -;; The inversions of any of these terms are also available as -;; (not indexed-slot) for example, to cover more than one feature -;; combination -;; -;; Each rule should apply uniquely to a given feature set. -;; -;; Actions taken when rules match can include: -;; -;; add-slot-index - add a new index with the slotname to the db -;; remove-slot-index - remove a slot with the slotname from the db -;; add-derived-index - xxx this makes no sense! xxx -;; remove-derived-index - remove a derived index from the db -;; unregister-indexed-slot - remove an indexed slot from the class metaobject -;; unregister-derived - remove a derived index from the class metaobject -;; register-indexed-slot - register a slot with the class metaobject -;; register-derived-index - register a derived index with the class metaobject -;; - -;; DEFINE THE SYNCHRONIZATION RULES -(eval-when (:compile-toplevel :load-toplevel) - - (defclass synch-rule () - ((lhs :accessor synch-rule-lhs :initarg :lhs :initform nil) - (rhs :accessor synch-rule-rhs :initarg :rhs :initform nil))) - - (defun make-synch-rule (rule-spec) - (let ((lhs (subseq rule-spec 0 (position '=> rule-spec))) - (rhs (subseq rule-spec (1+ (position '=> rule-spec))))) - (make-instance 'synch-rule :lhs lhs :rhs rhs))) - - (defparameter *synchronize-rules* - (mapcar #'(lambda (rule-specs) - (cons (car rule-specs) - (mapcar #'make-synch-rule (cdr rule-specs)))) - '((:class ;; class changes db - ((not db-slot) class-indexed => add-slot-index) - (db-slot (not class-indexed) => remove-slot-index) - (db-derived (not class-derived) => remove-derived-index)) - (:union ;; merge both sides - (db-slot (not class-indexed) => register-indexed-slot) - ((not db-slot) class-indexed => add-slot-index) - (db-derived (not class-derived) => register-derived-index) - (db-derived class-persistent => remove-derived-index warn)) - ;; NOTE: What about cases where we need to remove things as below? - (:db ;; db changes class - ((not db-slot) class-indexed => unregister-indexed-slot) - ((not db-derived) class-derived => unregister-derived-index) - (db-slot class-persistent => register-indexed-slot) - (db-slot class-transient => remove-indexed-slot) - (db-derived class-transient => remove-derived-index warn) - (db-derived class-persistent => remove-derived-index warn) - (db-derived class-indexed => remove-derived-index warn) - (db-derived (not class-derived) (not class-indexed) - (not class-persistent) (not class-transient) => - register-derived-slot))))) - ) - -;; TOP LEVEL METHOD - -(defun synchronize-class-to-store (class &key (sc *store-controller*) - (method *default-indexed-class-synch-policy*)) - (let ((slot-records (compute-class-and-ele-status class sc)) - (rule-set (cdr (assoc method *synchronize-rules*)))) - (apply-synch-rules class slot-records rule-set))) - -;; COMPUTING RULE APPLICABILITY AND FIRING - -(defun synch-rule-applicable? (rule features) - (simple-match-set (synch-rule-lhs rule) features)) - -(defun simple-match-set (a b) - (declare (optimize (speed 3) (safety 1))) - (cond ((null a) t) - ((and (not (null a)) (null b)) nil) - ((member (first a) b :test #'equal) - (simple-match-set (cdr a) (remove (first a) b :test #'equal))) - (t nil))) - -(defparameter *print-synch-messages* nil) - -(defun apply-synch-rule (rule class name) - (when *print-synch-messages* - (format t "Class/DB Synch: converting state ~A using ~A for ~A~%" - (synch-rule-lhs rule) (synch-rule-rhs rule) name)) - (loop for action in (synch-rule-rhs rule) do - (case action - (add-slot-index (add-class-slot-index class name :update-class nil)) - (remove-slot-index (remove-class-slot-index class name :update-class nil)) - (add-derived-index (add-class-derived-index class name :update-class nil)) - (remove-derived-index (remove-class-derived-index class name :update-class nil)) - (unregister-indexed-slot (unregister-indexed-slot class name)) - (unregister-derived-index (unregister-derived-index class name)) - (register-indexed-slot (register-indexed-slot class name)) - (register-derived-index (register-derived-index class name)) - (warn (warn "Performing slot synchronization actions: ~A" (synch-rule-rhs rule)))))) - -(defun apply-synch-rules (class records rule-set) - (declare (optimize (speed 3) (safety 1))) - (labels ((slotname (rec) (car rec)) - (feature-set (rec) (cdr rec))) - (loop for record in records do - (loop for rule in rule-set - when (synch-rule-applicable? rule (feature-set record)) - do - (apply-synch-rule rule class (slotname record)))))) - -;; COMPUTE CURRENT STATE OF CLASS OBJECT AND DATABASE AFTER CHANGES - -(defun compute-class-and-ele-status (class &optional (store-controller *store-controller*)) - (let* ((*store-controller* store-controller) - ;; db info - (db-indices (find-inverted-index-names class)) - (db-derived (mapcar #'get-derived-name-root - (remove-if-not #'derived-name? db-indices))) - (db-slot (set-difference db-indices db-derived)) - ;; class info - (marked-slots (indexing-record-slots (indexed-record class))) - (marked-derived (indexing-record-derived (indexed-record class))) - (persistent-slots (set-difference (persistent-slots class) marked-slots)) - (other-slots (set-difference - (set-difference (class-slots class) persistent-slots) - marked-slots)) - (all-names (union (mapcar #'slot-definition-name (class-slots class)) db-indices)) - ;; [order matters in traversal] - (all-sets `((class-indexed . ,marked-slots) - (class-derived . ,marked-derived) - (class-persistent . ,persistent-slots) - (class-transient . ,other-slots) - (db-slot . ,db-slot) - (db-derived . ,db-derived)))) - (labels ((compute-features (slotname) - (let ((features nil)) - (loop for set in all-sets do - (push (compute-feature slotname (cdr set) (car set)) - features)) - (cons slotname features))) - (compute-feature (name set label) - (if (member name set) - label - `(not ,label)))) - (mapcar #'compute-features all-names)))) --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2006/02/20 21:21:42 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2006/04/26 17:53:44 1.4 @@ -332,6 +332,17 @@ (unless more (return nil)) (funcall fn k v))))) +(defmethod empty-btree-p ((btree btree)) + (with-transaction (:store-controller (get-con btree)) + (with-btree-cursor (cur btree) + (multiple-value-bind (valid k) (cursor-next cur) + (cond ((not valid) ;; truly empty + t) + ((eq k *elephant-properties-label*) ;; has properties + (not (cursor-next cur))) + (t nil)))))) + + (defun dump-btree (bt) (format t "DUMP ~A~%" bt) (map-btree #'(lambda (k v) (format t "k ~A / v ~A~%" k v)) bt) --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/03/27 20:36:28 1.8 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/04/26 17:53:44 1.9 @@ -117,8 +117,9 @@ "Conveniently open a store controller." (assert (consp spec)) (setq *store-controller* (get-controller spec)) - (open-controller *store-controller* :recover recover - :recover-fatal recover-fatal :thread thread)) + (ensure-marked-version + (open-controller *store-controller* :recover recover + :recover-fatal recover-fatal :thread thread))) (defun close-store (&optional sc) "Conveniently close the store controller." @@ -131,12 +132,12 @@ (defmacro with-open-store ((spec) &body body) "Executes the body with an open controller, unconditionally closing the controller on exit." - `(let ((*store-controller* (get-controller ,spec))) + `(let ((*store-controller* nil)) (declare (special *store-controller*)) - (open-controller *store-controller*) + (open-store spec) (unwind-protect (progn ,@body) - (close-controller *store-controller*)))) + (close-store *store-controller*)))) ;; ;; COMMON STORE CONTROLLER FUNCTIONALITY @@ -163,6 +164,96 @@ (for garbage collection,) et cetera.")) ;; +;; VERSIONING AND UPGRADES +;; + +;; Need to tag databases +;; Need to handle untagged db's +;; Need to provide upgrade hooks + +(defvar *restricted-properties* '(:version) + "Properties that are not user manipulable") + +(defmethod controller-properties ((sc store-controller)) + (get-from-root *elephant-properties-label* :store-controller sc)) + +(defmethod set-ele-property (property value &key (sc *store-controller*)) + (assert (and (symbolp property) (not (member property *restricted-properties*)))) + (let ((props (get-from-root *elephant-properties-label* :store-controller sc))) + (setf (get-value *elephant-properties-label* (controller-root sc)) + (if (assoc property props) + (progn (setf (cdr (assoc property props)) value) + props) + (acons property value props))))) + +(defmethod get-ele-property (property &key (sc *store-controller*)) + (assert (symbolp property)) + (let ((entry (assoc property + (get-from-root *elephant-properties-label* + :store-controller sc)))) + (when entry + (cdr entry)))) + +(defmethod ensure-marked-version ((sc store-controller)) + "Not sure this test is right (empty root)" + (let ((props (controller-properties sc)) + (empty? (and (empty-btree-p (controller-root sc)) + (empty-btree-p (controller-class-root sc))))) + ;; marked - continue + (unless (assoc :version props) + (if empty? + ;; empty so new database - mark with current code version + (setf (get-value *elephant-properties-label* (controller-root sc)) + (acons :version *elephant-code-version* props)) + ;; has stuff in it but not marked - mark as prior + (setf (get-value *elephant-properties-label* (controller-root sc)) + (acons :version *elephant-unmarked-code-version* props))))) + sc) + +(defmethod controller-version ((sc store-controller)) + (let ((alist (controller-properties sc))) + (let ((result (assoc :version alist))) + (if result + (cdr result) + nil)))) + +(defmethod up-to-date-p ((sc store-controller)) + (equal (controller-version sc) *elephant-code-version*)) + +(defparameter *elephant-upgrade-table* + '( ((0 6 0) (0 5 0)) + )) + +(defun prior-version-p (v1 v2) + "Is v1 an equal or earlier version than v2" + (cond ((and (null v1) (null v2)) t) + ((and (null v1) (not (null v2))) t) + ((and (not (null v1)) (null v2)) nil) + ((< (car v1) (car v2)) t) + ((> (car v1) (car v2)) nil) + ((= (car v1) (car v2)) + (prior-version-p (cdr v1) (cdr v2))) + (t (error "Version problem!")))) + +(defmethod upgradable-p ((sc store-controller)) + "Determine if this store can be brought up to date using the upgrade function" + (unwind-protect + (let ((row (assoc *elephant-code-version* *elephant-upgrade-table* :test #'equal)) + (ver (controller-version sc))) + (when (member ver (rest row) :test #'equal)) t) + nil)) + +(defmethod upgrade ((sc store-controller)) + (unless (upgradable-p sc) + (error "Cannot upgrade ~A from version ~A to version ~A~%Valid upgrades are:~%~A" + (controller-spec sc) + (controller-version sc) + *elephant-code-version* + *elephant-upgrade-table*)) + (warn "Upgrade by migrating your old repository to a clean repository created using the current code base. i.e. (migrate new old)")) + + +;; ;; OBJECT CACHE ;; @@ -178,7 +269,7 @@ (let ((obj (get-cache oid (instance-cache sc)))) (if obj obj ;; Should get cached since make-instance calls cache-instance - (make-instance (handle-legacy-classes class-name) + (make-instance (handle-legacy-classes class-name nil) :from-oid oid :sc sc)))) (defmethod flush-instance-cache ((sc store-controller)) @@ -188,7 +279,13 @@ (setf (instance-cache sc) (make-cache-table :test 'eql))) -(defun handle-legacy-classes (name) +(defparameter *legacy-conversions-db* + '((("elephant" . "bdb-btree") . ("sleepycat" . "bdb-btree")) + (("elephant" . "bdb-indexed-btree") . ("sleepycat" . "bdb-indexed-btree")) + (("elephant" . "bdb-btree-index") . ("sleepycat" . "bdb-btree-index")))) + +(defun handle-legacy-classes (name version) + (declare (ignore version)) (let ((entry (assoc (symbol->string-pair name) *legacy-conversions-db* :test #'equal))) (if entry (string-pair->symbol (cdr entry)) @@ -201,10 +298,6 @@ (defun string-pair->symbol (name) (intern (string-upcase (cdr name)) (car name))) -(defparameter *legacy-conversions-db* - '((("elephant" . "bdb-btree") . ("sleepycat" . "bdb-btree")) - (("elephant" . "bdb-indexed-btree") . ("sleepycat" . "bdb-indexed-btree")) - (("elephant" . "bdb-btree-index") . ("sleepycat" . "bdb-btree-index")))) ;; ;; STORE CONTROLLER PROTOCOL @@ -264,6 +357,7 @@ retrieve it in a later session. N.B. this means it (and everything it points to) won't get gc'd." (declare (type store-controller store-controller)) + (assert (not (eq key *elephant-properties-label*))) (setf (get-value key (controller-root store-controller)) value)) (defun get-from-root (key &key (store-controller *store-controller*)) @@ -293,12 +387,9 @@ (defmethod drop-pobject ((inst persistent-object)) "Reclaim persistent object storage by unbinding slot values. - This also drops references to the instance from any index - it partipates in. This does not delete the cached object - instance or any serialized references still in the db. + This does not delete the cached object instance or any + serialized references still in the db. Need a migration or GC for that!" - (when (indexed (class-of inst)) - (drop-instances (list inst))) (let ((pslots (persistent-slots (class-of inst)))) (dolist (slot pslots) (slot-makunbound inst slot)))) --- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/25 22:05:08 1.6 +++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/04/26 17:53:44 1.7 @@ -40,16 +40,16 @@ ;; Top level defclass form - hide metaclass option ;; -(defmacro defpclass (cname parents slot-defs &optional class-opts) +(defmacro defpclass (cname parents slot-defs &rest class-opts) `(defclass ,cname ,parents ,slot-defs - ,(add-persistent-metaclass-argument class-opts))) + ,@(add-persistent-metaclass-argument class-opts))) (defun add-persistent-metaclass-argument (class-opts) (when (assoc :metaclass class-opts) (error "User metaclass specification not allowed in defpclass")) - (append (list :metaclass 'persistent-metaclass) class-opts)) - + (append class-opts (list (list :metaclass 'persistent-metaclass)))) + ;; ;; Persistent slot maintenance ;; @@ -105,7 +105,7 @@ ;; This just encapsulates record keeping a bit (defclass indexing-record () - ((class :accessor indexing-record-class :initarg :class :initform t) + ((class :accessor indexing-record-class :initarg :class :initform nil) (slots :accessor indexing-record-slots :initarg :slots :initform nil) (derived-count :accessor indexing-record-derived :initarg :derived :initform 0))) @@ -125,16 +125,21 @@ (when (slot-boundp class '%indexed-slots) (cdr (%indexed-slots class)))) -(defmethod update-indexed-record ((class persistent-metaclass) new-slot-list) +(defmethod update-indexed-record ((class persistent-metaclass) new-slot-list &key class-indexed) (let ((oldrec (if (slot-boundp class '%indexed-slots) (indexed-record class) nil))) (setf (%indexed-slots class) - (cons (make-instance 'indexing-record - :slots new-slot-list - :derived (when oldrec (indexing-record-derived oldrec))) + (cons (make-new-indexed-record new-slot-list oldrec class-indexed) (if oldrec oldrec nil))))) +(defmethod make-new-indexed-record (new-slot-list oldrec class-indexed) + (make-instance 'indexing-record + :class (or class-indexed + (when oldrec (indexing-record-class oldrec))) + :slots new-slot-list + :derived (when oldrec (indexing-record-derived oldrec)))) + (defmethod removed-indexing? ((class persistent-metaclass)) (and (not (indexed class)) (previously-indexed class))) @@ -191,9 +196,10 @@ (setf (indexing-record-derived record) (remove name (indexing-record-derived record))))) (defmethod indexed ((class persistent-metaclass)) - (and (slot-boundp class '%indexed-slots ) + (and (slot-boundp class '%indexed-slots) (not (null (%indexed-slots class))) - (or (indexing-record-slots (indexed-record class)) + (or (indexing-record-class (indexed-record class)) + (indexing-record-slots (indexed-record class)) (indexing-record-derived (indexed-record class))))) (defmethod previously-indexed ((class persistent-metaclass)) @@ -201,7 +207,8 @@ (not (null (%indexed-slots class))) (let ((old (old-indexed-record class))) (when (not (null old)) - (or (indexing-record-slots old) + (or (indexing-record-class old) + (indexing-record-slots old) (indexing-record-derived old)))))) (defmethod indexed ((slot standard-slot-definition)) nil) --- /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2006/02/21 19:40:06 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2006/04/26 17:53:44 1.4 @@ -28,17 +28,17 @@ ;; - 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 +;; 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 @@ -46,9 +46,16 @@ ;; 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... +;; +;; - Migrate keeps a memory-resident hash of all objects; this means +;; you cannot currently migrate a store that has more data than your +;; main memory. (This could be fixed by keeping the oid table in +;; the target store and deleting it on completion) +;; ;; - 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) +;; to keep the object references themselves rather than oids in general) +;; but they can overload the migrate method to accomplish this cleanly ;; ;; CUSTOMIZE MIGRATION: ;; - To customize migration overload a version of migrate to specialize on @@ -149,8 +156,9 @@ ;; 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)))) + (unless (eq key *elephant-properties-label*) + (with-transaction (:store-controller dst :txn-nosync t) + (add-to-root key newval :store-controller dst))))) (controller-root src)) dst) @@ -302,7 +310,7 @@ (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!") + (warn "Arrays containing persistent objects will fail migration!") src) --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/03/01 18:57:34 1.2 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/04/26 17:53:44 1.3 @@ -50,7 +50,7 @@ (defconstant +ucs4-string+ 21) (defconstant +ucs4-pathname+ 22) -(defconstant +persistent+ 15) +(defconstant +persistent+ 15) ;; stored by id+classname (defconstant +cons+ 16) (defconstant +hash-table+ 17) (defconstant +object+ 18) @@ -59,7 +59,6 @@ (defconstant +fill-pointer-p+ #x40) (defconstant +adjustable-p+ #x80) - (defun serialize (frob bs) "Serialize a lisp value into a buffer-stream." (declare (optimize (speed 3) (safety 0)) @@ -81,12 +80,13 @@ (buffer-write-byte #+(and allegro ics) (etypecase s - (base-string +ucs1-symbol+) + (base-string +ucs2-symbol+) ;; +ucs1-symbol+ (string +ucs2-symbol+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase s - (base-string +ucs1-symbol+) - (string #+sbcl +ucs4-symbol+ #+lispwoks +ucs2-symbol+)) + (base-string #+sbcl +ucs4-symbol+ #+lispworks +ucs2-symbol+ ) + ;; +ucs1-symbol+) + (string #+sbcl +ucs4-symbol+ #+lispworks +ucs2-symbol+)) #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) +ucs1-symbol+ bs) @@ -101,11 +101,12 @@ (buffer-write-byte #+(and allegro ics) (etypecase frob - (base-string +ucs1-string+) + (base-string +ucs2-string+) ;; +ucs1-string+ (string +ucs2-string+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase frob - (base-string +ucs1-string+) + (base-string #+sbcl +ucs4-string+ #+lispworks +ucs2-string+ ) + ;; +ucs1-string+ (string #+sbcl +ucs4-string+ #+lispworks +ucs2-string+)) #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) +ucs1-string+ @@ -143,11 +144,12 @@ (buffer-write-byte #+(and allegro ics) (etypecase s - (base-string +ucs1-pathname+) + (base-string +ucs2-pathname+) ;; +ucs1-pathname+ (string +ucs2-pathname+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase s - (base-string +ucs1-pathname+) + (base-string #+sbcl +ucs4-pathname+ #+lispwoks +ucs2-pathname+ ) + ;; +ucs1-pathname+ (string #+sbcl +ucs4-pathname+ #+lispwoks +ucs2-pathname+)) #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) +ucs1-pathname+ --- /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2006/04/26 17:53:44 1.2 @@ -52,6 +52,7 @@ :txn-nowait ,txn-nowait :txn-sync ,txn-sync)) + ;; ;; An interface to manage transactions explicitely ;; --- /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2006/04/26 17:53:44 1.2 @@ -27,6 +27,22 @@ (defvar *cachesize* 100 "Size of the OID sequence cache.") +;;;;;;;;;;;;;;;; +;;;; Versioning Support + +(defvar *elephant-code-version* '(0 6 0) + "The current database version supported by the code base") + +(defvar *elephant-unmarked-code-version* '(0 5 0) + "If a database is opened with existing data but no version then + we assume it's version 0.5.0") + +(defvar *elephant-properties-label* 'elephant::*database-properties* + "This is the symbol used to store properties associated with the + database in the controller-root through the new properties interface. + Users attempting to directly write this variable will run into an + error") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Thread-local specials --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2006/04/26 17:53:45 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2006/04/26 17:53:45 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; package.lisp -- package definition ;;; ;;; Initial version 8/26/2004 by Ben Lee ;;; <blee(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. ;;; (in-package :cl-user) (defpackage elephant (:use common-lisp elephant-memutil) (:nicknames ele :ele) (:documentation "Elephant: an object-oriented database for Common Lisp with multiple backends for Berkeley DB, SQL and others.") (:export #:*store-controller* #:*current-transaction* #:*auto-commit* #:*elephant-lib-path* #:store-controller #:open-store #:close-store #:with-open-store #:add-to-root #:get-from-root #:remove-from-root #:root-existsp #:flush-instance-cache #:with-transaction #:start-ele-transaction #:commit-transaction #:abort-transaction #:persistent #:persistent-object #:persistent-metaclass #:persistent-collection #:defpclass #:btree #:make-btree #:get-value #:remove-kv #:existp #:map-btree #:indexed-btree #:make-indexed-btree #:add-index #:get-index #:remove-index #:map-indices #:btree-index #:get-primary-key #:primary #:key-form #:key-fn #:btree-differ #:migrate #:*inhibit-slot-copy* #:cursor #:secondary-cursor #:make-cursor #:with-btree-cursor #:cursor-close #:cursor-init #:cursor-duplicate #:cursor-current #:cursor-first #:cursor-last #:cursor-next #:cursor-next-dup #:cursor-next-nodup #:cursor-prev #:cursor-prev-nodup #:cursor-set #:cursor-set-range #:cursor-get-both #:cursor-get-both-range #:cursor-delete #:cursor-put #:cursor-pcurrent #:cursor-pfirst #:cursor-plast #:cursor-pnext #:cursor-pnext-dup #:cursor-pnext-nodup #:cursor-pprev #:cursor-pprev-nodup #:cursor-pset #:cursor-pset-range #:cursor-pget-both #:cursor-pget-both-range #:run-elephant-thread ;; Class indexing management API #:*default-indexed-class-synch-policy* #:find-class-index #:find-inverted-index #:enable-class-indexing #:disable-class-indexing #:add-class-slot-index #:remove-class-slot-index #:add-class-derived-index #:remove-class-derived-index #:describe-db-class-index #:report-indexed-classes #:class-indexedp-by-name ;; Low level cursor API #:make-inverted-cursor #:make-class-cursor #:with-inverted-cursor #:with-class-cursor ;; Instance query API #:get-instances-by-class #:get-instance-by-value #:get-instances-by-value #:get-instances-by-range #:drop-instances ) #+cmu (:import-from :pcl compute-class-precedence-list validate-superclass standard-slot-definition standard-direct-slot-definition standard-effective-slot-definition direct-slot-definition-class effective-slot-definition-class slot-definition-name slot-definition-initform slot-definition-initfunction compute-effective-slot-definition class-slots slot-value-using-class slot-boundp-using-class slot-makunbound-using-class slot-definition-allocation slot-definition-initargs class-finalized-p finalize-inheritance ensure-class-using-class compute-slots initialize-internal-slot-functions compute-effective-slot-definition-initargs slot-definition-reader-function slot-definition-writer-function slot-definition-boundp-function slot-definition-allocation-class class-slot-cells plist-value +slot-unbound+) #+cmu (:import-from :ext make-weak-pointer weak-pointer-value finalize) #+cmu (:import-from :bignum %bignum-ref) #+sbcl (:import-from :sb-mop compute-class-precedence-list validate-superclass standard-slot-definition standard-direct-slot-definition standard-effective-slot-definition direct-slot-definition-class effective-slot-definition-class slot-definition-name slot-definition-initform slot-definition-initfunction compute-effective-slot-definition class-slots slot-value-using-class slot-boundp-using-class slot-makunbound-using-class slot-definition-allocation slot-definition-initargs class-finalized-p finalize-inheritance ensure-class-using-class compute-slots) #+sbcl (:import-from :sb-pcl initialize-internal-slot-functions compute-effective-slot-definition-initargs slot-definition-reader-function slot-definition-writer-function slot-definition-boundp-function slot-definition-allocation-class class-slot-cells plist-value +slot-unbound+) #+sbcl (:import-from :sb-ext make-weak-pointer weak-pointer-value finalize) #+sbcl (:import-from :sb-bignum %bignum-ref) #+allegro (:import-from :clos compute-class-precedence-list validate-superclass standard-slot-definition standard-direct-slot-definition standard-effective-slot-definition direct-slot-definition-class effective-slot-definition-class slot-definition-name slot-definition-initform slot-definition-initfunction compute-effective-slot-definition class-slots slot-value-using-class slot-boundp-using-class slot-makunbound-using-class slot-definition-allocation slot-definition-initargs class-finalized-p finalize-inheritance ensure-class-using-class compute-slots slot-definition-readers slot-definition-writers class-direct-slots ) #+allegro (:import-from :excl compute-effective-slot-definition-initargs) #+openmcl (:import-from :ccl class-finalized-p finalize-inheritance ensure-class-using-class compute-class-precedence-list validate-superclass standard-slot-definition standard-direct-slot-definition standard-effective-slot-definition direct-slot-definition-class effective-slot-definition-class slot-definition-name slot-definition-initform slot-definition-initfunction compute-effective-slot-definition class-slots slot-value-using-class slot-boundp-using-class slot-makunbound-using-class slot-definition-allocation slot-definition-initargs compute-slots ;; This stuff we need until we resolve the :transient ;; slot specifier stuff make-effective-slot-definition slots-class %slot-definition-initfunction %slot-definition-documentation %slot-definition-initargs %slot-definition-initform %slot-definition-allocation %slot-definition-class %slot-definition-type) #+lispworks (:import-from :clos compute-class-precedence-list validate-superclass ensure-class-using-class standard-slot-definition standard-direct-slot-definition standard-effective-slot-definition direct-slot-definition-class effective-slot-definition-class slot-definition-name slot-definition-initform slot-definition-initfunction compute-effective-slot-definition class-slots slot-value-using-class slot-boundp-using-class slot-makunbound-using-class slot-definition-allocation slot-definition-initargs compute-slots) ) (in-package "ELE") #+cmu (eval-when (:compile-toplevel) (proclaim '(optimize (ext:inhibit-warnings 3))))

1 0

[elephant-cvs] CVS elephant/src/contrib/eslick
by ieslick 26 Apr '06

26 Apr '06

Update of /project/elephant/cvsroot/elephant/src/contrib/eslick In directory clnet:/tmp/cvs-serv12311/src/contrib/eslick Added Files: tools.lisp Log Message: Significant additions to the 0.6.0 release on the trunk. Updates to documentation, 0.5.0 compliance, final on 0.6.0 features. There are one or two BDB interactions on migration to work out but this should be a nearly code complete 0.6.0 release. Please start testing and evaluating this - especially the ability to open and tag 0.5.0 databases. Features: - Database version tagging - Support for 0.5.0 namespaces & databases - New migration system - class indexing without slot indexing - various bug fixes - reverted fast allegro/sbcl string support to allow 0.5.0 databases to work correctly. I couldn't find a good way to work around this without creating infinite headaches - validated that running db_deadlock will stop all lisp freezes that I've encountered. This has to be run each time a DB environment is opened/created so eventually should be made part of the open-controller functionality for the BDB backend --- /project/elephant/cvsroot/elephant/src/contrib/eslick/tools.lisp 2006/04/26 17:53:44 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/tools.lisp 2006/04/26 17:53:44 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; tools.lisp -- use btree collections to track objects by slot values ;;; via metaclass options or accessor :after methods ;;; ;;; Initial version 3/29/2006 Ian Eslick ;;; eslick at alum mit edu ;;; ;;; License: Lisp Limited General Public License (LLGPL) ;;; http://www.franz.com/preamble.html ;;; (in-package :elephant) ;; ;; Messy method to see what's in a btree ;; (defmethod summarize-btree-contents ((btree btree) &key (print-depth 100) (search-depth nil) (dump nil) (recurse nil)) (let ((count 0) (record (make-btree-summary-record))) (catch 'max-depth (map-btree (lambda (key val) (incf count) (when (and search-depth (> count search-depth)) (throw 'max-depth nil)) (update-stats-for-value val record) (when (and dump (< count print-depth)) (format t "key: ~A value: ~A~%" key val)) (when (and recurse (subtypep (type-of val) 'btree) (< count print-depth)) (format t "Recursing into ~A:~A...~%" key val) (summarize-btree-contents val :search-depth search-depth :print-depth print-depth :dump dump :recurse recurse) (format t "...completing recursion into ~A:~A~%" key val))) btree)) (format t "Summary:~%") (loop for pair in record do (cond ((eq (car pair) 'array) (format t "~A (~A)~%" (symbol-name (car pair)) (- (cdr pair) (cdr (assoc 'string record))))) (t (format t "~A (~A)~%" (symbol-name (car pair)) (cdr pair))))))) (defparameter *base-types* '(persistent-object persistent-collection structure-object standard-object number string array hash-table)) (defun make-btree-summary-record () (let ((record nil)) (loop for type in *base-types* do (push (cons (intern type (find-package 'keyword)) 0) record)) record)) (defmethod update-stats-for-value (value record) (loop for type in *base-types* do (when (subtypep (type-of value) type) (incf (cdr (assoc (intern type (find-package 'keyword)) record))))))

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 26 Apr '06

26 Apr '06

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv12311/src/db-bdb Modified Files: bdb-collections.lisp bdb-controller.lisp sleepycat.lisp Log Message: Significant additions to the 0.6.0 release on the trunk. Updates to documentation, 0.5.0 compliance, final on 0.6.0 features. There are one or two BDB interactions on migration to work out but this should be a nearly code complete 0.6.0 release. Please start testing and evaluating this - especially the ability to open and tag 0.5.0 databases. Features: - Database version tagging - Support for 0.5.0 namespaces & databases - New migration system - class indexing without slot indexing - various bug fixes - reverted fast allegro/sbcl string support to allow 0.5.0 databases to work correctly. I couldn't find a good way to work around this without creating infinite headaches - validated that running db_deadlock will stop all lisp freezes that I've encountered. This has to be run each time a DB environment is opened/created so eventually should be made part of the open-controller functionality for the BDB backend --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/22 21:03:47 1.5 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/04/26 17:53:44 1.6 @@ -56,7 +56,8 @@ (defmethod (setf get-value) (value key (bt bdb-btree)) (declare (optimize (speed 3) (safety 0) (space 0))) - (with-transaction (:store-controller (get-con bt)) + (assert (or *auto-commit* (not (eq *current-transaction* 0)))) +;; (with-transaction (:store-controller (get-con bt)) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid bt) key-buf) (serialize key key-buf) @@ -64,16 +65,17 @@ (db-put-buffered (controller-btrees (get-con bt)) key-buf value-buf :auto-commit *auto-commit*) - value))) + value)) (defmethod remove-kv (key (bt bdb-btree)) (declare (optimize (speed 3) (space 0) (safety 0))) - (with-transaction (:store-controller (get-con bt)) + (assert (or *auto-commit* (not (eq *current-transaction* 0)))) +;; (with-transaction (:store-controller (get-con bt)) (with-buffer-streams (key-buf) (buffer-write-int (oid bt) key-buf) (serialize key key-buf) (db-delete-buffered (controller-btrees (get-con bt)) - key-buf :auto-commit *auto-commit*)))) + key-buf :auto-commit *auto-commit*))) ;; Secondary indices --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/03/07 14:12:22 1.6 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/04/26 17:53:44 1.7 @@ -59,9 +59,12 @@ (let ((env (db-env-create))) ;; thread stuff? (setf (controller-environment sc) env) - (db-env-open env (second (controller-spec sc)) :create t :init-txn t :init-lock t + (db-env-open env (second (controller-spec sc)) + :create t :init-txn t :init-lock t :init-mpool t :init-log t :thread thread :recover recover :recover-fatal recover-fatal) + (db-env-set-timeout env 100000 :set-transaction-timeout t) + (db-env-set-timeout env 100000 :set-lock-timeout t) (let ((db (db-create env)) (btrees (db-create env)) (indices (db-create env)) --- /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat.lisp 2006/02/19 20:06:03 1.3 +++ /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat.lisp 2006/04/26 17:53:44 1.4 @@ -300,7 +300,7 @@ ((= ,errno 0) (values ,@(rest out-args))) ,@(if transaction (list `((or (= ,errno DB_LOCK_DEADLOCK) - (= ,errno DB_LOCK_NOTGRANTED)) + (= ,errno DB_LOCK_NOTGRANTED)) (throw 'transaction ,transaction))) (values)) (t (error 'db-error :errno ,errno))))))))

1 0