[rucksack-cvs] CVS rucksack
alemmens
alemmens at common-lisp.net
Sat Aug 26 12:55:35 UTC 2006
Update of /project/rucksack/cvsroot/rucksack
In directory clnet:/tmp/cvs-serv9635
Modified Files:
example-1.lisp index.lisp mop.lisp objects.lisp p-btrees.lisp
rucksack.lisp
Log Message:
Make sure that indexing works correctly with subclasses.
Fix some more indexing bugs.
--- /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/11 12:52:53 1.1
+++ /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/26 12:55:34 1.2
@@ -1,40 +1,52 @@
-;; $Id: example-1.lisp,v 1.1 2006/08/11 12:52:53 alemmens Exp $
+;; $Id: example-1.lisp,v 1.2 2006/08/26 12:55:34 alemmens Exp $
(in-package :test-rucksack)
-;; NOTE: This example doesn't run at the moment, because indexing doesn't
-;; work correctly yet.
+;; 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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defparameter *example-1* #p"/tmp/rucksack/example-1/")
+(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"))
-(with-rucksack (rucksack *example-1* :if-exists :supersede)
- (with-transaction ()
+(defun random-elt (list)
+ (elt list (random (length list))))
- ;; 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.)
+(eval-when (:compile-toplevel)
+ (with-rucksack (*rucksack* *example-1* :if-exists :supersede)
+ (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.)
- ;; Define a class hacker
- (defclass hacker ()
- ((id :initform (gensym "HACKER-")
- :reader hacker-id
- :index :symbol-index
- :unique t)
- (name :initform (elt *hackers* (random (length *hackers*)))
- :accessor name
- :index :case-insensitive-string-index)
- (age :initform (random 100) :accessor age))
- (:metaclass persistent-class))))
-
+ (defclass hacker ()
+ ((id :initform (gensym "HACKER-")
+ :reader hacker-id
+ :index :symbol-index
+ :unique t)
+ (name :initform (random-elt *hackers*)
+ :accessor name
+ :index :case-insensitive-string-index)
+ (age :initform (random 100) :accessor age
+ :index :number-index))
+ (:metaclass persistent-class)
+ (:index t))
+
+ (defclass lisp-hacker (hacker)
+ ()
+ (:metaclass persistent-class)
+ (:index t)))))
+
(defmethod print-object ((hacker hacker) stream)
(print-unreadable-object (hacker stream :type t)
@@ -44,21 +56,35 @@
(age hacker))))
(defun example-1 ()
- (with-rucksack (rucksack *example-1*)
+ (with-rucksack (*rucksack* *example-1*)
;; Fill the rucksack with some hackers.
(with-transaction ()
- (loop repeat 1000
+ (loop repeat 20
do (make-instance 'hacker))
- #+nil
- (rucksack-map-slot rucksack 'hacker 'name
- (lambda (hacker)
- (print-object hacker *standard-output*)
- (terpri))))))
+ (loop repeat 10
+ do (make-instance 'lisp-hacker))
+ (rucksack-map-class *rucksack* 'hacker #'print))))
(defun show-hackers ()
- (with-rucksack (rucksack *example-1*)
- (rucksack-map-class rucksack 'hacker
- (lambda (hacker)
- (print-object hacker *standard-output*)
- (terpri)))))
-
+ (with-rucksack (*rucksack* *example-1*)
+ (with-transaction ()
+ (print "Hackers indexed by object id.")
+ (rucksack-map-class *rucksack* 'hacker #'print)
+ (print "Hackers indexed by name.")
+ (rucksack-map-slot *rucksack* 'hacker 'name #'print)
+ (print "Hackers indexed by hacker-id.")
+ (rucksack-map-slot *rucksack* 'hacker 'id #'print)
+ (print "Lisp hackers.")
+ (rucksack-map-class *rucksack* 'lisp-hacker #'print)
+ (print "Non-lisp hackers.")
+ (rucksack-map-class *rucksack* 'hacker #'print
+ :include-subclasses nil)
+ (print "Hacker object ids.")
+ (rucksack-map-class *rucksack* 'hacker #'print
+ :id-only t))))
+
+(defun show-indexes ()
+ (with-rucksack (r *example-1*)
+ (print (rs::rucksack-list-class-indexes r))
+ (print (rs::rucksack-list-slot-indexes r))
+ :ok))
--- /project/rucksack/cvsroot/rucksack/index.lisp 2006/08/11 12:44:21 1.5
+++ /project/rucksack/cvsroot/rucksack/index.lisp 2006/08/26 12:55:34 1.6
@@ -1,4 +1,4 @@
-;; $Id: index.lisp,v 1.5 2006/08/11 12:44:21 alemmens Exp $
+;; $Id: index.lisp,v 1.6 2006/08/26 12:55:34 alemmens Exp $
(in-package :rucksack)
@@ -15,7 +15,7 @@
If EQUAL is specified, the other arguments are ignored; the function
will be called once (if there is a key with the same value as EQUAL)
-or zero time (if there is no such key).
+or not at all (if there is no such key).
MIN, MAX, INCLUDE-MIN and INCLUDE-MAX specify the interval. The
interval is left-open if MIN is nil, right-open if MAX is nil. The
@@ -46,10 +46,15 @@
(defmethod map-index ((index btree) function
&rest args
- &key equal min max include-min include-max
+ &key min max include-min include-max
+ (equal nil equal-supplied)
(order :ascending))
- (declare (ignorable equal min max include-min include-max))
- (apply #'map-btree index function :order order args))
+ (declare (ignorable min max include-min include-max))
+ (if equal-supplied
+ (let ((value (btree-search index equal :errorp nil :default-value index)))
+ (unless (p-eql value index)
+ (funcall function equal value)))
+ (apply #'map-btree index function :order order args)))
(defmethod index-insert ((index btree) key value &key (if-exists :overwrite))
--- /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/11 12:44:21 1.5
+++ /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/26 12:55:34 1.6
@@ -1,4 +1,4 @@
-;; $Id: mop.lisp,v 1.5 2006/08/11 12:44:21 alemmens Exp $
+;; $Id: mop.lisp,v 1.6 2006/08/26 12:55:34 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 T.")))
+(for the standard class index). Default value is NIL.")))
(defclass persistent-slot-mixin ()
((persistence :initarg :persistence
@@ -148,7 +148,8 @@
(defun ensure-class-schema (class old-slot-indexes)
;; Update class and slot indexes.
- (when (some #'slot-persistence (class-direct-slots class))
+ (when (or (class-index class)
+ (some #'slot-persistence (class-direct-slots class)))
;; NOTE: We get the current-rucksack only if there are some
;; persistent slots, because this will also get called during
;; compilation of Rucksack (when the class definition of
--- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/24 15:21:25 1.9
+++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/26 12:55:34 1.10
@@ -1,4 +1,4 @@
-;; $Id: objects.lisp,v 1.9 2006/08/24 15:21:25 alemmens Exp $
+;; $Id: objects.lisp,v 1.10 2006/08/26 12:55:34 alemmens Exp $
(in-package :rucksack)
@@ -404,7 +404,12 @@
(defmethod shared-initialize :before ((object persistent-object) slots
- &key rucksack &allow-other-keys)
+ &key rucksack
+ ;; The DONT-INDEX argument is used
+ ;; when creating the indexes themselves
+ ;; (to prevent infinite recursion).
+ (dont-index nil)
+ &allow-other-keys)
;; This happens when persistent-objects are created in memory, not when
;; they're loaded from the cache (loading uses ALLOCATE-INSTANCE instead).
(let ((rucksack (or rucksack (rucksack object))))
@@ -414,7 +419,24 @@
;; DO: Explain why we don't set the transaction-id slot here.
(unless (slot-boundp object 'rucksack)
(setf (slot-value object 'rucksack) rucksack))
- (rucksack-maybe-index-new-object rucksack (class-of object) object)))
+ (unless dont-index
+ (rucksack-maybe-index-new-object rucksack (class-of object) object))))
+
+(defmethod shared-initialize :after ((object persistent-object) slots
+ &key rucksack
+ (dont-index nil)
+ &allow-other-keys)
+ ;; Update slot indexes for persistent slots that are bound now.
+ (unless dont-index
+ (let ((class (class-of object)))
+ (dolist (slot (class-slots class))
+ (let ((slot-name (slot-definition-name slot)))
+ (when (and (slot-boundp object slot-name)
+ (slot-persistence slot))
+ (rucksack-maybe-index-changed-slot rucksack
+ class object slot
+ nil (slot-value object slot-name)
+ nil t)))))))
(defmethod print-object ((object persistent-object) stream)
--- /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/08/10 12:36:16 1.9
+++ /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/08/26 12:55:34 1.10
@@ -1,4 +1,4 @@
-;; $Id: p-btrees.lisp,v 1.9 2006/08/10 12:36:16 alemmens Exp $
+;; $Id: p-btrees.lisp,v 1.10 2006/08/26 12:55:34 alemmens Exp $
(in-package :rucksack)
@@ -751,7 +751,8 @@
:btree btree
:key key
:value value)))))
- (let ((binding (node-search-binding btree (btree-root btree) key)))
+ (let ((binding (and (slot-boundp btree 'root)
+ (node-search-binding btree (btree-root btree) key))))
(cond ((not binding)
;; The binding doesn't exist: forget it.
(forget-it))
--- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/24 15:21:25 1.11
+++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/26 12:55:34 1.12
@@ -1,4 +1,4 @@
-;; $Id: rucksack.lisp,v 1.11 2006/08/24 15:21:25 alemmens Exp $
+;; $Id: rucksack.lisp,v 1.12 2006/08/26 12:55:34 alemmens Exp $
(in-package :rucksack)
@@ -109,7 +109,8 @@
-(defgeneric rucksack-slot-index (rucksack class-designator slot &key errorp)
+(defgeneric rucksack-slot-index (rucksack class-designator slot
+ &key errorp include-superclasses)
(:documentation
"Returns the slot index for the slot specified by CLASS-DESIGNATOR
and SLOT."))
@@ -314,8 +315,10 @@
:rucksack rucksack
:key< 'string<
:value= 'p-eql
- :unique-keys-p t)))
- (setf (slot-value rucksack 'class-index-table) (object-id btree))))
+ :unique-keys-p t
+ :dont-index t)))
+ (setf (slot-value rucksack 'class-index-table) (object-id btree)
+ (roots-changed-p rucksack) t)))
(cache-get-object (slot-value rucksack 'class-index-table)
(rucksack-cache rucksack))))
(if (current-transaction)
@@ -332,8 +335,10 @@
:rucksack rucksack
:key< 'string<
:value= 'p-eql
- :unique-keys-p t)))
- (setf (slot-value rucksack 'slot-index-tables) (object-id btree))))
+ :unique-keys-p t
+ :dont-index t)))
+ (setf (slot-value rucksack 'slot-index-tables) (object-id btree)
+ (roots-changed-p rucksack) t)))
;;
(cache-get-object (slot-value rucksack 'slot-index-tables)
(rucksack-cache rucksack))))
@@ -365,7 +370,7 @@
(when (probe-file roots-file)
(destructuring-bind (root-list class-index slot-index)
(load-objects roots-file)
- (with-slots (roots class-index-table slot-index-tables cache)
+ (with-slots (roots class-index-table slot-index-tables)
rucksack
(setf roots root-list)
(when class-index
@@ -645,7 +650,8 @@
class
rucksack))
(let ((index (rucksack-make-class-index rucksack class)))
- (btree-insert class index :if-exists :overwrite)
+ (btree-insert (class-index-table rucksack) class index
+ :if-exists :overwrite)
index))
(defmethod rucksack-make-class-index
@@ -673,24 +679,23 @@
(defmethod rucksack-map-class-indexes (rucksack function)
- (maphash function (class-index-table rucksack)))
+ (map-btree (class-index-table rucksack) function))
(defmethod rucksack-class-index ((rucksack standard-rucksack) class
&key (errorp nil))
(unless (symbolp class)
(setq class (class-name class)))
- (and (slot-boundp rucksack 'class-index-table)
- (handler-bind ((btree-search-error
- ;; Translate a btree error to something that makes more sense
- ;; in this context.
- (lambda (error)
- (declare (ignore error))
- (simple-rucksack-error "Can't find class index for ~S in ~A."
- class
- rucksack))))
- (btree-search (class-index-table rucksack) class
- :errorp errorp
- :default-value nil))))
+ (handler-bind ((btree-search-error
+ ;; Translate a btree error to something that makes more sense
+ ;; in this context.
+ (lambda (error)
+ (declare (ignore error))
+ (simple-rucksack-error "Can't find class index for ~S in ~A."
+ class
+ rucksack))))
+ (btree-search (class-index-table rucksack) class
+ :errorp errorp
+ :default-value nil)))
(defmethod rucksack-maybe-index-new-object ((rucksack standard-rucksack)
@@ -745,7 +750,7 @@
:key< 'string<
:value= 'p-eql
:unique-keys-p t)))
- (btree-insert table slot-index-tables :if-exists :error)
+ (btree-insert slot-index-tables class table :if-exists :error)
table)))
(new-slot-index (make-index index-spec unique-p)))
(handler-bind ((btree-key-already-present-error
@@ -756,7 +761,7 @@
slot
class
rucksack))))
- (btree-insert slot slot-index-table new-slot-index
+ (btree-insert slot-index-table slot new-slot-index
:if-exists (if errorp :error :overwrite)))
new-slot-index))
@@ -816,16 +821,19 @@
class object slot
old-value new-value
old-boundp new-boundp)
- (let ((index (rucksack-slot-index rucksack class slot)))
+ (let ((index (rucksack-slot-index rucksack class slot
+ :errorp nil
+ :include-superclasses t)))
(when index
- (when old-boundp
- (index-delete index old-value object :if-does-not-exist :ignore))
- (when new-boundp
- (index-insert index new-value object)))))
+ (let ((id (object-id object)))
+ (when old-boundp
+ (index-delete index old-value id :if-does-not-exist :ignore))
+ (when new-boundp
+ (index-insert index new-value id))))))
(defmethod rucksack-slot-index ((rucksack standard-rucksack) class slot
- &key (errorp nil))
+ &key (errorp nil) (include-superclasses nil))
(unless (symbolp class)
(setq class (class-name class)))
(unless (symbolp slot)
@@ -837,8 +845,9 @@
(and slot-index-table
(btree-search slot-index-table slot :errorp nil)))))
(or (find-index class)
- (loop for superclass in (class-precedence-list (find-class class))
- thereis (find-index (class-name superclass)))
+ (and include-superclasses
+ (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."
@@ -848,7 +857,8 @@
(defmethod rucksack-map-slot ((rucksack standard-rucksack) class slot function
- &key equal min max include-min include-max
+ &key min max include-min include-max
+ (equal nil equal-supplied)
(order :ascending)
(id-only nil) (include-subclasses t))
(let ((cache (rucksack-cache rucksack))
@@ -858,19 +868,20 @@
:errorp nil)))
(when index
;; The index maps slot values to object ids.
- (map-index index
- (lambda (slot-value object-id)
- (declare (ignore slot-value))
- (if id-only
- (funcall function object-id)
- (funcall function
- (cache-get-object object-id cache))))
- :equal equal
- :min min
- :max max
- :include-min include-min
- :include-max include-max
- :order order)
+ (apply #'map-index
+ index
+ (lambda (slot-value object-id)
+ (declare (ignore slot-value))
+ (if id-only
+ (funcall function object-id)
+ (funcall function
+ (cache-get-object object-id cache))))
+ :min min
+ :max max
+ :include-min include-min
+ :include-max include-max
+ :order order
+ (if equal-supplied (list :equal equal) '()))
(setf (gethash class visited-p) t))
(when include-subclasses
(loop for class in (class-direct-subclasses
@@ -881,3 +892,25 @@
do (map-slot class))))))
(map-slot (if (symbolp class) (find-class class) class)))))
+;;
+;; 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))))
+ 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))))
+ result))
More information about the rucksack-cvs
mailing list