[rucksack-cvs] CVS rucksack
alemmens
alemmens at common-lisp.net
Tue Aug 29 11:41:41 UTC 2006
Update of /project/rucksack/cvsroot/rucksack
In directory clnet:/tmp/cvs-serv5405
Modified Files:
example-1.lisp mop.lisp objects.lisp rucksack.lisp
schema-table.lisp serialize.lisp
Log Message:
Some work on schema updates.
Example 1: indexing should still work after recompiling.
RUCKSACK-UPDATE-SLOT-INDEXES: remove indexes for old slots that don exist
anymore.
Compute persistent slots at the right moment.
--- /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/26 12:55:34 1.2
+++ /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/29 11:41:40 1.3
@@ -1,34 +1,34 @@
-;; $Id: example-1.lisp,v 1.2 2006/08/26 12:55:34 alemmens Exp $
+;; $Id: example-1.lisp,v 1.3 2006/08/29 11:41:40 alemmens Exp $
(in-package :test-rucksack)
-;; NOTE: At the moment, this example works only when this file is compiled
-;; exactly once. After the second compile, slot indexing will fail (because
-;; ENSURE-CLASS-SCHEMA isn't complete yet).
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Indexing, class redefinitions
+;;; Indexing example
+;;;
+;;; To run this example:
+;;; - compile and load this file
+;;; - (CREATE-HACKERS)
+;;; - (SHOW-HACKERS)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defparameter *example-1* #p"/tmp/rucksack/example-1/"))
-
(defparameter *hackers* '("David" "Jim" "Peter" "Thomas"
"Arthur" "Jans" "Klaus" "James" "Martin"))
(defun random-elt (list)
(elt list (random (length list))))
-(eval-when (:compile-toplevel)
- (with-rucksack (*rucksack* *example-1* :if-exists :supersede)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+ (defparameter *hacker-rucksack* #p"/tmp/rucksack/hackers/")
+
+ (with-rucksack (*rucksack* *hacker-rucksack*)
(with-transaction ()
- ;; For classes that may change during program development, you should
- ;; wrap all class definitions in a WITH-RUCKSACK to make sure that
- ;; the corresponding schema definitions and indexes are updated correctly.
- ;; (This is only necessary if you already have a rucksack that contains
- ;; instances of the class that's being redefined, of course.)
-
+ ;; We define some persistent classes with indexed slots.
+ ;; So we must wrap the class definition in a WITH-RUCKSACK,
+ ;; otherwise the indexes can't be built.
+
(defclass hacker ()
((id :initform (gensym "HACKER-")
:reader hacker-id
@@ -36,12 +36,10 @@
:unique t)
(name :initform (random-elt *hackers*)
:accessor name
- :index :case-insensitive-string-index)
- (age :initform (random 100) :accessor age
- :index :number-index))
+ :index :case-insensitive-string-index))
(:metaclass persistent-class)
(:index t))
-
+
(defclass lisp-hacker (hacker)
()
(:metaclass persistent-class)
@@ -50,13 +48,12 @@
(defmethod print-object ((hacker hacker) stream)
(print-unreadable-object (hacker stream :type t)
- (format stream "~S called ~S of age ~D"
+ (format stream "~S called ~S"
(hacker-id hacker)
- (name hacker)
- (age hacker))))
+ (name hacker))))
-(defun example-1 ()
- (with-rucksack (*rucksack* *example-1*)
+(defun create-hackers ()
+ (with-rucksack (*rucksack* *hacker-rucksack*)
;; Fill the rucksack with some hackers.
(with-transaction ()
(loop repeat 20
@@ -66,7 +63,7 @@
(rucksack-map-class *rucksack* 'hacker #'print))))
(defun show-hackers ()
- (with-rucksack (*rucksack* *example-1*)
+ (with-rucksack (*rucksack* *hacker-rucksack*)
(with-transaction ()
(print "Hackers indexed by object id.")
(rucksack-map-class *rucksack* 'hacker #'print)
@@ -84,7 +81,215 @@
:id-only t))))
(defun show-indexes ()
- (with-rucksack (r *example-1*)
+ (with-rucksack (r *hacker-rucksack*)
(print (rs::rucksack-list-class-indexes r))
(print (rs::rucksack-list-slot-indexes r))
:ok))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Example output
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+#|
+
+CL-USER 2 > (in-package :test-rs)
+#<The TEST-RUCKSACK package, 74/256 internal, 0/16 external>
+
+TEST-RS 3 > (create-hackers)
+
+#<HACKER #:HACKER-9234 called "Martin">
+#<HACKER #:HACKER-9235 called "Martin">
+#<HACKER #:HACKER-9236 called "Martin">
+#<HACKER #:HACKER-9237 called "Jim">
+#<HACKER #:HACKER-9238 called "Thomas">
+#<HACKER #:HACKER-9239 called "David">
+#<HACKER #:HACKER-9240 called "Thomas">
+#<HACKER #:HACKER-9241 called "Jim">
+#<HACKER #:HACKER-9242 called "Martin">
+#<HACKER #:HACKER-9243 called "Jim">
+#<HACKER #:HACKER-9244 called "Peter">
+#<HACKER #:HACKER-9245 called "Jim">
+#<HACKER #:HACKER-9246 called "Thomas">
+#<HACKER #:HACKER-9247 called "Jans">
+#<HACKER #:HACKER-9248 called "Peter">
+#<HACKER #:HACKER-9249 called "Peter">
+#<HACKER #:HACKER-9250 called "Arthur">
+#<HACKER #:HACKER-9251 called "Thomas">
+#<HACKER #:HACKER-9252 called "James">
+#<HACKER #:HACKER-9253 called "Martin">
+#<LISP-HACKER #:HACKER-9254 called "Jans">
+#<LISP-HACKER #:HACKER-9255 called "Martin">
+#<LISP-HACKER #:HACKER-9256 called "Thomas">
+#<LISP-HACKER #:HACKER-9257 called "Klaus">
+#<LISP-HACKER #:HACKER-9258 called "David">
+#<LISP-HACKER #:HACKER-9259 called "Thomas">
+#<LISP-HACKER #:HACKER-9260 called "David">
+#<LISP-HACKER #:HACKER-9261 called "James">
+#<LISP-HACKER #:HACKER-9262 called "Peter">
+#<LISP-HACKER #:HACKER-9263 called "Peter">
+NIL
+T
+
+TEST-RS 4 > (show-hackers)
+
+"Hackers indexed by object id."
+#<HACKER #:HACKER-9234 called "Martin">
+#<HACKER #:HACKER-9235 called "Martin">
+#<HACKER #:HACKER-9236 called "Martin">
+#<HACKER #:HACKER-9237 called "Jim">
+#<HACKER #:HACKER-9238 called "Thomas">
+#<HACKER #:HACKER-9239 called "David">
+#<HACKER #:HACKER-9240 called "Thomas">
+#<HACKER #:HACKER-9241 called "Jim">
+#<HACKER #:HACKER-9242 called "Martin">
+#<HACKER #:HACKER-9243 called "Jim">
+#<HACKER #:HACKER-9244 called "Peter">
+#<HACKER #:HACKER-9245 called "Jim">
+#<HACKER #:HACKER-9246 called "Thomas">
+#<HACKER #:HACKER-9247 called "Jans">
+#<HACKER #:HACKER-9248 called "Peter">
+#<HACKER #:HACKER-9249 called "Peter">
+#<HACKER #:HACKER-9250 called "Arthur">
+#<HACKER #:HACKER-9251 called "Thomas">
+#<HACKER #:HACKER-9252 called "James">
+#<HACKER #:HACKER-9253 called "Martin">
+#<LISP-HACKER #:HACKER-9254 called "Jans">
+#<LISP-HACKER #:HACKER-9255 called "Martin">
+#<LISP-HACKER #:HACKER-9256 called "Thomas">
+#<LISP-HACKER #:HACKER-9257 called "Klaus">
+#<LISP-HACKER #:HACKER-9258 called "David">
+#<LISP-HACKER #:HACKER-9259 called "Thomas">
+#<LISP-HACKER #:HACKER-9260 called "David">
+#<LISP-HACKER #:HACKER-9261 called "James">
+#<LISP-HACKER #:HACKER-9262 called "Peter">
+#<LISP-HACKER #:HACKER-9263 called "Peter">
+"Hackers indexed by name."
+#<HACKER #:HACKER-9250 called "Arthur">
+#<LISP-HACKER #:HACKER-9260 called "David">
+#<LISP-HACKER #:HACKER-9258 called "David">
+#<HACKER #:HACKER-9239 called "David">
+#<LISP-HACKER #:HACKER-9261 called "James">
+#<HACKER #:HACKER-9252 called "James">
+#<LISP-HACKER #:HACKER-9254 called "Jans">
+#<HACKER #:HACKER-9247 called "Jans">
+#<HACKER #:HACKER-9245 called "Jim">
+#<HACKER #:HACKER-9243 called "Jim">
+#<HACKER #:HACKER-9241 called "Jim">
+#<HACKER #:HACKER-9237 called "Jim">
+#<LISP-HACKER #:HACKER-9257 called "Klaus">
+#<LISP-HACKER #:HACKER-9255 called "Martin">
+#<HACKER #:HACKER-9253 called "Martin">
+#<HACKER #:HACKER-9242 called "Martin">
+#<HACKER #:HACKER-9236 called "Martin">
+#<HACKER #:HACKER-9235 called "Martin">
+#<HACKER #:HACKER-9234 called "Martin">
+#<LISP-HACKER #:HACKER-9263 called "Peter">
+#<LISP-HACKER #:HACKER-9262 called "Peter">
+#<HACKER #:HACKER-9249 called "Peter">
+#<HACKER #:HACKER-9248 called "Peter">
+#<HACKER #:HACKER-9244 called "Peter">
+#<LISP-HACKER #:HACKER-9259 called "Thomas">
+#<LISP-HACKER #:HACKER-9256 called "Thomas">
+#<HACKER #:HACKER-9251 called "Thomas">
+#<HACKER #:HACKER-9246 called "Thomas">
+#<HACKER #:HACKER-9240 called "Thomas">
+#<HACKER #:HACKER-9238 called "Thomas">
+"Hackers indexed by hacker-id."
+#<HACKER #:HACKER-9234 called "Martin">
+#<HACKER #:HACKER-9235 called "Martin">
+#<HACKER #:HACKER-9236 called "Martin">
+#<HACKER #:HACKER-9237 called "Jim">
+#<HACKER #:HACKER-9238 called "Thomas">
+#<HACKER #:HACKER-9239 called "David">
+#<HACKER #:HACKER-9240 called "Thomas">
+#<HACKER #:HACKER-9241 called "Jim">
+#<HACKER #:HACKER-9242 called "Martin">
+#<HACKER #:HACKER-9243 called "Jim">
+#<HACKER #:HACKER-9244 called "Peter">
+#<HACKER #:HACKER-9245 called "Jim">
+#<HACKER #:HACKER-9246 called "Thomas">
+#<HACKER #:HACKER-9247 called "Jans">
+#<HACKER #:HACKER-9248 called "Peter">
+#<HACKER #:HACKER-9249 called "Peter">
+#<HACKER #:HACKER-9250 called "Arthur">
+#<HACKER #:HACKER-9251 called "Thomas">
+#<HACKER #:HACKER-9252 called "James">
+#<HACKER #:HACKER-9253 called "Martin">
+#<LISP-HACKER #:HACKER-9254 called "Jans">
+#<LISP-HACKER #:HACKER-9255 called "Martin">
+#<LISP-HACKER #:HACKER-9256 called "Thomas">
+#<LISP-HACKER #:HACKER-9257 called "Klaus">
+#<LISP-HACKER #:HACKER-9258 called "David">
+#<LISP-HACKER #:HACKER-9259 called "Thomas">
+#<LISP-HACKER #:HACKER-9260 called "David">
+#<LISP-HACKER #:HACKER-9261 called "James">
+#<LISP-HACKER #:HACKER-9262 called "Peter">
+#<LISP-HACKER #:HACKER-9263 called "Peter">
+"Lisp hackers."
+#<LISP-HACKER #:HACKER-9254 called "Jans">
+#<LISP-HACKER #:HACKER-9255 called "Martin">
+#<LISP-HACKER #:HACKER-9256 called "Thomas">
+#<LISP-HACKER #:HACKER-9257 called "Klaus">
+#<LISP-HACKER #:HACKER-9258 called "David">
+#<LISP-HACKER #:HACKER-9259 called "Thomas">
+#<LISP-HACKER #:HACKER-9260 called "David">
+#<LISP-HACKER #:HACKER-9261 called "James">
+#<LISP-HACKER #:HACKER-9262 called "Peter">
+#<LISP-HACKER #:HACKER-9263 called "Peter">
+"Non-lisp hackers."
+#<HACKER #:HACKER-9234 called "Martin">
+#<HACKER #:HACKER-9235 called "Martin">
+#<HACKER #:HACKER-9236 called "Martin">
+#<HACKER #:HACKER-9237 called "Jim">
+#<HACKER #:HACKER-9238 called "Thomas">
+#<HACKER #:HACKER-9239 called "David">
+#<HACKER #:HACKER-9240 called "Thomas">
+#<HACKER #:HACKER-9241 called "Jim">
+#<HACKER #:HACKER-9242 called "Martin">
+#<HACKER #:HACKER-9243 called "Jim">
+#<HACKER #:HACKER-9244 called "Peter">
+#<HACKER #:HACKER-9245 called "Jim">
+#<HACKER #:HACKER-9246 called "Thomas">
+#<HACKER #:HACKER-9247 called "Jans">
+#<HACKER #:HACKER-9248 called "Peter">
+#<HACKER #:HACKER-9249 called "Peter">
+#<HACKER #:HACKER-9250 called "Arthur">
+#<HACKER #:HACKER-9251 called "Thomas">
+#<HACKER #:HACKER-9252 called "James">
+#<HACKER #:HACKER-9253 called "Martin">
+"Hacker object ids."
+36
+65
+69
+73
+78
+83
+88
+92
+96
+100
+104
+109
+113
+117
+122
+126
+130
+135
+139
+144
+148
+160
+164
+168
+173
+177
+181
+185
+189
+193
+NIL
+T
+
+|#
--- /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/26 12:55:34 1.6
+++ /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/29 11:41:40 1.7
@@ -1,4 +1,4 @@
-;; $Id: mop.lisp,v 1.6 2006/08/26 12:55:34 alemmens Exp $
+;; $Id: mop.lisp,v 1.7 2006/08/29 11:41:40 alemmens Exp $
(in-package :rucksack)
@@ -48,6 +48,47 @@
())
+;;
+;; Copying and comparing slot definitions
+;;
+
+(defun copy-slot-definition (slot-def)
+ (make-instance (class-of slot-def)
+ :name (slot-definition-name slot-def)
+ :initargs (slot-definition-initargs slot-def)
+ :readers (slot-definition-readers slot-def)
+ :writers (slot-definition-writers slot-def)
+ :allocation (slot-definition-allocation slot-def)
+ :type (slot-definition-type slot-def)
+ ;; Our own options.
+ :persistence (slot-persistence slot-def)
+ :index (slot-index slot-def)
+ :unique (slot-unique slot-def)))
+
+
+(defun slot-definition-equal (slot-1 slot-2)
+ (and (equal (slot-persistence slot-1) (slot-persistence slot-2))
+ (index-spec-equal (slot-index slot-1) (slot-index slot-2))
+ (equal (slot-unique slot-1) (slot-unique slot-2))))
+
+
+(defun compare-slots (old-slots slots)
+ "Returns three values: a list of added slots, a list of discarded slots
+and a list of changed (according to SLOT-DEFINITION-EQUAL) slots."
+ (let ((added-slots (set-difference slots old-slots
+ :key #'slot-definition-name))
+ (discarded-slots (set-difference old-slots slots
+ :key #'slot-definition-name))
+ (changed-slots
+ (loop for slot in slots
+ for old-slot = (find (slot-definition-name slot) old-slots
+ :key #'slot-definition-name)
+ if (and old-slot
+ (not (slot-definition-equal slot old-slot)))
+ collect slot)))
+ (values added-slots discarded-slots changed-slots)))
+
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod validate-superclass ((class standard-class)
@@ -78,8 +119,8 @@
(defmethod clos:process-a-class-option ((class persistent-class)
option-name
value)
- (if (member value '(:index :unique))
- (list option-name value)
+ (if (eql option-name :index)
+ (cons option-name value)
(call-next-method)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -108,28 +149,23 @@
(ensure-class-schema class '())
result))
+
(defmethod reinitialize-instance :around ((class persistent-class)
&rest args
&key direct-superclasses
&allow-other-keys)
- (let* ((old-slot-defs (class-direct-slots class))
- ;; Create a simple alist with slot name as key and
- ;; a list with slot-index and slot-unique as value.
- (old-slot-indexes (loop for slot-def in old-slot-defs
- collect (list (slot-definition-name slot-def)
- (slot-index slot-def)
- (slot-unique slot-def)))))
- (let ((result (apply #'call-next-method
- class
- :direct-superclasses (maybe-add-persistent-object-class
- class
- direct-superclasses)
- ;; Tell Lispworks that it shouldn't bypass
- ;; slot-value-using-class.
- #+lispworks :optimize-slot-access #+lispworks nil
- args)))
- (ensure-class-schema class old-slot-indexes)
- result)))
+ (let* ((old-slots (mapcar #'copy-slot-definition (class-direct-slots class)))
+ (result (apply #'call-next-method
+ class
+ :direct-superclasses (maybe-add-persistent-object-class
+ class
+ direct-superclasses)
+ ;; Tell Lispworks that it shouldn't bypass
+ ;; SLOT-VALUE-USING-CLASS.
+ #+lispworks :optimize-slot-access #+lispworks nil
+ args)))
+ (ensure-class-schema class old-slots)
+ result))
(defun maybe-add-persistent-object-class (class direct-superclasses)
@@ -146,7 +182,7 @@
direct-superclasses
(cons root-class direct-superclasses))))
-(defun ensure-class-schema (class old-slot-indexes)
+(defun ensure-class-schema (class old-slots)
;; Update class and slot indexes.
(when (or (class-index class)
(some #'slot-persistence (class-direct-slots class)))
@@ -158,15 +194,25 @@
(let ((rucksack (current-rucksack)))
(when rucksack
(rucksack-update-class-index rucksack class)
- (rucksack-update-slot-indexes rucksack class old-slot-indexes))))
- ;; DO: Update schema in schema table, when necessary.
- 'DO-THIS)
+ (rucksack-update-slot-indexes rucksack class old-slots)
+ ;; Update schema in schema table, if necessary.
+ (rucksack-maybe-update-schema rucksack class old-slots)))))
(defmethod finalize-inheritance :after ((class persistent-class))
;; Register all persistent slots.
(setf (class-persistent-slots class)
- (remove-if-not #'slot-persistence (class-slots class))))
+ (remove-if-not #'slot-persistence (class-slots class)))
+ ;;
+ (when (or (class-index class) (class-persistent-slots class))
+ (let ((rucksack (current-rucksack)))
+ (when rucksack
+ (let* ((schema-table (schema-table (rucksack-cache rucksack)))
+ (schema (find-schema-for-class schema-table class)))
+ (when schema
+ (setf (persistent-slot-names schema)
+ (mapcar #'slot-definition-name
+ (class-persistent-slots class)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -211,5 +257,3 @@
;; Return the effective slot definition.
effective-slotdef))
-
-
--- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/26 12:55:34 1.10
+++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/29 11:41:40 1.11
@@ -1,4 +1,4 @@
-;; $Id: objects.lisp,v 1.10 2006/08/26 12:55:34 alemmens Exp $
+;; $Id: objects.lisp,v 1.11 2006/08/29 11:41:40 alemmens Exp $
(in-package :rucksack)
@@ -396,9 +396,9 @@
(rucksack :initarg :rucksack :reader rucksack :persistence nil :index nil))
(:default-initargs
:rucksack *rucksack*)
- (:metaclass persistent-class
- :indexed nil
- :documentation "Classes of metaclass PERSISTENT-CLASS automatically
+ (:metaclass persistent-class)
+ (:index nil)
+ (:documentation "Classes of metaclass PERSISTENT-CLASS automatically
inherit from this class."))
@@ -733,3 +733,28 @@
(internal-rucksack-error "Object-id mismatch (required: ~D; actual: ~D)."
object-id id))
(values id nr-slots schema-id transaction-id prev-version)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Updating persistent instances
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; When a persistent object must be loaded from disk, Rucksack loads the
+;; schema nr and finds the corresponding schema. If the schema is obsolete
+;; (i.e. there is a schema for the same class with a higher version number),
+;; Rucksack calls the generic function UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS
+;; after calling ALLOCATE-INSTANCE for the current class version. The generic
+;; function is very similar to UPDATE-INSTANCE-FOR-REDEFINED-CLASS: it takes a
+;; list of added slots, a list of deleted slots and a property list containing
+;; the slot names and values for slots that were discarded and had values.
+
+(defgeneric update-persistent-instance-for-redefined-class
+ (instance added-slots discarded-slots property-list
+ &rest initargs &key &allow-other-keys)
+ (:method ((instance persistent-object) added-slots discarded-slots property-list
+ &rest initargs &key &allow-other-keys)
+ ;; The default method for this function ignores the deleted slots,
+ ;; initializes added slots according to their initargs or initforms and
+ ;; initializes shared slots (that did not change) with the values that
+ ;; were saved on disk.
+ 'DO-IMPLEMENT-THIS))
--- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/26 12:55:34 1.12
+++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/29 11:41:40 1.13
@@ -1,4 +1,4 @@
-;; $Id: rucksack.lisp,v 1.12 2006/08/26 12:55:34 alemmens Exp $
+;; $Id: rucksack.lisp,v 1.13 2006/08/29 11:41:40 alemmens Exp $
(in-package :rucksack)
@@ -66,15 +66,14 @@
class index (i.e. a class index that's specified anymore in the class
option) is removed, new class indexes are added."))
-(defgeneric rucksack-update-slot-indexes (rucksack class old-slot-indexes)
+(defgeneric rucksack-update-slot-indexes (rucksack class old-slots)
(:documentation
"Compares the current slot indexes for CLASS to the slot indexes
that are specified in the slot options for the direct slots of CLASS.
Obsolete slot indexes (i.e. slot indexes that are not specified
-anymore in the slot options) are removed, new slot indexes are
-added.
- OLD-SLOT-INDEXES is a list with the name, index and unique-p info
-of each slot."))
+anymore in the slot options or indexes for slots that don't exist
+anymore) are removed, new slot indexes are added.
+ OLD-SLOTS is a list with the previous slot definitions."))
(defgeneric rucksack-add-class-index (rucksack class-designator &key errorp))
@@ -552,57 +551,85 @@
:no-change))))
+
(defmethod rucksack-update-slot-indexes ((rucksack standard-rucksack)
(class persistent-class)
- old-slot-indexes)
- (dolist (slot (class-direct-slots class))
- (let* ((index-spec (and (slot-persistence slot)
- (or (find-index-spec (slot-index slot) :errorp nil)
- (slot-index slot))))
- (unique-p (slot-unique slot)))
- (multiple-value-bind (current-index-spec current-unique-p)
- (find-old-index-spec (slot-definition-name slot) old-slot-indexes)
- (cond ((and (index-spec-equal index-spec current-index-spec)
- (eql unique-p current-unique-p))
- ;; We keep the same index: no change needed.
- :no-change)
- ((and current-index-spec (null index-spec))
- ;; The index is not wanted anymore: remove it.
- (rucksack-remove-slot-index rucksack class slot :errorp t))
- ((and (null current-index-spec) index-spec)
- ;; We didn't have an index but we need one now: add one.
- (rucksack-add-slot-index rucksack class slot index-spec unique-p
+ old-slots)
+ (let ((direct-slots (class-direct-slots class)))
+ ;; Remove indexes for old slots that don't exist anymore.
+ (loop for slot in old-slots
+ for slot-name = (slot-definition-name slot)
+ unless (find slot-name direct-slots :key #'slot-definition-name)
+ do (rucksack-remove-slot-index rucksack class slot-name :errorp t))
+ ;; Update indexes for the current set of direct slots.
+ (dolist (slot direct-slots)
+ (let ((index-spec (and (slot-persistence slot)
+ (or (find-index-spec (slot-index slot) :errorp nil)
+ (slot-index slot))))
+ (unique-p (slot-unique slot))
+ (slot-name (slot-definition-name slot)))
+ (multiple-value-bind (current-index-spec current-unique-p)
+ (find-old-index-spec slot-name old-slots)
+ (cond ((and (index-spec-equal index-spec current-index-spec)
+ (eql unique-p current-unique-p))
+ ;; We keep the same index: no change needed.
+ :no-change)
+ ((and current-index-spec (null index-spec))
+ ;; The index is not wanted anymore: remove it.
+ (rucksack-remove-slot-index rucksack class slot :errorp t))
+ ((and (null current-index-spec) index-spec)
+ ;; We didn't have an index but we need one now: add one.
+ (add-and-fill-slot-index rucksack class slot index-spec unique-p))
+ ((and current-index-spec index-spec)
+ ;; We have an index but need a different one now.
+ (replace-slot-index rucksack class slot index-spec unique-p))))))))
+
+
+(defun add-and-fill-slot-index (rucksack class slot index-spec unique-p)
+ ;; We didn't have an index but we need one now: add one.
+ (let ((index (rucksack-add-slot-index rucksack class slot index-spec unique-p
:errorp t))
- ((and current-index-spec index-spec)
- ;; We have an index but need a different one now. This requires
- ;; some care because we need to re-index all objects from the old
- ;; index.
- (let ((current-index (rucksack-slot-index rucksack class slot))
- (new-index (rucksack-add-slot-index rucksack class slot
- index-spec
- unique-p
- :errorp nil)))
- ;; Re-index all objects for the new index.
- ;; DO: This re-indexing can cause an error (e.g. if the old
- ;; index has non-unique keys, the new index has unique keys
- ;; and some keys occur more than once). We need to handle
- ;; that error here and offer some decent restarts (e.g.
- ;; remove the index entirely, or go back to the old index).
- (map-index current-index
- (lambda (slot-value object-id)
- (index-insert new-index slot-value object-id)))
- ;; We don't need to remove the old index explicitly, because
- ;; RUCKSACK-ADD-SLOT-INDEX already did that for us.
- )))))))
-
-(defun find-old-index-spec (slot-name old-slot-indexes)
- (let ((slot-info (cdr (assoc slot-name old-slot-indexes))))
- (and slot-info
- (destructuring-bind (index-spec-designator unique-p)
- slot-info
- (values (or (find-index-spec index-spec-designator :errorp nil)
- index-spec-designator)
- unique-p)))))
+ (slot-name (slot-definition-name slot)))
+ ;; Index all instances for the new index.
+ ;; NOTE: This will only work if the class is indexed, otherwise there is no
+ ;; affordable way to find all instances of the class.
+ (when (class-index class)
+ (rucksack-map-class rucksack class
+ (lambda (object)
+ (when (slot-boundp object slot-name)
+ (index-insert index (slot-value object slot-name)
+ (object-id object))))))))
+
+
+(defun replace-slot-index (rucksack class slot index-spec unique-p)
+ ;; We have an index but need a different one now. This requires
+ ;; some care because we need to re-index all objects from the old
+ ;; index.
+ (let ((current-index (rucksack-slot-index rucksack class slot))
+ (new-index (rucksack-add-slot-index rucksack class slot
+ index-spec
+ unique-p
+ :errorp nil)))
+ ;; Re-index all objects for the new index.
+ ;; DO: This re-indexing can cause an error (e.g. if the old
+ ;; index has non-unique keys, the new index has unique keys
+ ;; and some keys occur more than once). We need to handle
+ ;; that error here and offer some decent restarts (e.g.
+ ;; remove the index entirely, or go back to the old index).
+ (map-index current-index
+ (lambda (slot-value object-id)
+ (index-insert new-index slot-value object-id)))
+ ;; We don't need to remove the old index explicitly, because
+ ;; RUCKSACK-ADD-SLOT-INDEX already did that for us.
+ ))
+
+(defun find-old-index-spec (slot-name old-slots)
+ (let ((slot (find slot-name old-slots :key #'slot-definition-name)))
+ (and slot
+ (with-slots (index unique)
+ slot
+ (values (or (find-index-spec index :errorp nil) index)
+ unique)))))
@@ -785,7 +812,7 @@
(let ((slot-index-table (btree-search (slot-index-tables rucksack) class
:errorp errorp)))
(handler-bind ((btree-deletion-error #'oops))
- (btree-delete-key slot slot-index-table
+ (btree-delete-key slot-index-table slot
:if-does-not-exist (if errorp :error :ignore)))))
slot)))
@@ -914,3 +941,18 @@
(declare (ignore index))
(push class-name result))))
result))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Schema updates
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod rucksack-maybe-update-schema ((rucksack standard-rucksack)
+ class
+ old-slot-indexes)
+ ;; This is just a thin wrapper, so you can customize it if necessary.
+ (maybe-update-schema (schema-table (rucksack-cache rucksack))
+ class
+ old-slot-indexes))
+
+
+
\ No newline at end of file
--- /project/rucksack/cvsroot/rucksack/schema-table.lisp 2006/08/10 12:36:17 1.3
+++ /project/rucksack/cvsroot/rucksack/schema-table.lisp 2006/08/29 11:41:40 1.4
@@ -1,30 +1,50 @@
-;; $Id: schema-table.lisp,v 1.3 2006/08/10 12:36:17 alemmens Exp $
+;; $Id: schema-table.lisp,v 1.4 2006/08/29 11:41:40 alemmens Exp $
(in-package :rucksack)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Schema table
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
+;;;
;;; The schema table keeps track of all classes that have instances that
;;; were saved by the cache.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Schema
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass schema ()
- ((id :initarg :id :reader schema-id)
+ ((id :initarg :id :reader schema-id
+ :documentation "A unique number that identifies a schema.")
(class-name :initarg :class-name :reader schema-class-name)
- (version :initarg :version :initform 0 :reader schema-version)
- ;; DO: Keep track of all slots: their names, their initforms and their
- ;; persistence related slot options (persistence and index).
- ;; Also keep track of persistence related class options here?
+ (version :initarg :version :initform 0 :reader schema-version
+ :documentation "The combination of class-name and version number
+also uniquely identifies a schema.")
+ ;; Slot info
+ ;; DO: Keep track of all slots: their names, their initforms and their
+ ;; persistence related slot options.
+ ;; PERSISTENT-SLOT-NAMES is set during FINALIZE-INHERITANCE.
(persistent-slot-names :initarg :persistent-slot-names
- :reader persistent-slot-names)))
+ :accessor persistent-slot-names
+ :documentation "A list with the names of all
+persistent effective slots.")
+ ;; Class info
+ (class-index :initarg :class-index :reader class-index)))
(defmethod nr-persistent-slots ((schema schema))
(length (persistent-slot-names schema)))
-;;
-;;
-;;
+(defmethod print-object ((schema schema) stream)
+ (print-unreadable-object (schema stream :type t :identity t)
+ (format stream "~A ~D.~D with ~D slots"
+ (schema-class-name schema)
+ (schema-id schema)
+ (schema-version schema)
+ (nr-persistent-slots schema))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Schema table
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass schema-table ()
((pathname :initarg :pathname :accessor schema-table-pathname)
@@ -34,53 +54,102 @@
:reader schema-table-by-name)
(by-id :initform (make-hash-table)
:documentation "A mapping from a schema id to a schema."
- :reader schema-table-by-id)
+ :accessor schema-table-by-id)
(highest-schema-id :initform 0 :accessor highest-schema-id)
(dirty-p :initform nil :accessor dirty-p
:documentation "When dirty, the schema table will be saved
at the next commit.")))
+;;
+;; Serializing schema table
+;;
+
+(defmethod saved-slots ((table schema-table))
+ ;; Don't serialize the BY-ID hash table, but rebuild it by hand after the
+ ;; other slots are deserialized. This is necessary because schemas are
+ ;; referenced more than once, and the serializer doesn't handle shared
+ ;; objects (unless they're 'real' persistent objects).
+ '(pathname by-name highest-schema-id))
+
+(defmethod load-slots :after ((table schema-table) serializer)
+ ;; Reconstruct the BY-ID hash table. This method is called by the
+ ;; serializer after an object is deserialized.
+ (setf (schema-table-by-id table) (make-hash-table))
+ (loop for schemas being the hash-value of (schema-table-by-name table)
+ do (loop for schema in schemas
+ do (setf (gethash (schema-id schema)
+ (schema-table-by-id table))
+ schema)))
+ ;;
+ (setf (dirty-p table) nil)
+ table)
+
+;;
+;; Finding schemas
+;;
+
+(defmethod fresh-schema-id ((table schema-table))
+ (prog1 (highest-schema-id table)
+ (incf (highest-schema-id table))))
+
(defmethod find-schema-for-id ((table schema-table) id &key (errorp t))
(or (gethash id (schema-table-by-id table))
(and errorp
(error "Can't find schema with id ~D in ~S." id table))))
+(defmethod find-schema-for-class ((table schema-table) class)
+ ;; Returns the most recent schema for a class
+ ;; (or NIL if there is no schema for the class).
+ (first (gethash (class-name class) (schema-table-by-name table))))
+
+(defmethod schema-obsolete-p ((table schema-table) schema)
+ (let ((most-recent-schema (find-schema-for-class table
+ (schema-class-name schema))))
+ (not (= (schema-version most-recent-schema)
+ (schema-version schema)))))
+
(defmethod find-or-create-schema-for-object ((table schema-table) object)
;; NOTE: This assumes that the class hasn't changed without the
;; schema table knowing about it. We probably must assume that,
;; otherwise we'd have a very expensive check whenever we want to
;; save an object.
- (let ((class-name (class-name (class-of object))))
- (or (first (gethash class-name (schema-table-by-name table)))
+ (let ((class (class-of object)))
+ (or (find-schema-for-class table class)
;; There is no schema yet. Create it.
- (let ((new-schema (create-schema-using-class table
- (class-of object)
- object)))
- (add-schema table new-schema)
- new-schema))))
-
-(defmethod create-schema-using-class ((table schema-table) class object)
- (let ((persistent-slots (compute-persistent-slot-names class object)))
- (make-instance 'schema
- :class-name (class-name class)
- :id (highest-schema-id table)
- :version 0
- :persistent-slot-names persistent-slots)))
+ (let ((persistent-slots (compute-persistent-slot-names class object)))
+ (create-schema table class 0 persistent-slots)))))
+
+(defmethod create-schema ((table schema-table) class version
+ &optional (persistent-slots '()))
+ (let ((schema (make-instance 'schema
+ :id (fresh-schema-id table)
+ :class-name (class-name class)
+ :version version
+ :persistent-slot-names persistent-slots
+ :class-index (compute-class-index class))))
+ (add-schema table schema)
+ schema))
+
+
(defmethod compute-persistent-slot-names ((class persistent-class) object)
(declare (ignore object))
(mapcar #'slot-definition-name (class-persistent-slots class)))
-
+(defgeneric compute-class-index (class)
+ (:method ((class persistent-class))
+ (class-index class))
+ (:method ((class t))
+ nil))
(defmethod add-schema ((table schema-table) (schema schema))
(setf (gethash (schema-id schema) (schema-table-by-id table))
schema)
(push schema
(gethash (schema-class-name schema) (schema-table-by-name table) '()))
- (incf (highest-schema-id table))
(setf (dirty-p table) t))
+
(defmethod save-schema-table ((table schema-table))
;; Clear dirty flag first, because it's saved (and loaded) too.
(setf (dirty-p table) nil)
@@ -121,3 +190,25 @@
(when (and commit (dirty-p table))
(save-schema-table table)))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Schema updates
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod maybe-update-schema ((table schema-table) class old-slots)
+ ;; Rucksack analyzes the new class definition; if it's different from the
+ ;; previous version, a new schema is added to the schema table. From that
+ ;; moment, when an instance of the redefined class is created it will be
+ ;; saved with the new schema id.
+ ;; This is called by the (RE-)INITIALIZE-INSTANCE method for
+ ;; PERSISTENT-CLASS.
+ (let ((old-schema (find-schema-for-class table class)))
+ (if (null old-schema)
+ ;; There is no schema yet: create the first one.
+ (create-schema table class 0)
+ ;; There is a schema: create a new one if necessary.
+ (multiple-value-bind (added-slots discarded-slots changed-slots)
+ (compare-slots old-slots (class-direct-slots class))
+ (when (or added-slots discarded-slots changed-slots
+ (not (equal (class-index class) (class-index old-schema))))
+ ;; Add a new schema for this class.
+ (create-schema table class (1+ (schema-version old-schema))))))))
--- /project/rucksack/cvsroot/rucksack/serialize.lisp 2006/08/24 15:21:25 1.7
+++ /project/rucksack/cvsroot/rucksack/serialize.lisp 2006/08/29 11:41:40 1.8
@@ -1,4 +1,4 @@
-;; $Id: serialize.lisp,v 1.7 2006/08/24 15:21:25 alemmens Exp $
+;; $Id: serialize.lisp,v 1.8 2006/08/29 11:41:40 alemmens Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Serialize
@@ -1105,7 +1105,8 @@
(let ((nr-slots (deserialize stream))
(slots (saved-slots object)))
(unless (= nr-slots (length slots))
- (error "Slot mismatch while deserializing a standard object."))
+ (error "Slot mismatch while deserializing a standard object of class ~S."
+ (class-of object)))
(loop for slot-name in (saved-slots object)
do (let ((marker (read-next-marker stream)))
(if (eql marker +unbound-slot+)
More information about the rucksack-cvs
mailing list