[rucksack-cvs] CVS rucksack
alemmens
alemmens at common-lisp.net
Fri Aug 11 12:44:21 UTC 2006
Update of /project/rucksack/cvsroot/rucksack
In directory clnet:/tmp/cvs-serv3790
Modified Files:
glossary.txt index.lisp mop.lisp package.lisp rucksack.lisp
serialize.lisp test.lisp
Log Message:
Save and load the index tables when closing/opening a rucksack.
Add/remove indexes to/from the roots when necessary.
Implement the :UNIQUE slot option.
Improve predefined index specs.
--- /project/rucksack/cvsroot/rucksack/glossary.txt 2006/05/16 22:01:27 1.2
+++ /project/rucksack/cvsroot/rucksack/glossary.txt 2006/08/11 12:44:21 1.3
@@ -1,4 +1,4 @@
-;; $Header: /project/rucksack/cvsroot/rucksack/glossary.txt,v 1.2 2006/05/16 22:01:27 alemmens Exp $
+;; $Header: /project/rucksack/cvsroot/rucksack/glossary.txt,v 1.3 2006/08/11 12:44:21 alemmens Exp $
* block
@@ -23,6 +23,22 @@
The object version that's compatible with a transaction T is the most
recent version that's not younger than T.
+* index spec
+
+A non-keyword symbol (the name of an indexing class) or a list
+starting with a symbol (the name of an indexing class) followed by a
+plist of keywords and values (initargs for the indexing class).
+
+Examples: BTREE, (BTREE :KEY< < :VALUE= P-EQL).
+
+
+* index spec designator
+
+Either an index spec or the name (i.e. a keyword) of an index spec
+that has been defined with DEFINE-INDEX-SPEC.
+
+Example: :STRING-INDEX.
+
* object version list
--- /project/rucksack/cvsroot/rucksack/index.lisp 2006/08/10 12:36:16 1.4
+++ /project/rucksack/cvsroot/rucksack/index.lisp 2006/08/11 12:44:21 1.5
@@ -1,4 +1,4 @@
-;; $Id: index.lisp,v 1.4 2006/08/10 12:36:16 alemmens Exp $
+;; $Id: index.lisp,v 1.5 2006/08/11 12:44:21 alemmens Exp $
(in-package :rucksack)
@@ -26,17 +26,20 @@
ORDER is either :ASCENDING (default) or :DESCENDING."))
(defgeneric index-insert (index key value &key if-exists)
- (:documentation "Insert a key/value pair into an index. IF-EXISTS
-can be either :OVERWRITE (default) or :ERROR."))
+ (:documentation
+ "Insert a key/value pair into an index. IF-EXISTS can be either
+:OVERWRITE (default) or :ERROR."))
(defgeneric index-delete (index key value &key if-does-not-exist)
- (:documentation "Remove a key/value pair from an index.
-IF-DOES-NOT-EXIST can be either :IGNORE (default) or :ERROR."))
+ (:documentation
+ "Remove a key/value pair from an index. IF-DOES-NOT-EXIST can be
+either :IGNORE (default) or :ERROR."))
-;; make-index (index-spec) [Function]
+;; make-index (index-spec unique-keys-p) [Function]
;; index-spec-equal (index-spec-1 index-spec-2) [Function]
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Indexing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -64,10 +67,15 @@
;; and followed by a plist of keywords and values.
;; Examples: BTREE, (BTREE :KEY< < :VALUE= P-EQL)
-(defun make-index (index-spec)
+
+(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)
- (apply #'make-instance (first index-spec) (rest 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."
@@ -83,27 +91,60 @@
(plist-subset-p (rest index-spec-2) (rest index-spec-1))))))
-;;
-;; Predefined index specs for slots of persistent classes.
-;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Defining index specs
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defparameter *number-index*
- '(btree :key< < :value= p-eql))
+(eval-when (:compile-toplevel :load-toplevel :execute)
-(defparameter *string-index*
- '(btree :key< string< :value p-eql))
+ ;;
+ ;; Defining index specs
+ ;;
+
+ (defparameter *index-specs*
+ (make-hash-table))
+
+ (defun define-index-spec (name spec &key (if-exists :overwrite))
+ "NAME must be a keyword. SPEC must be an index spec. IF-EXISTS must be
+either :OVERWRITE (default) or :ERROR."
+ (assert (member if-exists '(:overwrite :error)))
+ (when (eql if-exists :error)
+ (let ((existing-spec (gethash name *index-specs*)))
+ (when (and existing-spec
+ (not (index-spec-equal existing-spec spec)))
+ (error "Index spec ~S is already defined. Its definition is: ~S."
+ name existing-spec))))
+ (setf (gethash name *index-specs*) spec))
+
+ (defun find-index-spec (name &key (errorp t))
+ (or (gethash name *index-specs*)
+ (and errorp
+ (error "Can't find index spec called ~S." name)))))
-(defparameter *symbol-index*
- '(btree :key< string< :value p-eql))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Predefined index specs
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defparameter *case-insensitive-string-index*
- '(btree :key< string-lessp :value p-eql))
-
-(defparameter *trimmed-string-index*
- ;; Like *STRING-INDEX*, but with whitespace trimmed left and right.
- '(btree :key< string<
- :key-key trim-whitespace
- :value p-eql))
-
(defun trim-whitespace (string)
- (string-trim '(#\space #\tab #\return #\newline) string))
+ (string-trim '(#\space #\tab #\return #\newline) string))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+ (define-index-spec :number-index
+ '(btree :key< < :value= p-eql))
+
+ (define-index-spec :string-index
+ '(btree :key< string< :value p-eql))
+
+ (define-index-spec :symbol-index
+ '(btree :key< string< :value p-eql))
+
+ (define-index-spec :case-insensitive-string-index
+ '(btree :key< string-lessp :value p-eql))
+
+ (define-index-spec :trimmed-string-index
+ ;; Like :STRING-INDEX, but with whitespace trimmed left
+ ;; and right.
+ '(btree :key< string<
+ :key-key trim-whitespace
+ :value p-eql)))
--- /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/10 12:36:16 1.4
+++ /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/11 12:44:21 1.5
@@ -1,4 +1,4 @@
-;; $Id: mop.lisp,v 1.4 2006/08/10 12:36:16 alemmens Exp $
+;; $Id: mop.lisp,v 1.5 2006/08/11 12:44:21 alemmens Exp $
(in-package :rucksack)
@@ -15,7 +15,7 @@
:accessor class-persistent-slots)
(index :initarg :index :initform nil :accessor class-index
:documentation "Can be either NIL (for no class index) or T
-(for the standard class index). Default value is NIL.")))
+(for the standard class index). Default value is T.")))
(defclass persistent-slot-mixin ()
((persistence :initarg :persistence
@@ -26,8 +26,8 @@
(index :initarg :index
:initform nil
:reader slot-index
- :documentation "An index spec for indexed slots, NIL for
-non-indexed slots. Default value is NIL.")
+ :documentation "An index spec designator for indexed slots,
+NIL for non-indexed slots. Default value is NIL.")
(unique :initarg :unique
:initform nil
:reader slot-unique
@@ -105,25 +105,31 @@
;; slot-value-using-class.
#+lispworks :optimize-slot-access #+lispworks nil
args)))
- (ensure-class-schema class)
+ (ensure-class-schema class '())
result))
(defmethod reinitialize-instance :around ((class persistent-class)
&rest args
&key direct-superclasses
&allow-other-keys)
- ;; This is a copy of the code for initialize-instance at the moment.
- (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)
- result))
+ (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)))
(defun maybe-add-persistent-object-class (class direct-superclasses)
@@ -140,7 +146,7 @@
direct-superclasses
(cons root-class direct-superclasses))))
-(defun ensure-class-schema (class)
+(defun ensure-class-schema (class old-slot-indexes)
;; Update class and slot indexes.
(when (some #'slot-persistence (class-direct-slots class))
;; NOTE: We get the current-rucksack only if there are some
@@ -151,7 +157,7 @@
(let ((rucksack (current-rucksack)))
(when rucksack
(rucksack-update-class-index rucksack class)
- (rucksack-update-slot-indexes rucksack class))))
+ (rucksack-update-slot-indexes rucksack class old-slot-indexes))))
;; DO: Update schema in schema table, when necessary.
'DO-THIS)
--- /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/10 12:36:17 1.6
+++ /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/11 12:44:21 1.7
@@ -1,4 +1,4 @@
-;; $Id: package.lisp,v 1.6 2006/08/10 12:36:17 alemmens Exp $
+;; $Id: package.lisp,v 1.7 2006/08/11 12:44:21 alemmens Exp $
#-(or allegro lispworks sbcl openmcl)
(error "Unsupported implementation: ~A" (lisp-implementation-type))
@@ -78,8 +78,7 @@
;; Indexes
#:map-index #:index-insert #:index-delete #:make-index
- #:*string-index* #:*number-index* #:*symbol-index*
- #:*trimmed-string-index* #:*case-insensitive-string-index*
+ #:define-index-spec #:find-index-spec
;; Btrees
#:btree
--- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/10 12:36:17 1.9
+++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/11 12:44:21 1.10
@@ -1,4 +1,4 @@
-;; $Id: rucksack.lisp,v 1.9 2006/08/10 12:36:17 alemmens Exp $
+;; $Id: rucksack.lisp,v 1.10 2006/08/11 12:44:21 alemmens Exp $
(in-package :rucksack)
@@ -62,17 +62,19 @@
(defgeneric rucksack-update-class-index (rucksack class)
(:documentation
"Compares the current class index for CLASS to the class index
-that's specified in the :INDEX class options of CLASS. An obsolete
+that's specified in the :INDEX class option of CLASS. An obsolete
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)
+(defgeneric rucksack-update-slot-indexes (rucksack class old-slot-indexes)
(: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."))
+added.
+ OLD-SLOT-INDEXES is a list with the name, index and unique-p info
+of each slot."))
(defgeneric rucksack-add-class-index (rucksack class-designator &key errorp))
@@ -95,15 +97,15 @@
(defgeneric rucksack-add-slot-index (rucksack class-designator slot index-spec
- &key errorp)
+ unique-p &key errorp)
(:documentation
"Creates a new slot index for the slot designated by
CLASS-DESIGNATOR and SLOT. The type of index is specified by
INDEX-SPEC. Returns the new index. Signals an error if ERRORP is T
-and there is already an index for the designated slot."))
+and there already is an index for the designated slot."))
(defgeneric rucksack-remove-slot-index (rucksack class-designator slot
- &key errorp))
+ &key errorp))
@@ -153,11 +155,13 @@
&key equal min max include-min include-max order
id-only include-subclasses)
(:documentation
- " FUNCTION is a unary function that gets called for all instances of
+ " FUNCTION is a unary function that gets called for all instances of
the specified class that have a slot value matching the EQUAL, MIN,
-MAX INCLUDE-MIN and INCLUDE-MAX arguments. ORDER can be either
-:ASCENDING (default) or :DESCENDING; currently, the specified order
-will be respected for instances of one class but not across subclasses.
+MAX INCLUDE-MIN and INCLUDE-MAX arguments (see the documentation of
+MAP-INDEX for a description of these arguments).
+ ORDER can be either :ASCENDING (default) or :DESCENDING; currently,
+the specified order will be respected for instances of one class but
+not across subclasses.
If ID-ONLY is T (default is NIL), the function will be called with
object ids instead of 'real' objects. This can be handy if you want to
do more filtering before actually loading objects from disk.
@@ -273,13 +277,23 @@
(defun load-roots (rucksack)
;; Read roots (i.e. object ids) from the roots file (if there is one).
+ ;; Also load the class and slot index tables.
(let ((roots-file (rucksack-roots-pathname rucksack)))
(when (probe-file roots-file)
- (setf (slot-value rucksack 'roots)
- (load-objects roots-file)))))
+ (destructuring-bind (root-list class-index slot-index)
+ (load-objects roots-file)
+ (with-slots (roots class-index-table slot-index-tables)
+ rucksack
+ (setf roots root-list
+ class-index-table (maybe-dereference-proxy class-index)
+ slot-index-tables (maybe-dereference-proxy slot-index))))))
+ rucksack)
+
(defun save-roots (rucksack)
- (save-objects (slot-value rucksack 'roots)
+ (save-objects (list (slot-value rucksack 'roots)
+ (class-index-table rucksack)
+ (slot-index-tables rucksack))
(rucksack-roots-pathname rucksack))
(setf (roots-changed-p rucksack) nil))
@@ -443,37 +457,61 @@
;; We don't need to change anything
:no-change))))
+
(defmethod rucksack-update-slot-indexes ((rucksack standard-rucksack)
- (class persistent-class))
+ (class persistent-class)
+ old-slot-indexes)
(dolist (slot (class-direct-slots class))
- (let ((index-needed (and (slot-persistence slot) (slot-index slot)))
- (current-index (rucksack-slot-index rucksack class slot)))
- (cond ((index-spec-equal index-needed current-index)
- ;; We keep the same index: no change needed.
- :no-change)
- ((and current-index (null index-needed))
- ;; The index is not wanted anymore: remove it.
- (rucksack-remove-slot-index rucksack class slot :errorp t))
- ((and (null current-index) index-needed)
- ;; We didn't have an index but we need one now: add one.
- (rucksack-add-slot-index rucksack class slot index-needed
- :errorp t))
- ((and current-index index-needed)
- ;; 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 ((new-index (rucksack-add-slot-index rucksack class slot
- index-needed
- :errorp nil)))
- ;; Re-index all objects for the new 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.
- ))))))
+ (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
+ :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)))))
+
;;
;; Some simple dispatchers.
;;
@@ -516,16 +554,18 @@
(simple-rucksack-error "Class index for ~S already exists in ~A."
class
rucksack))
- (setf (gethash class (class-index-table rucksack))
- (rucksack-make-class-index rucksack class)))
+ (let ((index (rucksack-make-class-index rucksack class)))
+ (setf (gethash class (class-index-table rucksack)) index)
+ (add-rucksack-root index rucksack)
+ index))
(defmethod rucksack-make-class-index
((rucksack standard-rucksack) class
&key
- (index-spec '(btree :key< < :key= = :value= eql :unique-keys-p t)))
+ (index-spec '(btree :key< < :value= p-eql)))
;; A class index maps object ids to objects.
(declare (ignore class))
- (make-index index-spec))
+ (make-index index-spec t))
(defmethod rucksack-remove-class-index ((rucksack standard-rucksack) class
&key (errorp nil))
@@ -536,7 +576,9 @@
(simple-rucksack-error "Class index for ~S doesn't exist in ~A."
class
rucksack))
- (remhash class (class-index-table rucksack)))
+ (let ((index (gethash class (class-index-table rucksack))))
+ (remhash class (class-index-table rucksack))
+ (delete-rucksack-root index rucksack)))
(defmethod rucksack-map-class-indexes (rucksack function)
@@ -589,7 +631,7 @@
;;
(defmethod rucksack-add-slot-index ((rucksack standard-rucksack)
- class slot index-spec
+ class slot index-spec unique-p
&key (errorp nil))
(unless (symbolp class)
(setq class (class-name class)))
@@ -602,14 +644,18 @@
(let ((table (make-hash-table)))
(setf (gethash class slot-index-tables) table)
table)))
- (new-slot-index (make-index index-spec)))
+ (new-slot-index (make-index index-spec unique-p))
+ (old-slot-index (gethash slot slot-index-table)))
;; Add a new slot index table if necessary.
- (when (and errorp (gethash slot slot-index-table))
+ (when (and errorp old-slot-index)
(simple-rucksack-error "Slot index for slot ~S of class ~S
already exists in ~A."
slot
class
rucksack))
+ (add-rucksack-root new-slot-index rucksack)
+ (when old-slot-index
+ (delete-rucksack-root old-slot-index rucksack))
(setf (gethash slot slot-index-table) new-slot-index)))
(defmethod rucksack-remove-slot-index (rucksack class slot &key (errorp nil))
@@ -628,7 +674,9 @@
(if errorp
(let ((index (gethash slot slot-index-table)))
(if index
- (remhash slot slot-index-table)
+ (progn
+ (remhash slot slot-index-table)
+ (delete-rucksack-root index rucksack))
(oops)))
(remhash slot slot-index-table))
(and errorp (oops))))))
@@ -684,14 +732,15 @@
(and slot-index-table
(gethash slot slot-index-table)))))
(or (find-index class)
- (loop for superclass in (class-precedence-list (find-class class))
+ (loop for superclass in (class-precedence-list
+ (find-class class))
thereis (find-index (class-name superclass)))
(and errorp
- (simple-rucksack-error "Can't find slot index for slot
-~S of class ~S in ~A."
- slot
- class
- rucksack))))))
+ (simple-rucksack-error
+ "Can't find slot index for slot ~S of class ~S in ~A."
+ slot
+ class
+ rucksack))))))
(defmethod rucksack-map-slot ((rucksack standard-rucksack) class slot function
--- /project/rucksack/cvsroot/rucksack/serialize.lisp 2006/08/04 10:26:23 1.5
+++ /project/rucksack/cvsroot/rucksack/serialize.lisp 2006/08/11 12:44:21 1.6
@@ -1,4 +1,4 @@
-;; $Id: serialize.lisp,v 1.5 2006/08/04 10:26:23 alemmens Exp $
+;; $Id: serialize.lisp,v 1.6 2006/08/11 12:44:21 alemmens Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Serialize
@@ -1203,7 +1203,8 @@
;; uses non-serializable objects to represent host or device or directory
;; or name or type or version, this will break.
(serialize-marker +pathname+ stream)
- (serialize (pathname-host pathname) stream)
+ #-sbcl(serialize (pathname-host pathname) stream)
+ #+sbcl(serialize (host-namestring pathname) stream)
(serialize (pathname-device pathname) stream)
(serialize (pathname-directory pathname) stream)
(serialize (pathname-name pathname) stream)
--- /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/10 12:36:17 1.9
+++ /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/11 12:44:21 1.10
@@ -1,4 +1,4 @@
-;; $Id: test.lisp,v 1.9 2006/08/10 12:36:17 alemmens Exp $
+;; $Id: test.lisp,v 1.10 2006/08/11 12:44:21 alemmens Exp $
(in-package :test-rucksack)
@@ -432,30 +432,3 @@
(list (p-car inner) (p-cdr inner))))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Indexing, class redefinitions
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-#|
-(with-rucksack (rucksack *test-suite* :if-exists :supersede)
- ;; 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.)
-
- ;; Define a class person
- (defclass person ()
- ((id :initform (gensym "PERSON-")
- :reader person-id
- :
-(name :initform (elt *names* (random (length *names*)))
- :accessor name)
- (age :initform (random 100) :accessor age))
- (:metaclass persistent-class))
-
- ;; Fill the rucksack with some persons.
- (with-transaction ()
- (loop repeat 1000
- do (make-instance 'person))
-|#
More information about the rucksack-cvs
mailing list