[rucksack-cvs] CVS rucksack
alemmens
alemmens at common-lisp.net
Tue Aug 29 13:50:19 UTC 2006
Update of /project/rucksack/cvsroot/rucksack
In directory clnet:/tmp/cvs-serv6896
Modified Files:
example-1.lisp objects.lisp package.lisp schema-table.lisp
Log Message:
Partial implementation of UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS
and friends.
--- /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/29 11:41:40 1.3
+++ /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/29 13:50:18 1.4
@@ -1,4 +1,4 @@
-;; $Id: example-1.lisp,v 1.3 2006/08/29 11:41:40 alemmens Exp $
+;; $Id: example-1.lisp,v 1.4 2006/08/29 13:50:18 alemmens Exp $
(in-package :test-rucksack)
@@ -7,6 +7,7 @@
;;;
;;; To run this example:
;;; - compile and load this file
+;;; - (IN-PACKAGE :TEST-RS)
;;; - (CREATE-HACKERS)
;;; - (SHOW-HACKERS)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/29 11:41:40 1.11
+++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/29 13:50:18 1.12
@@ -1,4 +1,4 @@
-;; $Id: objects.lisp,v 1.11 2006/08/29 11:41:40 alemmens Exp $
+;; $Id: objects.lisp,v 1.12 2006/08/29 13:50:18 alemmens Exp $
(in-package :rucksack)
@@ -663,31 +663,53 @@
(transaction-id transaction)
(heap cache))
(declare (ignore id))
- (let* ((schema (find-schema-for-id (schema-table cache) schema-id))
+ (let* ((table (schema-table cache))
+ (schema (find-schema-for-id table schema-id))
(object (allocate-instance (find-class (schema-class-name schema)))))
(unless (= nr-slots (nr-persistent-slots schema))
(internal-rucksack-error
"Schema inconsistency (expected ~D slots, got ~D slots)."
(nr-persistent-slots schema)
nr-slots))
- ;; Load and set slot values.
- ;; DO: We should probably initialize the transient slots to their
- ;; initforms here. And we should also deal with changed classes
- ;; at this point.
- ;; NOTE: The MOP doesn't intercept the (setf slot-value) here,
- ;; because the rucksack and object-id slots are still unbound.
- (loop for slot-name in (persistent-slot-names schema)
- do (let ((marker (read-next-marker buffer)))
- (if (eql marker +unbound-slot+)
- (slot-makunbound object slot-name)
- (setf (slot-value object slot-name)
- (deserialize-contents marker buffer)))))
- ;; Set CACHE, OBJECT-ID and TRANSACTION-ID slots if it's a persistent
- ;; object. This needs to be done before persistent slots are initialized.
- (when (typep object '(or persistent-object persistent-data))
- (setf (slot-value object 'rucksack) (current-rucksack)
- (slot-value object 'object-id) object-id
- (slot-value object 'transaction-id) (transaction-id transaction)))
+ (let ((added-slots '())
+ (discarded-slots '())
+ ;; DISCARDED-SLOT-VALUES is a list of discarded slot names and
+ ;; their (obsolete) values.
+ (discarded-slot-values '()))
+ (when (schema-obsolete-p schema)
+ (setf added-slots (schema-added-slot-names schema)
+ discarded-slots (schema-discarded-slot-names schema)))
+ ;; Load and set slot values.
+ ;; DO: We should probably initialize the transient slots to their
+ ;; initforms here.
+ ;; NOTE: The MOP doesn't intercept the (setf slot-value) here,
+ ;; because the rucksack and object-id slots are still unbound.
+ (loop for slot-name in (persistent-slot-names schema)
+ do (let ((marker (read-next-marker buffer))
+ (old-slot-p (member slot-name discarded-slots)))
+ (if (eql marker +unbound-slot+)
+ (unless old-slot-p
+ (slot-makunbound object slot-name))
+ ;; Deserialize the value
+ (let ((value (deserialize-contents marker buffer)))
+ (if old-slot-p
+ (progn
+ (push value discarded-slot-values)
+ (push slot-name discarded-slot-values))
+ (setf (slot-value object slot-name) value))))))
+ ;; Set CACHE, OBJECT-ID and TRANSACTION-ID slots if it's a persistent
+ ;; object.
+ (when (typep object '(or persistent-object persistent-data))
+ (setf (slot-value object 'rucksack) (current-rucksack)
+ (slot-value object 'object-id) object-id
+ (slot-value object 'transaction-id) (transaction-id transaction)))
+ ;; Call UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS if necessary.
+ (when (schema-obsolete-p schema)
+ (update-persistent-instance-for-redefined-class
+ object
+ added-slots
+ discarded-slots
+ discarded-slot-values)))
;;
(values object most-recent-p))))
@@ -753,8 +775,15 @@
&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))
+ ;; Default method: ignore the discarded slots and initialize added slots
+ ;; according to their initargs or initforms.
+ (let ((slots (class-slots (class-of instance))))
+ (loop for slot-name in added-slots
+ for slot = (find slot-name slots :key #'slot-definition-name)
+ for initfunction = (and slot
+ (slot-definition-initfunction slot))
+ when initfunction
+ ;; DO: Handle initargs!
+ do (setf (slot-value instance slot-name)
+ (funcall initfunction))))))
+
--- /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/24 15:21:25 1.8
+++ /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/29 13:50:18 1.9
@@ -1,4 +1,4 @@
-;; $Id: package.lisp,v 1.8 2006/08/24 15:21:25 alemmens Exp $
+;; $Id: package.lisp,v 1.9 2006/08/29 13:50:18 alemmens Exp $
#-(or allegro lispworks sbcl openmcl)
(error "Unsupported implementation: ~A" (lisp-implementation-type))
@@ -24,6 +24,7 @@
;; MOP related
#:persistent-class
+ #:update-persistent-instance-for-redefined-class
;; Objects
#:persistent-object
@@ -75,6 +76,8 @@
;; Conditions
#:rucksack-error #:simple-rucksack-error #:transaction-conflict
+ #:internal-rucksack-error
+ #:duplicate-slot-value #:slot-error
;; Indexes
#:map-index #:index-insert #:index-delete #:make-index
--- /project/rucksack/cvsroot/rucksack/schema-table.lisp 2006/08/29 11:41:40 1.4
+++ /project/rucksack/cvsroot/rucksack/schema-table.lisp 2006/08/29 13:50:18 1.5
@@ -1,4 +1,4 @@
-;; $Id: schema-table.lisp,v 1.4 2006/08/29 11:41:40 alemmens Exp $
+;; $Id: schema-table.lisp,v 1.5 2006/08/29 13:50:18 alemmens Exp $
(in-package :rucksack)
@@ -20,15 +20,15 @@
(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.
+ (obsolete-p :initform nil :accessor schema-obsolete-p)
+ ;; Slot info (computed during FINALIZE-INHERITANCE).
+ (added-slot-names :initform '() :accessor schema-added-slot-names)
+ (discarded-slot-names :initform '() :accessor schema-discarded-slot-names)
(persistent-slot-names :initarg :persistent-slot-names
:accessor persistent-slot-names
:documentation "A list with the names of all
persistent effective slots.")
- ;; Class info
+ ;; Class info (computed at schema creation time).
(class-index :initarg :class-index :reader class-index)))
(defmethod nr-persistent-slots ((schema schema))
@@ -102,11 +102,6 @@
;; (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
@@ -211,4 +206,9 @@
(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))))))))
+ (create-schema table class (1+ (schema-version old-schema)))
+ ;; Mark all older versions as obsolete.
+ (let ((old-schemas (rest (gethash (class-name class)
+ (schema-table-by-name table)))))
+ (loop for schema in old-schemas
+ do (setf (schema-obsolete-p schema) t))))))))
More information about the rucksack-cvs
mailing list