Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv5278/src/elephant

Modified Files: controller.lisp cross-platform.lisp package.lisp serializer.lisp serializer2.lisp variables.lisp Log Message: Promoted diff's provided by the community (Pierre and Gabor) as well as a checkpoint of ongoing work to get the 0.6.1 development tree on HEAD working again.

--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/19 21:03:30 1.18 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/20 22:12:17 1.19 @@ -26,7 +26,6 @@ (defparameter *elephant-backends* '((:bdb (:ele-bdb)) (:clsql (:ele-clsql)) -;; (:acache (:ele-acache)) ) "Entries have the form of (backend-type asdf-depends-list")

@@ -102,53 +101,6 @@ ;; ;; ================================================

-;; -;; Callback hooks for persistent variables -;; -;; NOTE: Design sketch; not sure I'll include this... - -;;(defvar *variable-hooks* nil -;; "An alist (specs -> varlist) where varlist is tuple of -;; lisp name, store name (auto) and policy") - -;;(defun add-hook (name spec) -;; (if (assoc spec *variable-hooks* :test #'equal) -;; (push name (assoc spec *variable-hooks* :test #'equal)) -;; (push (cons spec (list name)) *variable-hooks*))) - -;;(defun remove-hook (name spec) -;; (if (assoc spec *variable-hooks* :test #'equal) -;; (setf (assoc spec *variable-hooks* :test #'equal) -;; (remove name (assoc spec *variable-hooks* :test #'equal))) -;; (error "No hooks declared on ~A" spec))) - -;; (defmacro defpvar (name spec (policy &rest accessors) initial-value &optional (documentation nil)) -;; `(progn -;; (defvar ,name ,initial-value ,documentation) -;; (add-hook ,name ,spec) -;; ,(case policy -;; (:wrap-mutators -;; `(progn -;; ,(loop for accessor in accessors do -;; (let ((gf (ensure-generic-function -;; `(defmethod ,accessor :after ( - -;; (defpvar *agencies* (:wrap-mutators -;; 'add-agent -;; 'remove-agent -;; 'clear-agents) -;; nil -;; "test") - -;; (defmethod add-agent (agent) -;; (push agent *agencies*)) - -;; (defmethod remove-agent (agent) -;; (setf *agencies* (remove agent *agencies*))) - -;; (defmethod clear-agents (agent) -;; (setf *agencies* nil)) -

;; ;; Open a Store @@ -157,10 +109,11 @@ (defun open-store (spec &rest args) "Conveniently open a store controller." (assert (consp spec)) + ;; setup system config parameters (if necessary) + ;; GF iface to overload by backend (setq *store-controller* (get-controller spec)) (initialize-serializer *store-controller*) - (ensure-properties - (apply #'open-controller *store-controller* args))) + (apply #'open-controller *store-controller* args))

(defun close-store (&optional sc) "Conveniently close the store controller." @@ -205,6 +158,7 @@ ;; Symbol ID caches (symbol-cache :accessor controller-symbol-cache :initform (make-hash-table :size 2000)) (symbol-id-cache :accessor controller-symbol-id-cache :initform (make-hash-table :size 2000)) + (fast-symbols :accessor controller-fast-symbols-p :initform nil) ) (:documentation "Class of objects responsible for the book-keeping of holding DB @@ -213,24 +167,24 @@

(defun initialize-serializer (sc) "Establish serializer version on controller startup" - (cond ((equal (controller-version sc) '(0 6 1)) - (setf (controller-serializer-version sc) 2) - (setf (controller-serialize sc) 'elephant-serializer2::serialize) - (setf (controller-deserialize sc) 'elephant-serializer2::deserialize)) - ((prior-version-p (controller-version sc) '(0 6 0)) + (cond ((prior-version-p (controller-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 (error "Unsupported Elephant database version")))) + (t + (setf (controller-serializer-version sc) 2) + (setf (controller-serialize sc) 'elephant-serializer2::serialize) + (setf (controller-deserialize sc) 'elephant-serializer2::deserialize))))

;; ;; VERSIONING ;;

-(defvar *restricted-properties* '(:version) - "Properties that are not user manipulable") - -(defmethod controller-version ((sc store-controller)) +(defmethod database-version ((sc store-controller)) + (:documentation "A version determination for a given store + controller that is independant of the serializer as the + serializer is dispatched based on the code version which is a + list of the form '(0 6 0)")) (let ((version (controller-version-cached sc))) (if version version (let ((path (make-pathname :name "VERSION" :defaults (second (controller-spec sc))))) @@ -252,82 +206,6 @@ (prior-version-p (cdr v1) (cdr v2))) (t (error "Version problem!"))))

-(defmethod ensure-properties ((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) - - -;; -;; Upgrade paths -;; - -(defmethod up-to-date-p ((sc store-controller)) - (equal (controller-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) - (controller-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* - '( ((0 6 0) (0 5 0)) - ((0 6 1) (0 6 0)) - )) - -(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)) - - -;; -;; PROPERTIES -;; - -(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)))) - ;; ;; OBJECT CACHE ;; @@ -392,12 +270,6 @@ "Close the db handles and environment. Tries to wipe out references to the db handles."))

-(defgeneric database-version ((sc store-controller)) - (:documentation "A version determination for a given store - controller that is independant of the serializer as the - serializer is dispatched based on the code version which is a - list of the form '(0 6 0)")) - (defgeneric connection-is-indeed-open (controller) (:documentation "Validate the controller and the db that it is connected to") (:method ((controller t)) t)) @@ -411,6 +283,7 @@ "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."))

+ ;; ;; Object Root Operations ;; @@ -420,7 +293,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*)) @@ -453,6 +326,118 @@ (remhash (controller-spec sc) *dbconnection-spec*))

;; +;; DATABASE PROPERTY INTERFACE (Not used by system as of 0.6.1) +;; + +(defvar *restricted-properties* '() + "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)))) + + +;; +;; Upgrade paths +;; + +(defmethod up-to-date-p ((sc store-controller)) + (equal (controller-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) + (controller-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* + '( ((0 6 0) (0 5 0)) + ((0 6 1) (0 6 0)) + )) + +(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)) + + +;; +;; Callback hooks for persistent variables +;; + +;; NOTE: Design sketch; not sure I'll promote this... + +;;(defvar *variable-hooks* nil +;; "An alist (specs -> varlist) where varlist is tuple of +;; lisp name, store name (auto) and policy") + +;;(defun add-hook (name spec) +;; (if (assoc spec *variable-hooks* :test #'equal) +;; (push name (assoc spec *variable-hooks* :test #'equal)) +;; (push (cons spec (list name)) *variable-hooks*))) + +;;(defun remove-hook (name spec) +;; (if (assoc spec *variable-hooks* :test #'equal) +;; (setf (assoc spec *variable-hooks* :test #'equal) +;; (remove name (assoc spec *variable-hooks* :test #'equal))) +;; (error "No hooks declared on ~A" spec))) + +;; (defmacro defpvar (name spec (policy &rest accessors) initial-value &optional (documentation nil)) +;; `(progn +;; (defvar ,name ,initial-value ,documentation) +;; (add-hook ,name ,spec) +;; ,(case policy +;; (:wrap-mutators +;; `(progn +;; ,(loop for accessor in accessors do +;; (let ((gf (ensure-generic-function +;; `(defmethod ,accessor :after ( + +;; (defpvar *agencies* (:wrap-mutators +;; 'add-agent +;; 'remove-agent +;; 'clear-agents) +;; nil +;; "test") + +;; (defmethod add-agent (agent) +;; (push agent *agencies*)) + +;; (defmethod remove-agent (agent) +;; (setf *agencies* (remove agent *agencies*))) + +;; (defmethod clear-agents (agent) +;; (setf *agencies* nil)) + + +;; ;; Support for serialization efficiency ;;

@@ -465,6 +450,7 @@ (:documentation "Return a symbol for the ID. This should always succeed. The database should not use the existing serializer to perform this function; but memutils and unicode are available")) + ;; ;; Low-level support for metaclass protocol ;; --- /project/elephant/cvsroot/elephant/src/elephant/cross-platform.lisp 2007/01/16 00:51:25 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/cross-platform.lisp 2007/01/20 22:12:18 1.2 @@ -17,7 +17,7 @@ (in-package :elephant)

;; This is a quick portability hack to avoid external dependencies, if we get -;; to many of these do we need to import a standard library? do we need to import 'port' or some +;; too many of these do we need to import a standard library? do we need to import 'port' or some ;; other thread layer to the elephant dependency list?

(defmacro ele-without-interrupts (&body body) --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/01/19 21:03:30 1.5 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/01/20 22:12:18 1.6 @@ -26,7 +26,7 @@ "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* #:*elephant-code-version* + #:*elephant-lib-path* #:*elephant-code-version* #:*fast-symbols*

#:store-controller #:controller-root #:controller-class-root #:controller-version #:controller-serializer-version --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/12/16 19:35:10 1.15 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/01/20 22:12:18 1.16 @@ -26,6 +26,9 @@ current Elephant version" (funcall (symbol-function (controller-deserialize sc)) bs sc))

+;;(defun serializer-feature (sc) +;; ( + ;; ;; SQL encoding support ;; --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/16 00:51:25 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/20 22:12:18 1.2 @@ -460,27 +460,17 @@ ;; Symbol cache ;;

-(defun deserialize-symbol-id (id sc) - "Deserialize a symbol ID by finding it in the cache" - (declare (type fixnum id)) - (let ((symbol (gethash id (controller-symbol-cache sc)))) - (if symbol symbol - (let ((symbol (lookup-persistent-symbol sc id))) - (if symbol - (progn - (setf (gethash id (controller-symbol-cache sc)) symbol) - (setf (gethash symbol (controller-symbol-id-cache sc)) id) - symbol) - (error "Symbol lookup foobar! ID referred to does not exist in database")))))) - (defun serialize-symbol (symbol bs sc) "Serialize a symbol by recording its ID" (declare (type buffer-stream bs) - (type symbol symbol)) - (let ((id (lookup-id symbol sc))) - (declare (type fixnum id)) - (buffer-write-byte +symbol-id+ bs) - (buffer-write-int id bs))) + (type symbol symbol) + (type store-controller sc)) + (if *fast-symbols* + (let ((id (lookup-id symbol sc))) + (declare (type fixnum id)) + (buffer-write-byte +symbol-id+ bs) + (buffer-write-int id bs)) + (serialize-symbol-complete symbol bs)))

(defun lookup-id (symbol sc) "Find an id for a symbol or create a new one" @@ -509,6 +499,19 @@ (serialize-string (package-name package) bs) (buffer-write-byte +nil+ bs)))))

+(defun deserialize-symbol-id (id sc) + "Deserialize a symbol ID by finding it in the cache" + (declare (type fixnum id)) + (let ((symbol (gethash id (controller-symbol-cache sc)))) + (if symbol symbol + (let ((symbol (lookup-persistent-symbol sc id))) + (if symbol + (progn + (setf (gethash id (controller-symbol-cache sc)) symbol) + (setf (gethash symbol (controller-symbol-id-cache sc)) id) + symbol) + (error "Symbol lookup foobar! ID referred to does not exist in database")))))) +

;; ;; Array type tags --- /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2006/12/16 19:35:10 1.6 +++ /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2007/01/20 22:12:18 1.7 @@ -43,6 +43,8 @@ Users attempting to directly write this variable will run into an error")

+(defvar *fast-symbols* nil) + ;;;;;;;;;;;;;;;;; ;;;; Serializer optimization parameters