[rucksack-cvs] CVS rucksack
alemmens
alemmens at common-lisp.net
Thu Aug 31 15:47:59 UTC 2006
Update of /project/rucksack/cvsroot/rucksack
In directory clnet:/tmp/cvs-serv9153
Modified Files:
example-1.lisp index.lisp objects.lisp rucksack.lisp
Added Files:
test-schema-update-1a.lisp test-schema-update-1b.lisp
test-schema-update-1c.lisp
Log Message:
Add test cases for schema updates and user defined methods of
UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS.
Indexing: compare the specified slot/class indexes to the indexes that
exist in the rucksack, *not* to the indexes specified in the previous
version of the class definition. Otherwise we get inconsistencies when
we recompile class definitions from scratch with a rucksack that already
exists.
--- /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/30 14:05:40 1.5
+++ /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/31 15:47:58 1.6
@@ -1,4 +1,4 @@
-;; $Id: example-1.lisp,v 1.5 2006/08/30 14:05:40 alemmens Exp $
+;; $Id: example-1.lisp,v 1.6 2006/08/31 15:47:58 alemmens Exp $
(in-package :rucksack-test)
@@ -83,8 +83,9 @@
(defun show-indexes ()
(with-rucksack (r *hacker-rucksack*)
- (print (rs::rucksack-list-class-indexes r))
- (print (rs::rucksack-list-slot-indexes r))
+ (with-transaction ()
+ (print (rs::rucksack-list-class-indexes r))
+ (print (rs::rucksack-list-slot-indexes r)))
:ok))
--- /project/rucksack/cvsroot/rucksack/index.lisp 2006/08/26 12:55:34 1.6
+++ /project/rucksack/cvsroot/rucksack/index.lisp 2006/08/31 15:47:58 1.7
@@ -1,4 +1,4 @@
-;; $Id: index.lisp,v 1.6 2006/08/26 12:55:34 alemmens Exp $
+;; $Id: index.lisp,v 1.7 2006/08/31 15:47:58 alemmens Exp $
(in-package :rucksack)
@@ -39,16 +39,62 @@
;; index-spec-equal (index-spec-1 index-spec-2) [Function]
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Indexing
+;;; Index class
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defmethod map-index ((index btree) function
+(defclass index ()
+ ((spec :initarg :spec :reader index-spec)
+ (unique-keys-p :initarg :unique-keys-p :reader index-unique-keys-p)
+ (data :initarg :data :reader index-data
+ :documentation "The actual index data structure (e.g. a btree)."))
+ (:metaclass persistent-class)
+ (:index nil))
+
+(defmethod print-object ((index index) stream)
+ (print-unreadable-object (index stream :type t :identity t)
+ (format stream "~S with ~:[non-unique~;unique~] keys"
+ (index-spec index)
+ (index-unique-keys-p index))))
+
+(defmethod index-similar-p ((index-1 index) (index-2 index))
+ (and (index-spec-equal (index-spec index-1) (index-spec index-2))
+ (equal (index-unique-keys-p index-1) (index-unique-keys-p index-2))))
+
+;;
+;; Trampolines
+;;
+
+(defmethod map-index ((index index) function
&rest args
&key min max include-min include-max
- (equal nil equal-supplied)
+ (equal nil)
(order :ascending))
+ (declare (ignorable min max include-min include-max equal order))
+ (apply #'map-index-data (index-data index) function args))
+
+(defmethod index-insert ((index index) key value &key (if-exists :overwrite))
+ (index-data-insert (index-data index) key value
+ :if-exists if-exists))
+
+(defmethod index-delete ((index index) key value
+ &key (if-does-not-exist :ignore))
+ (index-data-delete (index-data index) key value
+ :if-does-not-exist if-does-not-exist))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Indexing
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; NOTE: If you define your own indexing data structures, you need to supply
+;; methods for the three generic functions below: MAP-INDEX-DATA,
+;; INDEX-DATA-INSERT and INDEX-DATA-DELETE.
+
+(defmethod map-index-data ((index btree) function
+ &rest args
+ &key min max include-min include-max
+ (equal nil equal-supplied)
+ (order :ascending))
(declare (ignorable min max include-min include-max))
(if equal-supplied
(let ((value (btree-search index equal :errorp nil :default-value index)))
@@ -57,30 +103,35 @@
(apply #'map-btree index function :order order args)))
-(defmethod index-insert ((index btree) key value &key (if-exists :overwrite))
+(defmethod index-data-insert ((index btree) key value
+ &key (if-exists :overwrite))
(btree-insert index key value :if-exists if-exists))
-(defmethod index-delete ((index btree) key value
- &key (if-does-not-exist :ignore))
+(defmethod index-data-delete ((index btree) key value
+ &key (if-does-not-exist :ignore))
(btree-delete index key value :if-does-not-exist if-does-not-exist))
-;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Index specs
-;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; An index spec is a symbol or a list starting with a symbol
;; and followed by a plist of keywords and values.
;; Examples: BTREE, (BTREE :KEY< < :VALUE= P-EQL)
+(defun make-index (index-spec unique-keys-p &key (class 'index))
+ ;; NOTE: All index data classes must accept the :UNIQUE-KEYS-P initarg.
+ (let ((data (if (symbolp index-spec)
+ (make-instance index-spec :unique-keys-p unique-keys-p)
+ (apply #'make-instance
+ (first index-spec)
+ :unique-keys-p unique-keys-p
+ (rest index-spec)))))
+ (make-instance class
+ :spec index-spec
+ :unique-keys-p unique-keys-p
+ :data data)))
-(defun make-index (index-spec unique-keys-p)
- ;; NOTE: All index classes must accept the :UNIQUE-KEYS-P initarg.
- (if (symbolp index-spec)
- (make-instance index-spec :unique-keys-p unique-keys-p)
- (apply #'make-instance
- (first index-spec)
- :unique-keys-p unique-keys-p
- (rest index-spec))))
(defun index-spec-equal (index-spec-1 index-spec-2)
"Returns T iff two index specs are equal."
--- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/30 14:05:40 1.13
+++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/31 15:47:58 1.14
@@ -1,4 +1,4 @@
-;; $Id: objects.lisp,v 1.13 2006/08/30 14:05:40 alemmens Exp $
+;; $Id: objects.lisp,v 1.14 2006/08/31 15:47:58 alemmens Exp $
(in-package :rucksack)
@@ -784,6 +784,5 @@
(slot-definition-initfunction slot))
when initfunction
;; DO: Handle initargs!
- do (setf (slot-value instance slot-name)
- (funcall initfunction))))))
+ do (setf (slot-value instance slot-name) (funcall initfunction))))))
--- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/30 14:05:40 1.14
+++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/31 15:47:58 1.15
@@ -1,4 +1,4 @@
-;; $Id: rucksack.lisp,v 1.14 2006/08/30 14:05:40 alemmens Exp $
+;; $Id: rucksack.lisp,v 1.15 2006/08/31 15:47:58 alemmens Exp $
(in-package :rucksack)
@@ -555,10 +555,10 @@
(defmethod rucksack-update-slot-indexes ((rucksack standard-rucksack)
(class persistent-class)
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)
+ (let ((direct-slots (class-direct-slots class))
+ (indexed-slot-names (rucksack-indexed-slots-for-class rucksack class)))
+ ;; Remove indexes for slots that don't exist anymore.
+ (loop for slot-name in indexed-slot-names
unless (find slot-name direct-slots :key #'slot-definition-name)
do (rucksack-remove-slot-index rucksack class slot-name :errorp nil))
;; Update indexes for the current set of direct slots.
@@ -568,8 +568,11 @@
(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)
+ (let* ((current-index (rucksack-slot-index rucksack class slot-name
+ :errorp nil
+ :include-superclasses nil))
+ (current-index-spec (and current-index (index-spec current-index)))
+ (current-unique-p (and current-index (index-unique-keys-p current-index))))
(cond ((and (index-spec-equal index-spec current-index-spec)
(eql unique-p current-unique-p))
;; We keep the same index: no change needed.
@@ -919,27 +922,39 @@
do (map-slot class))))))
(map-slot (if (symbolp class) (find-class class) class)))))
+
+(defun rucksack-indexed-slots-for-class (rucksack class)
+ "Returns a list with the names of the indexed direct slots of CLASS."
+ (unless (symbolp class)
+ (setq class (class-name class)))
+ (let ((result '()))
+ (rucksack-map-slot-indexes rucksack
+ (lambda (class-name slot-name slot-index)
+ (declare (ignore slot-index))
+ (when (eql class-name class)
+ (push slot-name result))))
+ result))
+
+
;;
;; Debugging
;;
(defun rucksack-list-slot-indexes (rucksack)
(let ((result '()))
- (with-transaction ()
- (rucksack-map-slot-indexes rucksack
- (lambda (class-name slot-name slot-index)
- (declare (ignore slot-index))
- (push (cons class-name slot-name)
- result))))
+ (rucksack-map-slot-indexes rucksack
+ (lambda (class-name slot-name slot-index)
+ (declare (ignore slot-index))
+ (push (cons class-name slot-name)
+ result)))
result))
(defun rucksack-list-class-indexes (rucksack)
(let ((result '()))
- (with-transaction ()
- (rucksack-map-class-indexes rucksack
- (lambda (class-name index)
- (declare (ignore index))
- (push class-name result))))
+ (rucksack-map-class-indexes rucksack
+ (lambda (class-name index)
+ (declare (ignore index))
+ (push class-name result)))
result))
--- /project/rucksack/cvsroot/rucksack/test-schema-update-1a.lisp 2006/08/31 15:47:59 NONE
+++ /project/rucksack/cvsroot/rucksack/test-schema-update-1a.lisp 2006/08/31 15:47:59 1.1
;; $Id: test-schema-update-1a.lisp,v 1.1 2006/08/31 15:47:58 alemmens Exp $
(in-package :rucksack-test-schema-update)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Schema updates and UPDATE-INSTANCE-FOR-REDEFINED-CLASS, part 1 of 3
;;;
;;; After compiling and loading this file, compile and load
;;; test-schema-update-1b.lisp.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defparameter *names* '(john dick mary jane peter ronald))
;;
;; Initial class definition of PERSON
;;
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *dir* #P"/tmp/rucksack/schema-update/")
(with-rucksack (*rucksack* *dir* :if-exists :supersede)
(with-transaction ()
(defclass person ()
((name :initarg :name
:initform (elt *names* (random (length *names*)))
:reader name)
(age :initarg :age
:initform (random 100)
:reader age))
(:metaclass persistent-class)
(:index t)))))
(defmethod print-object ((person person) stream)
(print-unreadable-object (person stream :type t)
(format stream "#~D ~A with age ~D"
(object-id person)
(name person)
(age person))))
;; Create some persons.
(with-rucksack (*rucksack* *dir*)
(with-transaction ()
(loop repeat 10
do (make-instance 'person))))
;; Show them.
(with-rucksack (*rucksack* *dir*)
(with-transaction ()
(rucksack-map-class *rucksack* 'person #'print)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Sample output
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#|
#<PERSON #12 JOHN with age 77>
#<PERSON #22 DICK with age 39>
#<PERSON #24 JOHN with age 95>
#<PERSON #26 PETER with age 41>
#<PERSON #28 JANE with age 17>
#<PERSON #30 JOHN with age 75>
#<PERSON #32 PETER with age 88>
#<PERSON #34 DICK with age 11>
#<PERSON #36 MARY with age 49>
#<PERSON #38 RONALD with age 72>
|#
--- /project/rucksack/cvsroot/rucksack/test-schema-update-1b.lisp 2006/08/31 15:47:59 NONE
+++ /project/rucksack/cvsroot/rucksack/test-schema-update-1b.lisp 2006/08/31 15:47:59 1.1
;; $Id: test-schema-update-1b.lisp,v 1.1 2006/08/31 15:47:58 alemmens Exp $
(in-package :rucksack-test-schema-update)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Schema updates and UPDATE-INSTANCE-FOR-REDEFINED-CLASS, part 2 of 3
;;;
;;; Compile and load this file after compiling and loading
;;; test-schema-update-1a.lisp. Study the output, and then compile
;;; and load test-schema-update-1c.lisp.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Redefine the PERSON class
;;
(eval-when (:compile-toplevel :load-toplevel :execute)
(with-rucksack (*rucksack* *dir*)
(with-transaction ()
(defclass person ()
((name :initarg :name
:initform (elt *names* (random (length *names*)))
:reader name)
(year-of-birth :initform (random-year)
:accessor year-of-birth))
(:metaclass persistent-class)
(:index t)))))
(defconstant +this-year+ 2006)
(defun random-year ()
(+ 1900 (random 100)))
(defmethod update-persistent-instance-for-redefined-class
((person person) added-slots discarded-slots plist
&key &allow-other-keys)
;; Make sure that existing PERSONS get the YEAR-OF-BIRTH value
;; corresponding to their (obsolete) AGE slot.
(let ((age (getf plist 'age)))
(setf (year-of-birth person) (- +this-year+ age))
(format *trace-output*
"~&Setting year of birth for ~D to ~D."
age
(year-of-birth person))))
(defmethod age ((person person))
;; Make sure that the AGE method still works.
(- +this-year+ (year-of-birth person)))
;; Create some persons with the new class definition.
(with-rucksack (*rucksack* *dir*)
(with-transaction ()
(loop repeat 10
do (make-instance 'person))))
;; Show some PERSON instances and some old PERSON instances.
;; (We don't show all PERSON instances, because showing them may
;; update them and we want to keep a few old instances for the next
;; part of the test).
(with-rucksack (*rucksack* *dir*)
(with-transaction ()
(let ((cache (rucksack-cache *rucksack*))
(count 0))
(rucksack-map-class *rucksack* 'person
(lambda (id)
(when (evenp count)
(print (cache-get-object id cache)))
(incf count))
:id-only t))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Sample output
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#|
;; Some old PERSON instances (updated after being loaded).
Setting year of birth for 77 to 1929.
#<PERSON #12 JOHN with age 77>
Setting year of birth for 39 to 1967.
#<PERSON #24 JOHN with age 95>
Setting year of birth for 41 to 1965.
#<PERSON #28 JANE with age 17>
Setting year of birth for 75 to 1931.
#<PERSON #32 PETER with age 88>
Setting year of birth for 11 to 1995.
#<PERSON #36 MARY with age 49>
Setting year of birth for 72 to 1934.
;; Some new PERSON instances.
#<PERSON #38 RONALD with age 72>
#<PERSON #42 JOHN with age 50>
#<PERSON #46 DICK with age 57>
#<PERSON #50 DICK with age 22>
#<PERSON #54 MARY with age 82>
#<PERSON #58 JANE with age 84>
|#
--- /project/rucksack/cvsroot/rucksack/test-schema-update-1c.lisp 2006/08/31 15:47:59 NONE
+++ /project/rucksack/cvsroot/rucksack/test-schema-update-1c.lisp 2006/08/31 15:47:59 1.1
;; $Id: test-schema-update-1c.lisp,v 1.1 2006/08/31 15:47:58 alemmens Exp $
(in-package :rucksack-test-schema-update)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Schema updates and UPDATE-INSTANCE-FOR-REDEFINED-CLASS, part 3 of 3
;;;
;;; Compile and load this file after compiling and loading
;;; test-schema-update-1c.lisp
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Redefine the PERSON class once more.
;;
(eval-when (:compile-toplevel :load-toplevel :execute)
(with-rucksack (*rucksack* *dir*)
(with-transaction ()
(defclass person ()
((name :initarg :name
:initform (elt *names* (random (length *names*)))
:reader name)
(date-of-birth :accessor date-of-birth
:initform (random-date)))
(:metaclass persistent-class)
(:index t)))))
(defun random-date ()
(make-date (random-year)
(+ 1 (random 12))
(+ 1 (random 28))))
(defun make-date (year &optional (month 1) (day 1))
(encode-universal-time 0 0 0 day month year))
(defun date-string (universal-time)
(multiple-value-bind (sec min hr day month year)
(decode-universal-time universal-time)
(declare (ignore sec min hr))
(format nil "~D-~2,'0D-~2,'0D"
year month day)))
(defmethod update-persistent-instance-for-redefined-class
((person person) added-slots discarded-slots plist
&key &allow-other-keys)
;; Now we need to deal with version 0 persons (with an obsolete
;; AGE slot) and with version 1 persons (with an obsolete
;; YEAR-OF-BIRTH slot).
(cond ((member 'age discarded-slots)
;; Version 0
(let* ((age (getf plist 'age))
(year (- +this-year+ age)))
(setf (date-of-birth person) (make-date year 1 1))
(format *trace-output*
"~&Setting date of birth from age ~D to ~A."
age
(date-string (date-of-birth person)))))
((member 'year-of-birth discarded-slots)
;; Version 1
(let ((year (getf plist 'year-of-birth)))
(setf (date-of-birth person) (make-date year 1 1))
(format *trace-output*
"~&Setting date of birth from year ~D to ~A."
year
(date-string (date-of-birth person)))))))
(defmethod year-of-birth ((person person))
;; Make sure that the YEAR-OF-BIRTH method still works.
(nth-value 5 (decode-universal-time (date-of-birth person))))
;; Create some persons with the second version of the class definition.
(with-rucksack (*rucksack* *dir*)
(with-transaction ()
(loop repeat 10
do (make-instance 'person))))
;; Show all persons (for three versions of the class definition).
(with-rucksack (*rucksack* *dir*)
(with-transaction ()
(rucksack-map-class *rucksack* 'person #'print)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Sample output
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Note that we see three different kinds of output, corresponding to the
;;; three class versions.
;;;
;;; Output like:
;;;
;;; Setting date of birth from age 6 to 2000-01-01.
;;; #<PERSON #26 MARY with age 6>
;;;
;;; is for version 0 instances that are updated to version 2.
;;;
;;; Output like:
;;;
;;; Setting date of birth from year 2001 to 2001-01-01.
;;; #<PERSON #12 PETER with age 5>
;;;
;;; is for version 1 PERSON instances that are updated to version 2.
;;;
;;; And output like:
;;;
;;; #<PERSON #60 JANE with age 26>
;;;
;;; is for version 2 instances (that don't need to be updated).
;;; Note also that you'll get this kind of output only once. If you load
;;; the file again, all old version instances have been updated already
;;; so you won't see any "Setting date of birth..." messages anymore.
#|
Setting date of birth from year 2001 to 2001-01-01.
#<PERSON #12 PETER with age 5>
Setting date of birth from age 46 to 1960-01-01.
#<PERSON #22 MARY with age 46>
Setting date of birth from year 1955 to 1955-01-01.
#<PERSON #24 PETER with age 51>
Setting date of birth from age 6 to 2000-01-01.
#<PERSON #26 MARY with age 6>
Setting date of birth from year 1920 to 1920-01-01.
#<PERSON #28 PETER with age 86>
Setting date of birth from age 33 to 1973-01-01.
#<PERSON #30 MARY with age 33>
Setting date of birth from year 1917 to 1917-01-01.
#<PERSON #32 JANE with age 89>
Setting date of birth from age 15 to 1991-01-01.
#<PERSON #34 JOHN with age 15>
Setting date of birth from year 1922 to 1922-01-01.
#<PERSON #36 DICK with age 84>
Setting date of birth from age 26 to 1980-01-01.
#<PERSON #38 DICK with age 26>
[32 lines skipped]
More information about the rucksack-cvs
mailing list