[elephant-cvs] CVS elephant/src/elephant
ieslick
ieslick at common-lisp.net
Sun Feb 4 04:34:57 UTC 2007
Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv16382/src/elephant
Modified Files:
controller.lisp package.lisp serializer.lisp serializer1.lisp
serializer2.lisp
Log Message:
char to unsigned char fix in BDB; cleaned up modular serializer initialization in BDB and SQL backends and main protocol
--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/03 04:09:13 1.28
+++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/04 04:34:57 1.29
@@ -98,48 +98,6 @@
(asdf:operate 'asdf:load-op dep)))
dep-list))
-;; ================================================
-;;
-;; USER API TO CONTROLLER OPS
-;;
-;; ================================================
-
-
-;;
-;; Open a Store
-;;
-
-(defun open-store (spec &rest args)
- "Conveniently open a store controller. Set *store-controller* to the new controller
- unless it is already set (opening a second controller means you must keep track of
- controllers yourself. *store-controller* is a convenience variable for single-store
- applications"
- (assert (consp spec))
- (let ((controller (get-controller spec)))
- (unless *store-controller*
- (setq *store-controller* controller))
- (load-user-configuration controller)
- (initialize-serializer controller)
- (apply #'open-controller controller args)
- controller))
-
-(defun close-store (&optional sc)
- "Conveniently close the store controller."
- (when (or sc *store-controller*)
- (close-controller (or sc *store-controller*)))
- (unless sc
- (setf *store-controller* nil)))
-
-(defmacro with-open-store ((spec) &body body)
- "Executes the body with an open controller,
-unconditionally closing the controller on exit."
- `(let ((*store-controller* nil))
- (declare (special *store-controller*))
- (open-store ,spec)
- (unwind-protect
- (progn , at body)
- (close-store *store-controller*))))
-
;;
;; COMMON STORE CONTROLLER FUNCTIONALITY
;;
@@ -160,7 +118,6 @@
(instance-cache-lock :accessor instance-cache-lock :initform (ele-make-lock)
:documentation "Protection for updates to the cache from multiple threads")
;; Upgradable serializer strategy
- (database-version :accessor controller-version-cached :initform nil)
(serializer-version :accessor controller-serializer-version :initform nil)
(serialize :accessor controller-serialize :initform nil)
(deserialize :accessor controller-deserialize :initform nil)
@@ -170,25 +127,25 @@
handles, the cache, table creation, counters, locks, the root
(for garbage collection,) et cetera."))
-;; User configuration parameters for the controller
-
-(defun load-user-configuration (controller)
- ;; Placeholder
- (declare (ignorable controller))
- nil)
-
-(defun initialize-serializer (sc)
- "Establish serializer version on controller startup"
- (cond ((prior-version-p (database-version sc) '(0 6 0))
- (setf (controller-serializer-version sc) 1)
- (setf (controller-serialize sc) 'elephant-serializer1::serialize)
- (setf (controller-deserialize sc) 'elephant-serializer1::deserialize))
- (t
- (setf (controller-serializer-version sc) 2)
- (setf (controller-serialize sc) 'elephant-serializer2::serialize)
- (setf (controller-deserialize sc) 'elephant-serializer2::deserialize))))
-
+;;
+;; Database versioning
+;;
+(defgeneric database-version (sc)
+ (:documentation "Backends implement this to store the serializer version.
+ The protocol requires that backends report their database
+ version. On new database creation, the database is written with the
+ *elephant-code-version* so that is returned by database-version.
+ If a legacy database does not have a version according to the method
+ then it should return nil"))
+
+(defmethod database-version :around (sc)
+ "Default version assumption for unmarked databases is 0.6.0"
+;; NOTE: It is possible to check for 0.5.0 databases, but it is not
+;; implemented now due to the low (none?) number of users still on 0.5.0"
+ (let ((db-version (call-next-method)))
+ (if db-version db-version
+ '(0 6 0))))
(defun prior-version-p (v1 v2)
"Is v1 an equal or earlier version than v2"
@@ -197,42 +154,73 @@
((and (not (null v1)) (null v2)) nil)
((< (car v1) (car v2)) t)
((> (car v1) (car v2)) nil)
- ((= (car v1) (car v2))
+ ((= (car v1) (car v2))
(prior-version-p (cdr v1) (cdr v2)))
- (t (error "Version problem!"))))
+ (t (error "Version comparison problem: (prior-version-p ~A ~A)" v1 v2))))
;;
-;; OBJECT CACHE
+;; Database upgrade paths
;;
-(defun cache-instance (sc obj)
- "Cache a persistent object with the controller."
- (declare (type store-controller sc))
- (ele-with-lock ((instance-cache-lock sc))
- (setf (get-cache (oid obj) (instance-cache sc)) obj)))
+(defparameter *elephant-upgrade-table*
+ '( ((0 6 0) (0 5 0))
+ ((0 6 1) (0 6 0))
+ ))
-(defun get-cached-instance (sc oid class-name)
- "Get a cached instance, or instantiate!"
- (declare (type store-controller sc)
- (type fixnum oid))
- (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 nil)
- :from-oid oid :sc sc))))
+(defmethod up-to-date-p ((sc store-controller))
+ (equal (database-version sc) *elephant-code-version*))
-(defmethod flush-instance-cache ((sc store-controller))
- "Reset the instance cache (flush object lookups). Useful
- for testing. Does not reclaim existing objects so there
- will be duplicate instances with identical functionality"
- (ele-with-lock ((instance-cache-lock sc))
- (setf (instance-cache sc)
- (make-cache-table :test 'eql))))
+(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 (database-version sc)))
+ (when (member ver (rest row) :test #'equal)) t)
+ nil))
+
+(defmethod upgrade ((sc store-controller) target-spec)
+ (unless (upgradable-p sc)
+ (error "Cannot upgrade ~A from version ~A to version ~A~%Valid upgrades are:~%~A"
+ (controller-spec sc)
+ (database-version sc)
+ *elephant-code-version*
+ *elephant-upgrade-table*))
+ (warn "Please read the current limitations on migrate-based upgrade in migrate.lisp to ensure your
+ data does not require any unsupported features")
+ (let ((source sc)
+ (target (open-store target-spec)))
+ (migrate target source)
+ (close-store target)))
+
+
+;;
+;; Modular serializer support and default serializers for a version
+;;
+
+(defmethod initialize-serializer ((sc store-controller))
+ "Establish serializer version on controller startup. Backends call this before
+ they need the serializer to be valid and after they enable their database-version
+ call. If the backend shadows this, it has to keep track of serializer versions
+ associated with the database version that is opened."
+ (cond ((prior-version-p (database-version sc) '(0 6 0))
+ (setf (controller-serializer-version sc) 1)
+ (setf (controller-serialize sc) 'elephant-serializer1::serialize)
+ (setf (controller-deserialize sc) 'elephant-serializer1::deserialize))
+ (t
+ (setf (controller-serializer-version sc) 2)
+ (setf (controller-serialize sc) 'elephant-serializer2::serialize)
+ (setf (controller-deserialize sc) 'elephant-serializer2::deserialize))))
+
+;;
+;; Handling package changes in legacy databases
+;;
(defparameter *legacy-conversions-db*
- '((("elephant" . "bdb-btree") . ("sleepycat" . "bdb-btree"))
+ '(;; 0.5.0 support
+ (("elephant" . "bdb-btree") . ("sleepycat" . "bdb-btree"))
(("elephant" . "bdb-indexed-btree") . ("sleepycat" . "bdb-indexed-btree"))
(("elephant" . "bdb-btree-index") . ("sleepycat" . "bdb-btree-index"))
+ ;; 0.6.0 support
(("sleepycat" . "bdb-btree") . ("db-bdb" . "bdb-btree"))
(("sleepycat" . "bdb-indexed-btree") . ("db-bdb" . "bdb-indexed-btree"))
(("sleepycat" . "bdb-btree-index") . ("db-bdb" . "bdb-btree-index"))))
@@ -252,19 +240,40 @@
(defun string-pair->symbol (name)
(intern (string-upcase (cdr name)) (car name)))
-
-
;;
-;; VERSIONING
+;; Per-controller instance caching
;;
-(defgeneric database-version (sc)
- (:documentation "Backends implement this to store the serializer version")
- )
+(defun cache-instance (sc obj)
+ "Cache a persistent object with the controller."
+ (declare (type store-controller sc))
+ (ele-with-lock ((instance-cache-lock sc))
+ (setf (get-cache (oid obj) (instance-cache sc)) obj)))
+
+(defun get-cached-instance (sc oid class-name)
+ "Get a cached instance, or instantiate!"
+ (declare (type store-controller sc)
+ (type fixnum oid))
+ (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 nil)
+ :from-oid oid :sc sc))))
+(defmethod flush-instance-cache ((sc store-controller))
+ "Reset the instance cache (flush object lookups). Useful
+ for testing. Does not reclaim existing objects so there
+ will be duplicate instances with identical functionality"
+ (ele-with-lock ((instance-cache-lock sc))
+ (setf (instance-cache sc)
+ (make-cache-table :test 'eql))))
+
+
+;; ================================================================================
;;
-;; STORE CONTROLLER PROTOCOL
-;;
+;; BACKEND STORE CONTROLLER PROTOCOL
+;;
+;; ================================================================================
(defgeneric open-controller (sc &key recover recover-fatal thread &allow-other-keys)
(:documentation
@@ -276,6 +285,11 @@
"Close the db handles and environment. Tries to wipe out
references to the db handles."))
+(defmethod close-controller :after ((sc store-controller))
+ "Delete connection spec so store-controller operations on cached
+ controller information fail"
+ (remhash (controller-spec sc) *dbconnection-spec*))
+
(defgeneric connection-is-indeed-open (controller)
(:documentation "Validate the controller and the db that it is connected to")
(:method ((controller t)) t))
@@ -289,9 +303,70 @@
"Tell the backend to reclaim any storage caused by key deletion, if possible.
This should default to return space to the filesystem rather than just to the free list."))
+;;
+;; Low-level support for metaclass protocol
+;;
+
+(defgeneric persistent-slot-reader (sc instance name)
+ (:documentation
+ "Backend specific slot reader function"))
+
+(defgeneric persistent-slot-writer (sc new-value instance name)
+ (:documentation
+ "Backend specific slot writer function"))
+(defgeneric persistent-slot-boundp (sc instance name)
+ (:documentation
+ "Backend specific slot bound test function"))
+
+(defgeneric persistent-slot-makunbound (sc instance name)
+ (:documentation
+ "Backend specific slot makunbound handler"))
+
+
+;; ================================================================================
;;
-;; Object Root Operations
+;; CONTROLLER USER API
+;;
+;; ================================================================================
+
+
+;;
+;; Opening and closing backend stores
+;;
+
+(defun open-store (spec &rest args)
+ "Conveniently open a store controller. Set *store-controller* to the new controller
+ unless it is already set (opening a second controller means you must keep track of
+ controllers yourself. *store-controller* is a convenience variable for single-store
+ applications or single-store per thread apps"
+ (assert (consp spec))
+ (let ((controller (get-controller spec)))
+ (apply #'open-controller controller args)
+ (if *store-controller*
+ controller
+ (setq *store-controller* controller))))
+
+(defun close-store (&optional sc)
+ "Conveniently close the store controller."
+ (when (or sc *store-controller*)
+ (close-controller (or sc *store-controller*)))
+ (unless sc
+ (setf *store-controller* nil)))
+
+(defmacro with-open-store ((spec) &body body)
+ "Executes the body with an open controller,
+ unconditionally closing the controller on exit."
+ `(let ((*store-controller* nil))
+ (declare (special *store-controller*))
+ (open-store ,spec)
+ (unwind-protect
+ (progn , at body)
+ (close-store *store-controller*))))
+
+
+;;
+;; Operations on the root index
;;
(defun add-to-root (key value &key (store-controller *store-controller*))
@@ -299,7 +374,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*)))
+ (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*))
@@ -324,15 +399,23 @@
(map-btree fn (controller-root store-controller)))
;;
-;; Handling dbconnection specs
+;; Explicit storage reclamation
;;
-(defmethod close-controller :after ((sc store-controller))
- "Delete connection spec so object ops on cached db info fail"
- (remhash (controller-spec sc) *dbconnection-spec*))
+(defmethod drop-pobject ((inst persistent-object))
+ "Reclaim persistent object storage by unbinding slot values.
+ This does not delete the cached object instance or any
+ serialized references still in the db.
+ Need a migration or GC for that!"
+ (let ((pslots (persistent-slots (class-of inst))))
+ (dolist (slot pslots)
+ (slot-makunbound inst slot))))
+;; (slot-makunbound-using-class (class-of inst)
+;; inst
+;; (find-effective-slot-def (class-of inst) slot)))))
;;
-;; DATABASE PROPERTY INTERFACE (Not used by system as of 0.6.1)
+;; DATABASE PROPERTY INTERFACE (Not used by system as of 0.6.1, but supported)
;;
(defvar *restricted-properties* '()
@@ -358,42 +441,6 @@
(when entry
(cdr entry))))
-
-;;
-;; Upgrade paths
-;;
-
-(defmethod up-to-date-p ((sc store-controller))
- (equal (database-version sc) *elephant-code-version*))
-
-(defmethod upgrade ((sc store-controller) target-spec)
- (unless (upgradable-p sc)
- (error "Cannot upgrade ~A from version ~A to version ~A~%Valid upgrades are:~%~A"
- (controller-spec sc)
- (database-version sc)
- *elephant-code-version*
- *elephant-upgrade-table*))
- (warn "Please read the current limitations on migrate-based upgrade in migrate.lisp to ensure your
- data does not require any unsupported features")
- (let ((source sc)
- (target (open-store target-spec)))
- (migrate target source)
- (close-store target)))
-
-(defparameter *elephant-upgrade-table*
[57 lines skipped]
--- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/03 00:57:34 1.10
+++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/04 04:34:57 1.11
@@ -30,8 +30,6 @@
#:with-elephant-variables
#:store-controller #:controller-root #:controller-class-root
- #:controller-version #:controller-serializer-version
- #:controller-serialize #:controller-deserialize
#:open-store #:close-store #:with-open-store
#:add-to-root #:get-from-root #:remove-from-root #:root-existsp
#:get-cached-instance #:flush-instance-cache
@@ -39,6 +37,15 @@
#:controller-fast-symbols-p
#:optimize-storage
+ #:controller-version #:controller-serializer-version
+ #:controller-serialize #:controller-deserialize
+ #:serialize-database-version-key
+ #:serialize-database-version-value
+ #:deserialize-database-version-value
+ #:serialize-database-serializer-version-value
+ #:deserialize-database-serializer-version-value
+ #:initialize-serializer
+
#:with-transaction #:ensure-transaction
#:start-ele-transaction #:commit-transaction #:abort-transaction
--- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/02/02 23:51:58 1.20
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/02/04 04:34:57 1.21
@@ -64,7 +64,64 @@
target
(cl-base64::base64-string-to-usb8-array string))
sc)))
+
+;;
+;; Serializer independant system information
+;;
+;; We'll can this for now, can expose as API for backend later
+
+(defconstant +reserved-dbinfo+ #xF0)
+(defconstant +elephant-version+ 1)
+(defconstant +elephant-serializer-version+ 2)
+
+;; Database Version (a list of integers = [version major minor])
+
+(defun serialize-database-version-key (bs)
+ (serialize-reserved-tag bs)
+ (serialize-system-tag +elephant-version+ bs))
+
+(defun serialize-database-version-value (version bs)
+ "Simple serializes a list containing three integers"
+ (assert (consp version))
+ (destructuring-bind (version major minor) version
+ (serialize-system-integer version bs)
+ (serialize-system-integer major bs)
+ (serialize-system-integer minor bs)))
+
+(defun deserialize-database-version-value (bs)
+ (let ((version (deserialize-system-integer bs))
+ (major (deserialize-system-integer bs))
+ (minor (deserialize-system-integer bs)))
+ (list version major minor)))
+
+;;
+;; Serializer version (so you know what encoding is/was used in the db)
+;;
+
+(defun serialize-database-serializer-version-key (bs)
+ (serialize-reserved-tag bs)
+ (serialize-system-tag +elephant-serializer-version+ bs))
+
+(defun serialize-database-serializer-version-value (version bs)
+ (serialize-system-integer version bs))
+
+(defun deserialize-database-serializer-version-value (bs)
+ (deserialize-system-integer bs))
+
+;; Simple API for basic byte and integer operations
+
+(defun serialize-reserved-tag (bs)
+ (elephant-memutil::buffer-write-byte +reserved-dbinfo+ bs))
+
+(defun serialize-system-tag (byte bs)
+ (elephant-memutil::buffer-write-byte byte bs))
+
+(defun serialize-system-integer (int bs)
+ (elephant-memutil::buffer-write-int32 int bs))
+(defun deserialize-system-integer (bs)
+ (elephant-memutil::buffer-read-int32 bs))
+
;; (defclass blob ()
;; ((slot1 :accessor slot1 :initarg :slot1)
--- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/01 04:03:27 1.3
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/04 04:34:57 1.4
@@ -71,6 +71,8 @@
(defconstant +object+ 18)
(defconstant +array+ 19)
+(defconstant +reserved-dbinfo+ #xF0)
+
(defconstant +fill-pointer-p+ #x40)
(defconstant +adjustable-p+ #x80)
--- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/03 00:57:34 1.11
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/04 04:34:57 1.12
@@ -77,6 +77,7 @@
(defconstant +class+ 21)
(defconstant +nil+ #x3F)
+(defconstant +reserved-dbinfo+ #xF0)
;; Arrays
(defconstant +fill-pointer-p+ #x20)
More information about the Elephant-cvs
mailing list