[elephant-cvs] CVS elephant/src/contrib/eslick

Thu Apr 12 02:45:09 UTC 2007

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))