[rucksack-cvs] CVS rucksack
alemmens
alemmens at common-lisp.net
Thu Aug 10 12:36:17 UTC 2006
Update of /project/rucksack/cvsroot/rucksack
In directory clnet:/tmp/cvs-serv23772
Modified Files:
cache.lisp heap.lisp index.lisp mop.lisp objects.lisp
p-btrees.lisp package.lisp rucksack.lisp schema-table.lisp
test.lisp transactions.lisp
Log Message:
Do a FINISH-OUTPUT at the end of a transaction commit (suggested by Marco Baringer).
Add :KEY-KEY and :VALUE-KEY initargs to btrees.
Add some standard slot indexes.
Add :UNIQUE initarg for persistent slots (not finished yet).
--- /project/rucksack/cvsroot/rucksack/cache.lisp 2006/08/04 10:37:59 1.8
+++ /project/rucksack/cvsroot/rucksack/cache.lisp 2006/08/10 12:36:16 1.9
@@ -1,4 +1,4 @@
-;; $Id: cache.lisp,v 1.8 2006/08/04 10:37:59 alemmens Exp $
+;; $Id: cache.lisp,v 1.9 2006/08/10 12:36:16 alemmens Exp $
(in-package :rucksack)
@@ -378,8 +378,15 @@
(remhash (transaction-id transaction) (transactions cache)))
(defmethod map-transactions ((cache standard-cache) function)
- (loop for transaction being the hash-value of (transactions cache)
- do (funcall function transaction)))
+ ;; FUNCTION may be a function that closes the transaction (removing
+ ;; it from the hash table), so we create a fresh list with transactions
+ ;; before doing the actual iteration.
+ (let ((transactions '()))
+ (loop for transaction being the hash-value of (transactions cache)
+ do (push transaction transactions))
+ ;; Now we can iterate safely.
+ (mapc function transactions)))
+
;;
;; Commit/rollback
@@ -397,7 +404,9 @@
(defmethod cache-commit ((cache standard-cache))
+ ;; Commit all transactions.
(map-transactions cache #'transaction-commit)
+ ;; Save the schema table.
(save-schema-table (schema-table cache)))
;;
--- /project/rucksack/cvsroot/rucksack/heap.lisp 2006/08/09 13:23:18 1.10
+++ /project/rucksack/cvsroot/rucksack/heap.lisp 2006/08/10 12:36:16 1.11
@@ -1,4 +1,4 @@
-;; $Id: heap.lisp,v 1.10 2006/08/09 13:23:18 alemmens Exp $
+;; $Id: heap.lisp,v 1.11 2006/08/10 12:36:16 alemmens Exp $
(in-package :rucksack)
@@ -96,6 +96,8 @@
(defmethod close-heap ((heap heap))
(close (heap-stream heap)))
+(defmethod finish-heap-output ((heap heap))
+ (finish-output (heap-stream heap)))
;;
;; Heap start/end
--- /project/rucksack/cvsroot/rucksack/index.lisp 2006/08/08 13:35:18 1.3
+++ /project/rucksack/cvsroot/rucksack/index.lisp 2006/08/10 12:36:16 1.4
@@ -1,4 +1,4 @@
-;; $Id: index.lisp,v 1.3 2006/08/08 13:35:18 alemmens Exp $
+;; $Id: index.lisp,v 1.4 2006/08/10 12:36:16 alemmens Exp $
(in-package :rucksack)
@@ -62,7 +62,7 @@
;; 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= EQL)
+;; Examples: BTREE, (BTREE :KEY< < :VALUE= P-EQL)
(defun make-index (index-spec)
(if (symbolp index-spec)
@@ -82,3 +82,28 @@
(plist-subset-p (rest index-spec-1) (rest index-spec-2))
(plist-subset-p (rest index-spec-2) (rest index-spec-1))))))
+
+;;
+;; Predefined index specs for slots of persistent classes.
+;;
+
+(defparameter *number-index*
+ '(btree :key< < :value= p-eql))
+
+(defparameter *string-index*
+ '(btree :key< string< :value p-eql))
+
+(defparameter *symbol-index*
+ '(btree :key< string< :value p-eql))
+
+(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))
--- /project/rucksack/cvsroot/rucksack/mop.lisp 2006/05/28 12:07:55 1.3
+++ /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/10 12:36:16 1.4
@@ -1,4 +1,4 @@
-;; $Id: mop.lisp,v 1.3 2006/05/28 12:07:55 alemmens Exp $
+;; $Id: mop.lisp,v 1.4 2006/08/10 12:36:16 alemmens Exp $
(in-package :rucksack)
@@ -25,7 +25,19 @@
transient slots. Default value is T.")
(index :initarg :index
:initform nil
- :reader slot-index)))
+ :reader slot-index
+ :documentation "An index spec for indexed slots, NIL for
+non-indexed slots. Default value is NIL.")
+ (unique :initarg :unique
+ :initform nil
+ :reader slot-unique
+ :documentation "Only relevant for indexed slots. Can be
+either NIL (slot values are not unique), T (slot values are unique,
+and an error will be signaled for attempts to add a duplicate slot
+value) or :NO-ERROR (slot values are unique, but no error will be
+signaled for attempts to add a duplicate slot value). :NO-ERROR
+should only be used when speed is critical.
+ The default value is NIL.")))
(defclass persistent-direct-slot-definition
(persistent-slot-mixin standard-direct-slot-definition)
@@ -49,7 +61,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Processing class and slot options for objects of metaclass
-;; PERSISTENT-CLASS.
+;;; PERSISTENT-CLASS.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#+lispworks
@@ -58,7 +70,7 @@
value
already-processed-options
slot)
- (if (member option '(:index :persistence))
+ (if (member option '(:index :persistence :unique))
(list* option value already-processed-options)
(call-next-method)))
@@ -66,7 +78,7 @@
(defmethod clos:process-a-class-option ((class persistent-class)
option-name
value)
- (if (member value '(:index))
+ (if (member value '(:index :unique))
(list option-name value)
(call-next-method)))
@@ -169,28 +181,28 @@
(defmethod compute-effective-slot-definition ((class persistent-class)
slot-name
direct-slot-definitions)
- (let ((effective-slotd (call-next-method))
- (persistent-slotds
- (remove-if-not (lambda (slotd)
- (typep slotd 'persistent-direct-slot-definition))
+ (let ((effective-slotdef (call-next-method))
+ (persistent-slotdefs
+ (remove-if-not (lambda (slotdef)
+ (typep slotdef 'persistent-direct-slot-definition))
direct-slot-definitions)))
;; If any direct slot is persistent, then the effective one is too.
- (setf (slot-value effective-slotd 'persistence)
- (some #'slot-persistence persistent-slotds))
+ (setf (slot-value effective-slotdef 'persistence)
+ (some #'slot-persistence persistent-slotdefs))
- ;; If exactly one direct slot is indexed, then the effecive one is
+ ;; If exactly one direct slot is indexed, then the effective one is
;; too. If more then one is indexed, signal an error.
- (let ((index-slotds (remove-if-not #'slot-index persistent-slotds)))
- (cond ((cdr index-slotds)
+ (let ((index-slotdefs (remove-if-not #'slot-index persistent-slotdefs)))
+ (cond ((cdr index-slotdefs)
(error "Multiple indexes for slot ~S in ~S:~% ~{~S~^, ~}."
slot-name class
- (mapcar #'slot-index index-slotds)))
- (index-slotds
- (setf (slot-value effective-slotd 'index)
- (slot-index (car index-slotds))))))
+ (mapcar #'slot-index index-slotdefs)))
+ (index-slotdefs
+ (setf (slot-value effective-slotdef 'index)
+ (slot-index (car index-slotdefs))))))
;; Return the effective slot definition.
- effective-slotd))
+ effective-slotdef))
--- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/09 13:23:18 1.7
+++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/10 12:36:16 1.8
@@ -1,4 +1,4 @@
-;; $Id: objects.lisp,v 1.7 2006/08/09 13:23:18 alemmens Exp $
+;; $Id: objects.lisp,v 1.8 2006/08/10 12:36:16 alemmens Exp $
(in-package :rucksack)
@@ -88,10 +88,11 @@
(transaction-id :reader transaction-id)
(rucksack :initarg :rucksack :initform (current-rucksack) :reader rucksack)
(contents :initarg :contents :accessor contents))
- (:documentation "PERSISTENT-DATA classes do not have
-PERSISTENT-CLASS as metaclass because we don't want to specialize
-SLOT-VALUE-USING-CLASS & friends for persistent-data instances. Their
-contents are accessed by special functions like P-CAR instead."))
+ (:documentation
+ "PERSISTENT-DATA classes do not have PERSISTENT-CLASS as metaclass
+because we don't want to specialize SLOT-VALUE-USING-CLASS & friends
+for persistent-data instances. Their contents are accessed by special
+functions like P-CAR instead."))
(defmethod print-object ((object persistent-data) stream)
(print-unreadable-object (object stream :type t :identity nil)
--- /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/08/08 13:35:18 1.8
+++ /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/08/10 12:36:16 1.9
@@ -1,4 +1,4 @@
-;; $Id: p-btrees.lisp,v 1.8 2006/08/08 13:35:18 alemmens Exp $
+;; $Id: p-btrees.lisp,v 1.9 2006/08/10 12:36:16 alemmens Exp $
(in-package :rucksack)
@@ -187,9 +187,18 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass btree ()
- ((key< :initarg :key< :reader btree-key< :initform '<)
- (value= :initarg :value= :reader btree-value= :initform 'p-eql
+ ((key< :initarg :key< :initform '<)
+ (value= :initarg :value= :initform 'p-eql
:documentation "This is only used for btrees with non-unique keys.")
+ (key-key :initarg :key-key :reader btree-key-key :initform 'identity
+ :documentation "A unary function that is applied to a
+btree key before comparing it to another key with a key comparison
+predicate like BTREE-KEY<.")
+ (value-key :initarg :value-key :reader btree-value-key :initform 'identity
+ :documentation "A unary function that is applied to a
+btree value before comparing it to another value with the BTREE-VALUE=
+predicate.")
+
;;
(node-class :initarg :node-class
:reader btree-node-class
@@ -218,48 +227,75 @@
(defmethod initialize-instance :around ((btree btree)
&rest initargs
- &key key< value=
+ &key key< key-key value= value-key
&allow-other-keys)
;; It must be possible to save these btrees in the cache, but
;; that will not work for function objects because they can't be
;; serialized. This means that you should only specify symbols that
;; name a function. For program-independent databases you should
- ;; only use symbols from the COMMON-LISP package.
+ ;; only use symbols from the COMMON-LISP or RUCKSACK packages.
(declare (ignore initargs))
- (if (and (symbolp key<) (symbolp value=))
+ (if (and (symbolp key<) (symbolp value=)
+ (symbolp key-key) (symbolp value-key))
(call-next-method)
- (error "The :key< and :value= initargs for persistent btrees
-must be symbols naming a function, otherwise they can't be saved on
-disk.")))
+ (error "The :key<, :key-key, :value= and :value-key initargs for
+persistent btrees must be symbols naming a function, otherwise they
+can't be saved on disk.")))
;;
;; Comparison functions that can be deduced from KEY< (because the
;; btree keys have a total order).
;;
+(defmethod btree-key< ((btree btree))
+ (let ((key< (slot-value btree 'key<))
+ (key-key (btree-key-key btree)))
+ (lambda (key1 key2)
+ (funcall key<
+ (funcall key-key key1)
+ (funcall key-key key2)))))
+
(defmethod btree-key= ((btree btree))
- (let ((key< (btree-key< btree)))
+ (let ((key< (slot-value btree 'key<))
+ (key-key (btree-key-key btree)))
(lambda (key1 key2)
- (and (not (funcall key< key1 key2))
- (not (funcall key< key2 key1))))))
+ (let ((key1 (funcall key-key key1))
+ (key2 (funcall key-key key2)))
+ (and (not (funcall key< key1 key2))
+ (not (funcall key< key2 key1)))))))
(defmethod btree-key>= ((btree btree))
(lambda (key1 key2)
(not (funcall (btree-key< btree) key1 key2))))
(defmethod btree-key<= ((btree btree))
- (let ((key< (btree-key< btree)))
+ (let ((key< (slot-value btree 'key<))
+ (key-key (btree-key-key btree)))
(lambda (key1 key2)
- (or (funcall key< key1 key2)
- (not (funcall key< key2 key1))))))
+ (let ((key1 (funcall key-key key1))
+ (key2 (funcall key-key key2)))
+ (or (funcall key< key1 key2)
+ (not (funcall key< key2 key1)))))))
(defmethod btree-key> ((btree btree))
- (let ((key< (btree-key< btree)))
+ (let ((key< (slot-value btree 'key<))
+ (key-key (btree-key-key btree)))
(lambda (key1 key2)
- (and (not (funcall key< key1 key2))
- (funcall key< key2 key1)))))
+ (let ((key1 (funcall key-key key1))
+ (key2 (funcall key-key key2)))
+ (and (not (funcall key< key1 key2))
+ (funcall key< key2 key1))))))
+(defmethod btree-value= ((btree btree))
+ (let ((value= (slot-value btree 'value=))
+ (value-key (btree-value-key btree)))
+ (lambda (value1 value2)
+ (let ((value1 (funcall value-key value1))
+ (value2 (funcall value-key value2)))
+ (funcall value= value1 value2)))))
+
+
;;
;; The next two classes are for internal use only, so we don't bother
;; with fancy long names.
--- /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/08 13:35:18 1.5
+++ /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/10 12:36:17 1.6
@@ -1,4 +1,4 @@
-;; $Id: package.lisp,v 1.5 2006/08/08 13:35:18 alemmens Exp $
+;; $Id: package.lisp,v 1.6 2006/08/10 12:36:17 alemmens Exp $
#-(or allegro lispworks sbcl openmcl)
(error "Unsupported implementation: ~A" (lisp-implementation-type))
@@ -78,6 +78,8 @@
;; Indexes
#:map-index #:index-insert #:index-delete #:make-index
+ #:*string-index* #:*number-index* #:*symbol-index*
+ #:*trimmed-string-index* #:*case-insensitive-string-index*
;; Btrees
#:btree
--- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/09 13:23:18 1.8
+++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/10 12:36:17 1.9
@@ -1,4 +1,4 @@
-;; $Id: rucksack.lisp,v 1.8 2006/08/09 13:23:18 alemmens Exp $
+;; $Id: rucksack.lisp,v 1.9 2006/08/10 12:36:17 alemmens Exp $
(in-package :rucksack)
@@ -283,6 +283,9 @@
(rucksack-roots-pathname rucksack))
(setf (roots-changed-p rucksack) nil))
+(defun save-roots-if-necessary (rucksack)
+ (when (roots-changed-p rucksack)
+ (save-roots rucksack)))
(defmethod add-rucksack-root (object (rucksack standard-rucksack))
(add-rucksack-root-id (object-id object) rucksack))
@@ -438,7 +441,7 @@
(rucksack-add-class-index rucksack class :errorp t))
(t
;; We don't need to change anything
- 'no-change))))
+ :no-change))))
(defmethod rucksack-update-slot-indexes ((rucksack standard-rucksack)
(class persistent-class))
@@ -447,7 +450,7 @@
(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)
+ :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))
@@ -519,7 +522,8 @@
(defmethod rucksack-make-class-index
((rucksack standard-rucksack) class
&key
- (index-spec '(btree :key< < :key= = :value= eql)))
+ (index-spec '(btree :key< < :key= = :value= eql :unique-keys-p t)))
+ ;; A class index maps object ids to objects.
(declare (ignore class))
(make-index index-spec))
--- /project/rucksack/cvsroot/rucksack/schema-table.lisp 2006/05/16 22:01:27 1.2
+++ /project/rucksack/cvsroot/rucksack/schema-table.lisp 2006/08/10 12:36:17 1.3
@@ -1,4 +1,4 @@
-;; $Id: schema-table.lisp,v 1.2 2006/05/16 22:01:27 alemmens Exp $
+;; $Id: schema-table.lisp,v 1.3 2006/08/10 12:36:17 alemmens Exp $
(in-package :rucksack)
@@ -86,6 +86,9 @@
(setf (dirty-p table) nil)
(save-objects (list table) (schema-table-pathname table)))
+(defmethod save-schema-table-if-necessary ((table schema-table))
+ (when (dirty-p table)
+ (save-schema-table table)))
(defun open-schema-table (pathname &key if-exists if-does-not-exist)
;; Load existing schemas from the file.
--- /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/09 13:23:18 1.8
+++ /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/10 12:36:17 1.9
@@ -1,4 +1,4 @@
-;; $Id: test.lisp,v 1.8 2006/08/09 13:23:18 alemmens Exp $
+;; $Id: test.lisp,v 1.9 2006/08/10 12:36:17 alemmens Exp $
(in-package :test-rucksack)
@@ -430,3 +430,32 @@
(inner (p-cdr (p-cdr (p-cdr root)))))
;; we expect the list ("Waldorf" "Statler") here
(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))
+|#
--- /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/09 13:23:18 1.9
+++ /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/10 12:36:17 1.10
@@ -1,4 +1,4 @@
-;; $Id: transactions.lisp,v 1.9 2006/08/09 13:23:18 alemmens Exp $
+;; $Id: transactions.lisp,v 1.10 2006/08/10 12:36:17 alemmens Exp $
(in-package :rucksack)
@@ -216,8 +216,20 @@
;; 5. Let the garbage collector do an amount of work proportional
;; to the number of octets that were allocated during the commit.
(collect-some-garbage heap
- (gc-work-for-size heap nr-allocated-octets))))
-
+ (gc-work-for-size heap nr-allocated-octets))
+ ;; 6. Make sure that all changes are actually on disk before
+ ;; we continue.
+ (finish-all-output rucksack)))
+
+(defmethod finish-all-output ((rucksack standard-rucksack))
+ (let ((cache (rucksack-cache rucksack)))
+ (finish-heap-output (heap cache))
+ (finish-heap-output (object-table (heap cache)))
+ ;; NOTE: I'm not totally sure that saving the roots and schema table
+ ;; for each transaction commit is necessary, but it probably is. So
+ ;; let's play safe for now.
+ (save-roots-if-necessary rucksack)
+ (save-schema-table-if-necessary (schema-table cache))))
;;
More information about the rucksack-cvs
mailing list