[elephant-cvs] CVS elephant/src/contrib/eslick
ieslick
ieslick at common-lisp.net
Thu Apr 12 17:09:56 UTC 2007
Update of /project/elephant/cvsroot/elephant/src/contrib/eslick
In directory clnet:/tmp/cvs-serv19106/src/contrib/eslick
Modified Files:
snapshot-db.lisp
Log Message:
Final hacks for snapshot-set
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/snapshot-db.lisp 2007/04/12 02:45:08 1.1
+++ /project/elephant/cvsroot/elephant/src/contrib/eslick/snapshot-db.lisp 2007/04/12 17:09:56 1.2
@@ -38,24 +38,18 @@
(in-package :elephant)
-(defparameter *use-proxy-objects* t
- "Indicates that the snapshot set should register
- and write any standard-objects found in slots registered
- of standard objects during snapshots")
-
(defpclass snapshot-set ()
((index :accessor snapshot-set-index :initform (make-btree))
(next-id :accessor snapshot-set-next-id :initform 0)
- (cache :accessor snapshot-set-cache :initform (make-hash-table) :transient t)
- (root :accessor snapshot-set-root :initform nil))
+ (root :accessor snapshot-set-root :initform nil)
+ (cache :accessor snapshot-set-cache :initform (make-hash-table) :transient t))
(:documentation "Keeps track of a set of standard objects
allowing a single snapshot call to update the store
controller with the latest state of all objects registered with
this set"))
-(defmethod initialize-instance :after ((set snapshot-set) &rest rest)
- (declare (ignore rest))
- (restore set))
+(defmethod initialize-instance :after ((set snapshot-set) &key lazy-load &allow-other-keys)
+ (unless lazy-load (restore set)))
;; =================
;; User methods
@@ -63,28 +57,21 @@
(defmethod register-object ((object standard-object) (set snapshot-set))
"Register a standard object. Not recorded until snapshot is called on db"
- (if (lookup-cached-id object set) nil
- (let ((id (incf (snapshot-set-next-id set))))
- (cache-snapshot-object id object set)
- object)))
+ (aif (lookup-cached-id object set)
+ (values object it)
+ (let ((id (incf (snapshot-set-next-id set))))
+ (cache-snapshot-object id object set)
+ (values object id))))
(defmethod register-object ((hash hash-table) (set snapshot-set))
"Adds a hash table to the snapshot set and registers any standard objects
stored as values that are not already part of the snapshot. Must call snapshot
to save."
- (if (lookup-cached-id hash set) nil
- (let ((id (incf (snapshot-set-next-id set))))
- (cache-snapshot-object id hash set)
- hash)))
-
-(defmethod set-root ((set snapshot-set))
- (if (snapshot-set-root set)
- (lookup-cached-object (snapshot-set-root set) set)
- nil))
-
-(defmethod (setf set-root) (value (set snapshot-set))
- (setf (snapshot-set-root set)
- (ensure-registered value)))
+ (aif (lookup-cached-id hash set)
+ (values hash it)
+ (let ((id (incf (snapshot-set-next-id set))))
+ (cache-snapshot-object id hash set)
+ (values hash id))))
(defmethod unregister-object (object (set snapshot-set))
"Drops the object from the cache and backing store"
@@ -94,36 +81,47 @@
(drop-cached-object object set)
(delete-snapshot-object id set)))
-(defmethod snapshot ((set snapshot-set))
- (maphash (lambda (obj id)
- (write-object id obj set))
- (snapshot-set-cache set)))
-
-(defmethod restore ((set snapshot-set))
- "Restores a snapshot by setting the snapshot-set state to the last snapshot.
- If this is used during runtime, the user needs to drop all references
- to objects and retrieve again from the snapshot set"
- (clear-cache set)
- (let ((proxyrecs nil))
- (map-btree (lambda (k v)
- (cond ((hash-table-p v)
- (push (list k v) proxyrecs))
- ((subtypep (type-of v) 'standard-object)
- (cache-snapshot-object k v set))
- (t (error "Invalid type in snapshot-set type ~A for ~A" (type-of v) v))))
- (snapshot-set-index set))
- ;; All objects should be loaded so object references in hashes are valid
- (dolist (proxyrec proxyrecs)
- (destructuring-bind (id proxy) proxyrec
- (cache-snapshot-object id (restore-proxy-hash proxy set) set)))))
+(defmethod snapshot-root ((set snapshot-set))
+ "Get the snapshot root object"
+ (when (snapshot-set-root set)
+ (lookup-cached-object (snapshot-set-root set) set)))
+
+(defmethod (setf snapshot-root) (value (set snapshot-set))
+ "Specify a root object for the set. There is only 1
+ so it should be a hash or the root node of a graph"
+ (setf (snapshot-set-root set)
+ (multiple-value-bind (obj id)
+ (register-object value set)
+ id))
+ value)
(defun map-set (fn set)
- "Iterates through all values in the set"
+ "Iterates through all values in the active set, not the
+ saved snapshot"
(maphash (lambda (k v)
(declare (ignore v))
(funcall fn k))
(snapshot-set-cache set)))
+(defmethod snapshot ((set snapshot-set))
+ "Saves all objects in the set (and any objects reachable from the
+ current set of objects) to the persistent store"
+ (with-transaction (:store-controller (get-con (snapshot-set-index set)))
+ (maphash (lambda (obj id)
+ (save-snapshot-object id obj set))
+ (snapshot-set-cache set))))
+
+(defmethod restore ((set snapshot-set))
+ "Restores a snapshot by setting the snapshot-set state to the last snapshot.
+ If this is used during runtime, the user needs to drop all references
+ to objects and retrieve again from the snapshot set. Also used to initialize
+ the set state when a set is created, for example pulled from the root of a
+ store-controller, unless :lazy-load is specified"
+ (clear-cache set)
+ (map-btree (lambda (id object)
+ (load-snapshot-object id object set))
+ (snapshot-set-index set)))
+
;; ===============
;; Shorthand
;; ===============
@@ -133,6 +131,9 @@
(defun clear-cache (set)
(clrhash (snapshot-set-cache set)))
+(defun cache-snapshot-object (id obj set)
+ (setf (gethash obj (snapshot-set-cache set)) id))
+
(defun lookup-cached-id (obj set)
(gethash obj (snapshot-set-cache set)))
@@ -145,77 +146,140 @@
(return-from find-hash-key-by-value k)))
hash))
-(defun cache-snapshot-object (id obj set)
- (setf (gethash obj (snapshot-set-cache set)) id))
-
(defun drop-cached-object (obj set)
(remhash obj (snapshot-set-cache set)))
-;; Save and restore objects
-
-(defun read-snapshot-object (id set)
- (get-value id (snapshot-set-index set)))
+;; Save objects
-(defun write-object (id obj set)
- (setf (get-value id (snapshot-set-index set))
- (cond ((subtypep (type-of obj) 'standard-object)
- (make-proxy-object obj set))
- ((eq (type-of obj) 'hash-table)
- (make-proxy-hash obj set))
- (t (error "Cannot only snapshot standard-objects and hash-tables")))))
-
-(defun ensure-registered (obj set)
- "Return object id by cache lookup or register and write object"
- (let ((id (lookup-cached-id obj set)))
- (if id id
- (progn
- (register-object obj set)
- (let ((id (lookup-cached-id obj set)))
- (write-object id obj set)
- id)))))
-
-(defun delete-snapshot-object (id set)
- (remove-kv id (snapshot-set-index set)))
+(defclass setref ()
+ ((id :accessor snapshot-set-reference-id :initarg :id)))
-;; Snapshot ops
+(defun setrefp (obj)
+ (eq (type-of obj) 'setref))
-(defun reified-class-p (obj)
- (or (subtypep (type-of obj) 'standard-object)
- (eq (type-of obj) 'hash-table)))
+(defun standard-object-subclass-p (obj)
+ (subtypep (type-of obj) 'standard-object))
-(defclass setref ()
- ((id :accessor snapshot-set-reference-id :initarg :id)))
+(defun save-snapshot-object (id obj set)
+ (setf (get-value id (snapshot-set-index set))
+ (cond ((standard-object-subclass-p obj)
+ (save-proxy-object obj set))
+ ((hash-table-p obj)
+ (save-proxy-hash obj set))
+ (t (error "Cannot only snapshot standard-objects and hash-tables"))))
+ id)
+
+(defun save-proxy-object (obj set)
+ (let ((svs (subsets 2 (slots-and-values obj))))
+ (if (some #'reified-class-p (mapcar #'second svs))
+ (let ((proxy (make-instance (type-of obj))))
+ (loop for (slotname value) in svs do
+ (setf (slot-value proxy slotname)
+ (if (reify-class-p value)
+ (reify-object value set)
+ value)))
+ proxy)
+ obj)))
-(defun make-proxy-object (obj set)
- (if (not *use-proxy-objects*)
- obj
- (let ((proxy (make-instance (type-of obj))))
- (loop for (slotname value) in (subsets 2 (slots-and-values obj)) do
- (setf (slot-value proxy slotname)
- (if (reified-class-p value)
- (make-instance 'setref :id (ensure-registered value set))
- value))))))
-(defun make-proxy-hash (hash set)
+(defun save-proxy-hash (hash set)
(let ((proxy (make-hash-table)))
(maphash (lambda (key value)
(setf (gethash key proxy)
- (if (or (subtypep (type-of value) 'standard-object)
- (subtypep (type-of value) 'hash-table))
- (make-instance 'setref :id (ensure-registered value set))
+ (if (reify-class-p value)
+ (reify-object value set)
value)))
hash)
proxy))
-(defun restore-proxy-hash (proxy set)
- "Convert a proxy object to a standard hash, resolving references"
- (let ((hash (make-hash-table)))
- (maphash (lambda (k v)
- (setf (gethash k hash)
- (if (eq (type-of v) 'setref)
- (lookup-cached-object (snapshot-set-reference-id v) set)
- v)))
- proxy)
- hash))
+(defun reify-class-p (obj)
+ (or (standard-object-subclass-p obj)
+ (hash-table-p obj)))
+
+(defun reify-object (obj set)
+ (multiple-value-bind (obj id)
+ (register-object obj set)
+ (make-instance 'setref :id (save-snapshot-object id obj set))))
+
+;; Load objects
+
+(defun load-snapshot-object (id object set)
+ (let ((object (ifret object (get-value id (snapshot-set-index set)))))
+ (cond ((standard-object-subclass-p object)
+ (load-proxy-object id object set))
+ ((hash-table-p object)
+ (load-proxy-hash id object set))
+ (t (error "Unrecognized type ~A for id ~A in set ~A" (type-of object) id set)))))
+
+;; Need to create placeholder, then populate slots
+
+(defun load-proxy-object (id obj set)
+ (ifret (lookup-cached-object id set)
+ (progn
+ (cache-snapshot-object id obj set)
+ (let ((svs (subsets 2 (slots-and-values obj))))
+ (loop for (slotname value) in svs do
+ (when (setrefp value)
+ (setf (slot-value obj slotname)
+ (load-snapshot-object (snapshot-set-reference-id value) nil set)))))
+ obj)))
+
+(defun load-proxy-hash (id hash set)
+ (ifret (lookup-cached-object id set)
+ (progn
+ (cache-snapshot-object id hash set)
+ (maphash (lambda (key value)
+ (when (setrefp value)
+ (setf (gethash key hash)
+ (load-snapshot-object (snapshot-set-reference-id value) nil set))))
+ hash)
+ hash)))
+
+
+;; Delete from snapshot
+
+(defun delete-snapshot-object (id set)
+ (remove-kv id (snapshot-set-index set)))
-
\ No newline at end of file
+;; ==============================
+;; Tests
+;; ==============================
+
+(defclass snapshot-test ()
+ ((slot1 :accessor slot1 :initarg :slot1)
+ (slot2 :accessor slot2 :initarg :slot2)))
+
+(defun make-stest (slot1 slot2)
+ (make-instance 'snapshot-test :slot1 slot1 :slot2 slot2))
+
+(defun test-snapshot ()
+ "Requires open store"
+ (let* ((set (make-instance 'snapshot-set))
+ (hash (make-hash-table))
+ (test1 (make-stest 1 2))
+ (test2 (make-stest 10 20))
+ (test3 (make-stest (make-stest 'one 'two) (make-stest 'three 'four)))
+ (test4 (make-stest (slot1 test3) (slot2 test3))))
+ (loop for num from 1
+ for obj in (list test1 test2 test3 test4) do
+ (setf (gethash num hash) obj))
+ (setf (snapshot-root set) hash)
+ (add-to-root 'set set)
+ (snapshot set)
+ ;; Clear
+ (setf set nil)
+ (setf hash nil)
+ (elephant::flush-instance-cache *store-controller*)
+ (cl-user::gc)
+ ;; Reload
+ (setf set (get-from-root 'set))
+ (setf hash (snapshot-root set))
+ (let ((t1 (gethash 1 hash))
+ (t2 (gethash 2 hash))
+ (t3 (gethash 3 hash))
+ (t4 (gethash 4 hash)))
+ (values
+ (eq 1 (slot1 t1))
+ (eq 20 (slot2 t2))
+ (eq (slot2 t3)
+ (slot2 t4))))))
More information about the Elephant-cvs
mailing list