Update of /project/elephant/cvsroot/elephant/src/contrib/eslick In directory clnet:/tmp/cvs-serv28024
Added Files: snapshot-db.lisp Log Message: Cool snapshot hack
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/snapshot-db.lisp 2007/04/12 02:45:09 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/snapshot-db.lisp 2007/04/12 02:45:09 1.1 ;;; ;;; Copyright (c) 2007 Ian Eslick <ieslick common-lisp net> ;;; ;;; Simple snapshot sets. Create a snapshot set for standard objects, ;;; work in-memory and then call snapshot to save the objects to ;;; the underlying store-controller. ;;;
;; ;; Limitations: ;; ;; - Hashes can be registered as indexes of objects. Keys ;; should be simple (numbers, strings, symbols) although ;; arrays in an equalp cache are probably OK too. Values ;; should also be simple or subclasses of standard-object ;; ;; - When a snapshot is taken of a hash, all values that are ;; standard objects are registered. Any refs to registered ;; objects are properly restored on retrieval ;; ;; Easy extensions: ;; ;; - Support arrays of objects as well as hash-tables ;; ;; - Create a method standard-object-dirty-p that defaults to 't' but ;; allows users to implement a method that avoids storing unchanged ;; objects. ;; ;; - Enable versioned or named snapshots ;; ;; - Better interface API (special object metaclass?) to create a more ;; natural abstraction. Could also add object journaling for ;; prevalence dynamics via rucksack log model. For example, writes ;; to slots are saved to a persistent list that gets reused after ;; snapshots (id slotname value). Slot reads are as usual. ;;
(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)) (: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))
;; ================= ;; User methods ;; =================
(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)))
(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)))
(defmethod unregister-object (object (set snapshot-set)) "Drops the object from the cache and backing store" (let ((id (gethash object (snapshot-set-cache set)))) (when (null id) (error "Object ~A not registered in ~A" object set)) (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)))))
(defun map-set (fn set) "Iterates through all values in the set" (maphash (lambda (k v) (declare (ignore v)) (funcall fn k)) (snapshot-set-cache set)))
;; =============== ;; Shorthand ;; ===============
;; Cache ops
(defun clear-cache (set) (clrhash (snapshot-set-cache set)))
(defun lookup-cached-id (obj set) (gethash obj (snapshot-set-cache set)))
(defun lookup-cached-object (id set) (find-hash-key-by-value id (snapshot-set-cache set)))
(defun find-hash-key-by-value (value hash) (maphash (lambda (k v) (when (eq v value) (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)))
(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)))
;; Snapshot ops
(defun reified-class-p (obj) (or (subtypep (type-of obj) 'standard-object) (eq (type-of obj) 'hash-table)))
(defclass setref () ((id :accessor snapshot-set-reference-id :initarg :id)))
(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) (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)) 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))