[elephant-cvs] CVS elephant/src/elephant
ieslick
ieslick at common-lisp.net
Sat Jan 20 22:12:18 UTC 2007
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
More information about the Elephant-cvs
mailing list