From alemmens at common-lisp.net Wed Jan 16 15:08:21 2008 From: alemmens at common-lisp.net (alemmens) Date: Wed, 16 Jan 2008 10:08:21 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20080116150821.A6780610B4@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv13762 Modified Files: p-btrees.lisp rucksack.asd transactions.lisp Log Message: When deleting a key from a btree, use the BTREE-KEY= function (not P-EQL) to determine the position of the key. Reported and fixed by Leonid Novikov. --- /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2007/08/12 13:01:14 1.15 +++ /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2008/01/16 15:08:20 1.16 @@ -1,4 +1,4 @@ -;; $Id: p-btrees.lisp,v 1.15 2007/08/12 13:01:14 alemmens Exp $ +;; $Id: p-btrees.lisp,v 1.16 2008/01/16 15:08:20 alemmens Exp $ (in-package :rucksack) @@ -869,11 +869,11 @@ (:ignore (return-from leaf-delete-key)) (:error (error 'btree-search-error :btree btree :key key)))) - (let* ((position (key-position key leaf)) + (let* ((position (key-position key leaf (btree-key= btree))) (length (btree-node-index-count leaf)) (was-biggest-key-p (= position (1- length)))) - (remove-key leaf (binding-key binding)) + (remove-key leaf (binding-key binding) (btree-key= btree)) (unless (node-full-enough-p btree leaf) (enlarge-node btree leaf parent-stack)) @@ -915,7 +915,7 @@ (when parent-stack (let ((node (first parent-stack))) (when node - (let ((position (key-position old-key node))) + (let ((position (key-position old-key node (btree-key= btree)))) (when position (setf (binding-key (node-binding node position)) new-key) @@ -978,7 +978,7 @@ :start1 left-length :start2 0 :end2 right-length) ;; Remove key which pointed to LEFT-NODE. - (remove-key parent (binding-key left-binding)) + (remove-key parent (binding-key left-binding) (btree-key= btree)) ;; Make binding which pointed to RIGHT-NODE point to LEFT-NODE. (setf (binding-value right-binding) left-node) ;; Set new length of LEFT-NODE. @@ -1002,8 +1002,8 @@ do (setf (node-binding node i) nil)) (setf (btree-node-index-count node) new-length)) -(defun remove-key (node key) - (let ((position (key-position key node)) +(defun remove-key (node key test) + (let ((position (key-position key node test)) (length (btree-node-index-count node))) (unless (>= position (1- length)) ;; Move bindings to the left. @@ -1013,9 +1013,10 @@ :start2 (1+ position) :end2 length))) (shorten node (1- length)))) -(defun key-position (key node) +(defun key-position (key node test) (p-position key (btree-node-index node) :key #'binding-key + :test test :end (btree-node-index-count node))) (defun node-full-enough-p (btree node) --- /project/rucksack/cvsroot/rucksack/rucksack.asd 2007/08/12 13:01:14 1.11 +++ /project/rucksack/cvsroot/rucksack/rucksack.asd 2008/01/16 15:08:21 1.12 @@ -1,24 +1,23 @@ -;;; $Id: rucksack.asd,v 1.11 2007/08/12 13:01:14 alemmens Exp $ - -(in-package :cl-user) - -(asdf:defsystem :rucksack - :version "0.1.9" - :serial t - :components ((:file "queue") - (:file "package") - (:file "errors") - (:file "mop") - (:file "serialize" ) - (:file "heap") - (:file "object-table") - (:file "schema-table") - (:file "garbage-collector") - (:file "cache") - (:file "objects") - (:file "p-btrees") - (:file "index") - (:file "rucksack") - (:file "transactions") - (:file "test"))) - +;;; $Id: rucksack.asd,v 1.12 2008/01/16 15:08:21 alemmens Exp $ + +(in-package :cl-user) + +(asdf:defsystem :rucksack + :version "0.1.9" + :serial t + :components ((:file "queue") + (:file "package") + (:file "errors") + (:file "mop") + (:file "serialize" ) + (:file "heap") + (:file "object-table") + (:file "schema-table") + (:file "garbage-collector") + (:file "cache") + (:file "objects") + (:file "p-btrees") + (:file "index") + (:file "rucksack") + (:file "transactions") + (:file "test"))) --- /project/rucksack/cvsroot/rucksack/transactions.lisp 2007/01/20 18:17:55 1.13 +++ /project/rucksack/cvsroot/rucksack/transactions.lisp 2008/01/16 15:08:21 1.14 @@ -1,4 +1,4 @@ -;; $Id: transactions.lisp,v 1.13 2007/01/20 18:17:55 alemmens Exp $ +;; $Id: transactions.lisp,v 1.14 2008/01/16 15:08:21 alemmens Exp $ (in-package :rucksack) @@ -39,7 +39,7 @@ (dirty-objects :initarg :dirty-objects :initform (make-hash-table) :reader dirty-objects - :documentation "A hash-table (from id to object) + :documentation "A hash-table \(from id to object) containing all objects of which the slot changes have not been written to disk yet.") (dirty-queue :initarg :dirty-queue @@ -48,7 +48,7 @@ :documentation "A queue with the ids of all objects that have been created or modified since the last commit. The queue is in least-recently-dirtied-first order. During a commit, the -objects are written to disk in the same order (this is necessary to +objects are written to disk in the same order \(this is necessary to guarantee that the garbage collector never sees an id of an object that doesn't exist on disk yet."))) From alemmens at common-lisp.net Tue Jan 22 15:59:25 2008 From: alemmens at common-lisp.net (alemmens) Date: Tue, 22 Jan 2008 10:59:25 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20080122155925.3861E340A2@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv24259 Modified Files: done.txt index.lisp p-btrees.lisp rucksack.asd rucksack.lisp test.lisp Log Message: - Fix bug caused by LEAF-DELETE-KEY. Reported and fixed by Brad Beveridge. - Fix some typos (:VALUE should be :VALUE=) in index.lisp. - Version 0.1.11. --- /project/rucksack/cvsroot/rucksack/done.txt 2007/08/13 15:14:28 1.11 +++ /project/rucksack/cvsroot/rucksack/done.txt 2008/01/22 15:59:24 1.12 @@ -1,3 +1,18 @@ +* 2008-01-22 - version 0.1.11 + +- Fix bug caused by LEAF-DELETE-KEY. Reported and fixed by + Brad Beveridge. + +- Fix some typos (:VALUE should be :VALUE=) in index.lisp. + + +* 2008-01-16 - version 0.1.10 + +- When deleting a key from a btree, use the BTREE-KEY= function (not + P-EQL) to determine the position of the key. Reported and fixed + by Leonid Novikov. + + * 2007-08-12 - version 0.1.9 - Fix btree bug during btree-delete: if we're deleting the biggest key --- /project/rucksack/cvsroot/rucksack/index.lisp 2007/08/12 13:01:13 1.10 +++ /project/rucksack/cvsroot/rucksack/index.lisp 2008/01/22 15:59:24 1.11 @@ -1,4 +1,4 @@ -;; $Id: index.lisp,v 1.10 2007/08/12 13:01:13 alemmens Exp $ +;; $Id: index.lisp,v 1.11 2008/01/22 15:59:24 alemmens Exp $ (in-package :rucksack) @@ -196,18 +196,18 @@ '(btree :key< < :value= p-eql)) (define-index-spec :string-index - '(btree :key< string< :value p-eql :key-type string)) + '(btree :key< string< :value= p-eql :key-type string)) (define-index-spec :symbol-index - '(btree :key< string< :value p-eql :key-type symbol)) + '(btree :key< string< :value= p-eql :key-type symbol)) (define-index-spec :case-insensitive-string-index - '(btree :key< string-lessp :value p-eql :key-type string)) + '(btree :key< string-lessp :value= p-eql :key-type string)) (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 + :value= p-eql :key-type string))) --- /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2008/01/16 15:08:20 1.16 +++ /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2008/01/22 15:59:24 1.17 @@ -1,4 +1,4 @@ -;; $Id: p-btrees.lisp,v 1.16 2008/01/16 15:08:20 alemmens Exp $ +;; $Id: p-btrees.lisp,v 1.17 2008/01/22 15:59:24 alemmens Exp $ (in-package :rucksack) @@ -261,7 +261,9 @@ (lambda (key1 key2) (let ((key1 (funcall key-key key1)) (key2 (funcall key-key key2))) - (and (not (funcall key< key1 key2)) + (and (not (eql key1 'key-irrelevant)) + (not (eql key2 'key-irrelevant)) + (not (funcall key< key1 key2)) (not (funcall key< key2 key1))))))) (defmethod btree-key>= ((btree btree)) @@ -869,18 +871,23 @@ (:ignore (return-from leaf-delete-key)) (:error (error 'btree-search-error :btree btree :key key)))) - (let* ((position (key-position key leaf (btree-key= btree))) + (let* ((position (key-position btree key leaf)) (length (btree-node-index-count leaf)) (was-biggest-key-p (= position (1- length)))) - (remove-key leaf (binding-key binding) (btree-key= btree)) - - (unless (node-full-enough-p btree leaf) - (enlarge-node btree leaf parent-stack)) + (remove-key btree leaf (binding-key binding)) (when was-biggest-key-p + ;; Parent nodes always keep track of the biggest key in + ;; their child nodes. So if we just deleted the biggest + ;; key from this leaf, the parent node needs to be updated + ;; with the key that is now the biggest of this leaf. (unless (= 0 (btree-node-index-count leaf)) - (update-parents-for-deleted-key btree parent-stack key (biggest-key leaf))))))) + (let ((biggest-key (biggest-key leaf))) + (update-parents-for-deleted-key btree parent-stack key biggest-key)))) + + (unless (node-full-enough-p btree leaf) + (enlarge-node btree leaf parent-stack))))) (defun enlarge-node (btree node parent-stack) @@ -889,21 +896,22 @@ ;; are only half full; in that case we merge some nodes.) (let ((parent (first parent-stack))) ;; Don't enlarge root node. - (unless parent + (when (null parent) (return-from enlarge-node)) (let ((node-pos (node-position node parent)) left-sibling) - (when (plusp node-pos) ; there is a left sibling + (when (plusp node-pos) + ;; There is a left sibling. (setq left-sibling (binding-value (node-binding parent (1- node-pos)))) (unless (node-has-min-size-p btree left-sibling) (distribute-elements left-sibling node parent) (return-from enlarge-node))) - (when (< (1+ node-pos) (btree-node-index-count parent)) ; there is a right sibling + (when (< (1+ node-pos) (btree-node-index-count parent)) + ;; There is a right sibling. (let ((right-sibling (binding-value (node-binding parent (1+ node-pos))))) - (unless (node-has-min-size-p btree right-sibling) - (distribute-elements node right-sibling parent) - (return-from enlarge-node)) - (join-nodes btree node right-sibling parent-stack) + (if (node-has-min-size-p btree right-sibling) + (join-nodes btree node right-sibling parent-stack) + (distribute-elements node right-sibling parent)) (return-from enlarge-node))) (when left-sibling (join-nodes btree left-sibling node parent-stack) @@ -915,22 +923,23 @@ (when parent-stack (let ((node (first parent-stack))) (when node - (let ((position (key-position old-key node (btree-key= btree)))) + (let ((position (key-position btree old-key node))) (when position (setf (binding-key (node-binding node position)) new-key) (update-parents-for-deleted-key btree (rest parent-stack) old-key new-key))))))) -;; The idea is that DISTRIBUTE-ELEMENTS will only be called if the union of -;; the two nodes has enough elements for two "legal" nodes. JOIN-NODES, -;; OTOH, makes one node out of two, deletes one key in the parent, and -;; finally checks the parent to see if it has to be enlarged as well. +;; The idea is that DISTRIBUTE-ELEMENTS will only be called if the +;; union of the two nodes has enough elements for two nodes that are +;; 'full enough'. JOIN-NODES, OTOH, makes one node out of two, +;; deletes one key in the parent, and finally checks the parent to see +;; if it has to be enlarged as well. (defun distribute-elements (left-node right-node parent) - ;; One of LEFT-NODE and RIGHT-NODE doesn't have enough elements, but - ;; the union of both has enough elements for two nodes, so we - ;; redistribute the elements between the two nodes. + "One of LEFT-NODE and RIGHT-NODE doesn't have enough elements, but +the union of both has enough elements for two nodes, so we +redistribute the elements between the two nodes." (let* ((left-index (btree-node-index left-node)) (left-length (btree-node-index-count left-node)) (right-index (btree-node-index right-node)) @@ -963,8 +972,8 @@ (biggest-key left-node)))) (defun join-nodes (btree left-node right-node parent-stack) - ;; Create one node which contains the elements of both LEFT-NODE and - ;; RIGHT-NODE. + "Create one node which contains the elements of both LEFT-NODE and +RIGHT-NODE." (let* ((parent (first parent-stack)) (left-index (btree-node-index left-node)) (left-length (btree-node-index-count left-node)) @@ -978,7 +987,7 @@ :start1 left-length :start2 0 :end2 right-length) ;; Remove key which pointed to LEFT-NODE. - (remove-key parent (binding-key left-binding) (btree-key= btree)) + (remove-key btree parent (binding-key left-binding)) ;; Make binding which pointed to RIGHT-NODE point to LEFT-NODE. (setf (binding-value right-binding) left-node) ;; Set new length of LEFT-NODE. @@ -1002,8 +1011,8 @@ do (setf (node-binding node i) nil)) (setf (btree-node-index-count node) new-length)) -(defun remove-key (node key test) - (let ((position (key-position key node test)) +(defun remove-key (btree node key) + (let ((position (key-position btree key node)) (length (btree-node-index-count node))) (unless (>= position (1- length)) ;; Move bindings to the left. @@ -1013,10 +1022,10 @@ :start2 (1+ position) :end2 length))) (shorten node (1- length)))) -(defun key-position (key node test) +(defun key-position (btree key node) (p-position key (btree-node-index node) :key #'binding-key - :test test + :test (btree-key= btree) :end (btree-node-index-count node))) (defun node-full-enough-p (btree node) --- /project/rucksack/cvsroot/rucksack/rucksack.asd 2008/01/16 15:08:21 1.12 +++ /project/rucksack/cvsroot/rucksack/rucksack.asd 2008/01/22 15:59:24 1.13 @@ -1,9 +1,9 @@ -;;; $Id: rucksack.asd,v 1.12 2008/01/16 15:08:21 alemmens Exp $ +;;; $Id: rucksack.asd,v 1.13 2008/01/22 15:59:24 alemmens Exp $ (in-package :cl-user) (asdf:defsystem :rucksack - :version "0.1.9" + :version "0.1.11" :serial t :components ((:file "queue") (:file "package") --- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2007/08/12 13:01:14 1.21 +++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2008/01/22 15:59:24 1.22 @@ -1,4 +1,4 @@ -;; $Id: rucksack.lisp,v 1.21 2007/08/12 13:01:14 alemmens Exp $ +;; $Id: rucksack.lisp,v 1.22 2008/01/22 15:59:24 alemmens Exp $ (in-package :rucksack) @@ -304,8 +304,9 @@ (roots-changed-p :initform nil :accessor roots-changed-p) ;; Indexes (class-index-table :documentation - "A btree mapping class names to indexes. Each index contains the ids -of all instances from a class.") + "A btree mapping class names to class indexes. Each class index +contains the ids of all instances from a class; technically speaking, +it maps object ids to themselves.") (slot-index-tables :documentation "A btree mapping class names to slot index tables, where each slot index table is a btree mapping slot names to slot indexes. Each slot --- /project/rucksack/cvsroot/rucksack/test.lisp 2007/08/12 13:01:14 1.15 +++ /project/rucksack/cvsroot/rucksack/test.lisp 2008/01/22 15:59:24 1.16 @@ -1,4 +1,4 @@ -;; $Id: test.lisp,v 1.15 2007/08/12 13:01:14 alemmens Exp $ +;; $Id: test.lisp,v 1.16 2008/01/22 15:59:24 alemmens Exp $ (in-package :rucksack-test) @@ -432,5 +432,3 @@ (inner (p-cdr (p-cdr (p-cdr root))))) ;; we expect the list ("Waldorf" "Statler") here (list (p-car inner) (p-cdr inner)))))) - - From alemmens at common-lisp.net Tue Jan 22 17:02:07 2008 From: alemmens at common-lisp.net (alemmens) Date: Tue, 22 Jan 2008 12:02:07 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20080122170207.ECEA1830B9@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv6909 Modified Files: done.txt heap.lisp rucksack.asd Log Message: Version 0.1.12. Use (ARRAY-DIMENSION buffer 0) instead of LENGTH in LOAD-BUFFER, because we want to ignore the fill pointer here. Thanks to Sean Ross. --- /project/rucksack/cvsroot/rucksack/done.txt 2008/01/22 15:59:24 1.12 +++ /project/rucksack/cvsroot/rucksack/done.txt 2008/01/22 17:02:07 1.13 @@ -1,3 +1,12 @@ +* 2008-01-22 - version 0.1.12 + +- Use (ARRAY-DIMENSION buffer 0) instead of LENGTH in + LOAD-BUFFER, because we want to ignore the fill pointer + here. Thanks to Sean Ross. + + + + * 2008-01-22 - version 0.1.11 - Fix bug caused by LEAF-DELETE-KEY. Reported and fixed by --- /project/rucksack/cvsroot/rucksack/heap.lisp 2007/03/13 13:13:00 1.15 +++ /project/rucksack/cvsroot/rucksack/heap.lisp 2008/01/22 17:02:07 1.16 @@ -1,4 +1,4 @@ -;; $Id: heap.lisp,v 1.15 2007/03/13 13:13:00 alemmens Exp $ +;; $Id: heap.lisp,v 1.16 2008/01/22 17:02:07 alemmens Exp $ (in-package :rucksack) @@ -575,7 +575,10 @@ (with-slots (contents) buffer ;; If the buffer isn't big enough, make a bigger buffer. - (when (< (length contents) nr-octets) + ;; We can't use LENGTH instead of ARRAY-DIMENSION, because + ;; LENGTH looks at the fill pointer instead of the entire + ;; buffer. + (when (< (array-dimension contents 0) nr-octets) (setf contents (make-array nr-octets :adjustable t --- /project/rucksack/cvsroot/rucksack/rucksack.asd 2008/01/22 15:59:24 1.13 +++ /project/rucksack/cvsroot/rucksack/rucksack.asd 2008/01/22 17:02:07 1.14 @@ -1,9 +1,9 @@ -;;; $Id: rucksack.asd,v 1.13 2008/01/22 15:59:24 alemmens Exp $ +;;; $Id: rucksack.asd,v 1.14 2008/01/22 17:02:07 alemmens Exp $ (in-package :cl-user) (asdf:defsystem :rucksack - :version "0.1.11" + :version "0.1.12" :serial t :components ((:file "queue") (:file "package") From alemmens at common-lisp.net Wed Jan 23 15:42:15 2008 From: alemmens at common-lisp.net (alemmens) Date: Wed, 23 Jan 2008 10:42:15 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack/tests Message-ID: <20080123154215.25C3F49110@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack/tests In directory clnet:/tmp/cvs-serv1911/tests Log Message: Directory /project/rucksack/cvsroot/rucksack/tests added to the repository From alemmens at common-lisp.net Wed Jan 23 15:43:42 2008 From: alemmens at common-lisp.net (alemmens) Date: Wed, 23 Jan 2008 10:43:42 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20080123154342.4D6BF50009@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv2005 Modified Files: done.txt objects.lisp package.lisp rucksack.asd Log Message: Version 0.1.13: Add Brad Beveridge's basic unit test suite (modified to work with lisp-unit instead of 5am). Add Chris Riesbeck's lisp-unit library to help with creating unit test suites. --- /project/rucksack/cvsroot/rucksack/done.txt 2008/01/22 17:02:07 1.13 +++ /project/rucksack/cvsroot/rucksack/done.txt 2008/01/23 15:43:42 1.14 @@ -1,3 +1,18 @@ +* 2008-01-23 - version 0.1.13 + +- Add Brad Beveridge's basic unit test suite (modified to work + with lisp-unit instead of 5am). + +- Add Chris Riesbeck's lisp-unit library to help with creating + unit test suites. + +- Move all tests to their own directory. + +- Add P-NREVERSE and P-POSITION for persistent lists. + +- Fix bugs in P-REPLACE and P-MAPCAR. + + * 2008-01-22 - version 0.1.12 - Use (ARRAY-DIMENSION buffer 0) instead of LENGTH in @@ -5,8 +20,6 @@ here. Thanks to Sean Ross. - - * 2008-01-22 - version 0.1.11 - Fix bug caused by LEAF-DELETE-KEY. Reported and fixed by --- /project/rucksack/cvsroot/rucksack/objects.lisp 2007/01/20 18:17:55 1.18 +++ /project/rucksack/cvsroot/rucksack/objects.lisp 2008/01/23 15:43:42 1.19 @@ -1,4 +1,4 @@ -;; $Id: objects.lisp,v 1.18 2007/01/20 18:17:55 alemmens Exp $ +;; $Id: objects.lisp,v 1.19 2008/01/23 15:43:42 alemmens Exp $ (in-package :rucksack) @@ -119,7 +119,8 @@ (defmethod persistent-data-write (function (data persistent-data) value &rest args) (apply function value (contents data) args) - (cache-touch-object data (cache data))) + (cache-touch-object data (cache data)) + value) (defun make-persistent-data (class contents &optional (rucksack (current-rucksack))) @@ -231,7 +232,7 @@ (setq result (p-cons (funcall function (p-car list)) result) list (p-cdr list))) - result)) + (p-nreverse result))) (defun p-mapc (function list) ;; DO: Accept more than one list argument. @@ -247,7 +248,7 @@ (loop while list do (setq result (p-cons (funcall function list) result) list (p-cdr list))) - result)) + (p-nreverse result))) (defun p-mapl (function list) ;; DO: Accept more than one list argument. @@ -333,6 +334,25 @@ ;; Return nil if not found nil) + +(defmethod p-position (value (list persistent-cons) + &key (key #'identity) (test #'p-eql) + (start 0) (end nil)) + ;; Move list to start position. + (loop repeat start + do (setq list (p-cdr list))) + ;; The real work. + (loop for i from start do + (if (or (p-endp list) (and end (= i end))) + (return-from p-position nil) + (let ((elt (funcall key (p-car list)))) + (if (funcall test value elt) + (return-from p-position i) + (setq list (p-cdr list)))))) + ;; Return nil if not found. + nil) + + (defmethod p-replace ((vector-1 persistent-array) (vector-2 persistent-array) &key (start1 0) end1 (start2 0) end2) @@ -385,6 +405,23 @@ list) +(defmethod p-nreverse ((object (eql nil))) + nil) + +(defmethod p-nreverse ((object persistent-cons)) + (let* ((previous object) + (current (p-cdr previous))) + (setf (p-cdr previous) '()) + (loop until (p-endp current) + do (let ((next (p-cdr current))) + (setf (p-cdr current) previous + previous current + current next))) + previous)) + +;; DO: Implement P-NREVERSE for persistent vectors. + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Full fledged persistent objects ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; --- /project/rucksack/cvsroot/rucksack/package.lisp 2007/01/20 18:17:55 1.11 +++ /project/rucksack/cvsroot/rucksack/package.lisp 2008/01/23 15:43:42 1.12 @@ -1,4 +1,4 @@ -;; $Id: package.lisp,v 1.11 2007/01/20 18:17:55 alemmens Exp $ +;; $Id: package.lisp,v 1.12 2008/01/23 15:43:42 alemmens Exp $ #-(or allegro lispworks sbcl openmcl) (error "Unsupported implementation: ~A" (lisp-implementation-type)) @@ -97,15 +97,6 @@ ;; Conditions #:btree-error #:btree-search-error #:btree-insertion-error #:btree-key-already-present-error #:btree-type-error - #:btree-error-btree #:btree-error-key #:btree-error-value -)) + #:btree-error-btree #:btree-error-key #:btree-error-value)) - -(defpackage :rucksack-test - (:nicknames :rs-test) - (:use :common-lisp :rucksack)) - -(defpackage :rucksack-test-schema-update - (:nicknames :rs-tsu) - (:use :common-lisp :rucksack)) \ No newline at end of file --- /project/rucksack/cvsroot/rucksack/rucksack.asd 2008/01/22 17:02:07 1.14 +++ /project/rucksack/cvsroot/rucksack/rucksack.asd 2008/01/23 15:43:42 1.15 @@ -1,9 +1,9 @@ -;;; $Id: rucksack.asd,v 1.14 2008/01/22 17:02:07 alemmens Exp $ +;;; $Id: rucksack.asd,v 1.15 2008/01/23 15:43:42 alemmens Exp $ (in-package :cl-user) (asdf:defsystem :rucksack - :version "0.1.12" + :version "0.1.13" :serial t :components ((:file "queue") (:file "package") @@ -20,4 +20,5 @@ (:file "index") (:file "rucksack") (:file "transactions") - (:file "test"))) + (:file "import-export"))) + From alemmens at common-lisp.net Wed Jan 23 15:45:03 2008 From: alemmens at common-lisp.net (alemmens) Date: Wed, 23 Jan 2008 10:45:03 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20080123154503.F0C8C50016@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv2215 Added Files: import-export.lisp manual.txt Log Message: Get started with import-export and with a manual. --- /project/rucksack/cvsroot/rucksack/import-export.lisp 2008/01/23 15:45:03 NONE +++ /project/rucksack/cvsroot/rucksack/import-export.lisp 2008/01/23 15:45:03 1.1 (in-package :rucksack) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Import/export ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; The contents of a rucksack can be exported to a single file. The file will ;; contain enough information to reconstruct the original rucksack objects. ;; Rucksack export files use a relatively simple s-expression format. ;; ;; There are two reasons for exporting a rucksack: ;; - backup ;; The export file has a simple format, so it's a lot less sensitive ;; to data corruption bugs. ;; - migration ;; Export files can be imported by newer versions of Rucksack. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Import/export API ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric export-rucksack (rucksack pathname) (:documentation "Export all objects in a rucksack to a file. The resulting file can be imported by newer versions of Rucksack.")) (defgeneric import-rucksack (pathname directory-designator &rest args &key (if-exists :error) &allow-other-keys) (:documentation "Creates a new rucksack in the directory specified by DIRECTORY-DESIGNATOR, opens the new rucksack and imports all objects that were exported to the file specified by PATHNAME.")) --- /project/rucksack/cvsroot/rucksack/manual.txt 2008/01/23 15:45:03 NONE +++ /project/rucksack/cvsroot/rucksack/manual.txt 2008/01/23 15:45:03 1.1 * Getting started To compile and load Rucksack and make sure that the basics are working: 1. Make sure you have ASDF (Another System Definition Facility) loaded. 2. Compile and load rucksack.asd. 3. Compile and load tests/rucksack-test.asd. 4. (asdf:oos 'asdf:load-op :rucksack-test :force t) 5. (in-package :rucksack-test) 6. (run-tests) From alemmens at common-lisp.net Wed Jan 23 15:46:31 2008 From: alemmens at common-lisp.net (alemmens) Date: Wed, 23 Jan 2008 10:46:31 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack/tests Message-ID: <20080123154631.0010B50036@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack/tests In directory clnet:/tmp/cvs-serv2369 Added Files: lisp-unit.lisp package.lisp regression-1.lisp rucksack-test.asd unit-tests.lisp Log Message: Actually commit the files in the new test directory. --- /project/rucksack/cvsroot/rucksack/tests/lisp-unit.lisp 2008/01/23 15:46:31 NONE +++ /project/rucksack/cvsroot/rucksack/tests/lisp-unit.lisp 2008/01/23 15:46:31 1.1 ;;;-*- Mode: Lisp; Package: LISP-UNIT -*- #| Copyright (c) 2004-2005 Christopher K. Riesbeck Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. |# ;;; A test suite package, modelled after JUnit. ;;; Author: Chris Riesbeck ;;; ;;; Update history: ;;; ;;; 04/07/06 added ~<...~> to remaining error output forms [CKR] ;;; 04/06/06 added ~<...~> to compact error output better [CKR] ;;; 04/06/06 fixed RUN-TESTS to get tests dynamically (bug reported ;;; by Daniel Edward Burke) [CKR] ;;; 02/08/06 added newlines to error output [CKR] ;;; 12/30/05 renamed ASSERT-PREDICATE to ASSERT-EQUALITY [CKR] ;;; 12/29/05 added ASSERT-EQ, ASSERT-EQL, ASSERT-EQUALP [CKR] ;;; 12/22/05 recoded use-debugger to use handler-bind, added option to prompt for debugger, ;;; 11/07/05 added *use-debugger* and assert-predicate [DFB] ;;; 09/18/05 replaced Academic Free License with MIT Licence [CKR] ;;; 08/30/05 added license notice [CKR] ;;; 06/28/05 changed RUN-TESTS to compile code at run time, not expand time [CKR] ;;; 02/21/05 removed length check from SET-EQUAL [CKR] ;;; 02/17/05 added RUN-ALL-TESTS [CKR] ;;; 01/18/05 added ASSERT-EQUAL back in [CKR] ;;; 01/17/05 much clean up, added WITH-TEST-LISTENER [CKR] ;;; 01/15/05 replaced ASSERT-EQUAL etc. with ASSERT-TRUE and ASSERT-FALSE [CKR] ;;; 01/04/05 changed COLLECT-RESULTS to echo output on *STANDARD-OUTPuT* [CKR] ;;; 01/04/05 added optional package argument to REMOVE-ALL-TESTS [CKR] ;;; 01/04/05 changed OUTPUT-OK-P to trim spaces and returns [CKR] ;;; 01/04/05 changed OUTPUT-OK-P to not check output except when asked to [CKR] ;;; 12/03/04 merged REMOVE-TEST into REMOVE-TESTS [CKR] ;;; 12/03/04 removed ability to pass forms to RUN-TESTS [CKR] ;;; 12/03/04 refactored RUN-TESTS expansion into RUN-TEST-THUNKS [CKR] ;;; 12/02/04 changed to group tests under packages [CKR] ;;; 11/30/04 changed assertions to put expected value first, like JUnit [CKR] ;;; 11/30/04 improved error handling and summarization [CKR] ;;; 11/30/04 generalized RUN-TESTS, removed RUN-TEST [CKR] ;;; 02/27/04 fixed ASSERT-PRINTS not ignoring value [CKR] ;;; 02/07/04 fixed ASSERT-EXPANDS failure message [CKR] ;;; 02/07/04 added ASSERT-NULL, ASSERT-NOT-NULL [CKR] ;;; 01/31/04 added error handling and totalling to RUN-TESTS [CKR] ;;; 01/31/04 made RUN-TEST/RUN-TESTS macros [CKR] ;;; 01/29/04 fixed ASSERT-EXPANDS quote bug [CKR] ;;; 01/28/04 major changes from BUG-FINDER to be more like JUnit [CKR] #| How to use ---------- 1. Read the documentation in lisp-unit.html. 2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many examples. If you want, start your test file with (REMOVE-TESTS) to clear any previously defined tests. 2. Load this file. 2. (use-package :lisp-unit) 3. Load your code file and your file of tests. 4. Test your code with (RUN-TESTS test-name1 test-name2 ...) -- no quotes! -- or simply (RUN-TESTS) to run all defined tests. A summary of how many tests passed and failed will be printed, with details on the failures. Note: Nothing is compiled until RUN-TESTS is expanded. Redefining functions or even macros does not require reloading any tests. For more information, see lisp-unit.html. |# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Packages ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cl:defpackage #:lisp-unit (:use #:common-lisp) (:export #:define-test #:run-all-tests #:run-tests #:assert-eq #:assert-eql #:assert-equal #:assert-equalp #:assert-error #:assert-expands #:assert-false #:assert-equality #:assert-prints #:assert-true #:get-test-code #:get-tests #:remove-all-tests #:remove-tests #:logically-equal #:set-equal #:use-debugger #:with-test-listener) ) (in-package #:lisp-unit) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *test-listener* nil) (defparameter *tests* (make-hash-table)) ;;; Used by RUN-TESTS to collect summary statistics (defvar *test-count* 0) (defvar *pass-count* 0) ;;; Set by RUN-TESTS for use by SHOW-FAILURE (defvar *test-name* nil) ;;; If nil, errors in tests are caught and counted. ;;; If :ask, user is given option of entering debugger or not. ;;; If true and not :ask, debugger is entered. (defparameter *use-debugger* nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Macros ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; DEFINE-TEST (defmacro define-test (name &body body) `(progn (store-test-code ',name ',body) ',name)) ;;; ASSERT macros (defmacro assert-eq (expected form &rest extras) (expand-assert :equal form form expected extras :test #'eq)) (defmacro assert-eql (expected form &rest extras) (expand-assert :equal form form expected extras :test #'eql)) (defmacro assert-equal (expected form &rest extras) (expand-assert :equal form form expected extras :test #'equal)) (defmacro assert-equalp (expected form &rest extras) (expand-assert :equal form form expected extras :test #'equalp)) (defmacro assert-error (condition form &rest extras) (expand-assert :error form (expand-error-form form) condition extras)) (defmacro assert-expands (&environment env expansion form &rest extras) #+lispworks(declare (ignore env)) (expand-assert :macro form (expand-macro-form form #+lispworks nil #-lispworks env) expansion extras)) (defmacro assert-false (form &rest extras) (expand-assert :result form form nil extras)) (defmacro assert-equality (test expected form &rest extras) (expand-assert :equal form form expected extras :test test)) (defmacro assert-prints (output form &rest extras) (expand-assert :output form (expand-output-form form) output extras)) (defmacro assert-true (form &rest extras) (expand-assert :result form form t extras)) (defun expand-assert (type form body expected extras &key (test #'eql)) `(internal-assert ,type ',form #'(lambda () ,body) #'(lambda () ,expected) ,(expand-extras extras), test)) (defun expand-error-form (form) `(handler-case ,form (condition (error) error))) (defun expand-output-form (form) (let ((out (gensym))) `(let* ((,out (make-string-output-stream)) (*standard-output* (make-broadcast-stream *standard-output* ,out))) ,form (get-output-stream-string ,out)))) (defun expand-macro-form (form env) `(macroexpand-1 ',form ,env)) (defun expand-extras (extras) `#'(lambda () (list ,@(mapcan #'(lambda (form) (list `',form form)) extras)))) ;;; RUN-TESTS (defmacro run-all-tests (package &rest tests) `(let ((*package* (find-package ',package))) (run-tests ,@(mapcar #'(lambda (test) (find-symbol (symbol-name test) package)) tests)))) (defmacro run-tests (&rest names) `(run-test-thunks (get-test-thunks ,(if (null names) '(get-tests *package*) `',names)))) (defun get-test-thunks (names &optional (package *package*)) (mapcar #'(lambda (name) (get-test-thunk name package)) names)) (defun get-test-thunk (name package) (assert (get-test-code name package) (name package) "No test defined for ~S in package ~S" name package) (list name (coerce `(lambda () ,@(get-test-code name)) 'function))) (defun use-debugger (&optional (flag t)) (setq *use-debugger* flag)) ;;; WITH-TEST-LISTENER (defmacro with-test-listener (listener &body body) `(let ((*test-listener* #',listener)) , at body)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Public functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun get-test-code (name &optional (package *package*)) (let ((table (get-package-table package))) (unless (null table) (gethash name table)))) (defun get-tests (&optional (package *package*)) (let ((l nil) (table (get-package-table package))) (cond ((null table) nil) (t (maphash #'(lambda (key val) (declare (ignore val)) (push key l)) table) (sort l #'string< :key #'string))))) (defun remove-tests (names &optional (package *package*)) (let ((table (get-package-table package))) (unless (null table) (if (null names) (clrhash table) (dolist (name names) (remhash name table)))))) (defun remove-all-tests (&optional (package *package*)) (if (null package) (clrhash *tests*) (remhash (find-package package) *tests*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Private functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; DEFINE-TEST support (defun get-package-table (package &key create) (let ((table (gethash (find-package package) *tests*))) (or table (and create (setf (gethash package *tests*) (make-hash-table)))))) (defun get-test-name (form) (if (atom form) form (cadr form))) (defun store-test-code (name code &optional (package *package*)) (setf (gethash name (get-package-table package :create t)) code)) ;;; ASSERTION support (defun internal-assert (type form code-thunk expected-thunk extras test) (let* ((expected (multiple-value-list (funcall expected-thunk))) (actual (multiple-value-list (funcall code-thunk))) (passed (test-passed-p type expected actual test))) (incf *test-count*) (when passed (incf *pass-count*)) (record-result passed type form expected actual extras) passed)) (defun record-result (passed type form expected actual extras) (funcall (or *test-listener* 'default-listener) passed type *test-name* form expected actual (and extras (funcall extras)) *test-count* *pass-count*)) (defun default-listener (passed type name form expected actual extras test-count pass-count) (declare (ignore test-count pass-count)) (unless passed (show-failure type (get-failure-message type) name form expected actual extras))) (defun test-passed-p (type expected actual test) (ecase type (:error (or (eql (car actual) (car expected)) (typep (car actual) (car expected)))) (:equal (and (<= (length expected) (length actual)) (every test expected actual))) (:macro (equal (car actual) (car expected))) (:output (string= (string-trim '(#\newline #\return #\space) (car actual)) (car expected))) (:result (logically-equal (car actual) (car expected))) )) ;;; RUN-TESTS support (defun run-test-thunks (test-thunks) (unless (null test-thunks) (let ((total-test-count 0) (total-pass-count 0) (total-error-count 0)) (dolist (test-thunk test-thunks) (multiple-value-bind (test-count pass-count error-count) (run-test-thunk (car test-thunk) (cadr test-thunk)) (incf total-test-count test-count) (incf total-pass-count pass-count) (incf total-error-count error-count))) (unless (null (cdr test-thunks)) (show-summary 'total total-test-count total-pass-count total-error-count)) (values)))) (defun run-test-thunk (*test-name* thunk) (if (null thunk) (format t "~& Test ~S not found" *test-name*) (prog ((*test-count* 0) (*pass-count* 0) (error-count 0)) (handler-bind ((error #'(lambda (e) (let ((*print-escape* nil)) (setq error-count 1) (format t "~& ~S: ~W" *test-name* e)) (if (use-debugger-p e) e (go exit))))) (funcall thunk) (show-summary *test-name* *test-count* *pass-count*)) exit (return (values *test-count* *pass-count* error-count))))) (defun use-debugger-p (e) (and *use-debugger* (or (not (eql *use-debugger* :ask)) (y-or-n-p "~A -- debug?" e)))) ;;; OUTPUT support (defun get-failure-message (type) (case type (:error "~&~@[Should have signalled ~{~S~^; ~} but saw~] ~{~S~^; ~}") (:macro "~&Should have expanded to ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") (:output "~&Should have printed ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") (t "~&Expected ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") )) (defun show-failure (type msg name form expected actual extras) (format t "~&~@[~S: ~]~S failed: " name form) (format t msg expected actual) (format t "~{~& ~S => ~S~}~%" extras) type) (defun show-summary (name test-count pass-count &optional error-count) (format t "~&~A: ~S assertions passed, ~S failed~@[, ~S execution errors~]." name pass-count (- test-count pass-count) error-count)) (defun collect-form-values (form values) [30 lines skipped] --- /project/rucksack/cvsroot/rucksack/tests/package.lisp 2008/01/23 15:46:31 NONE +++ /project/rucksack/cvsroot/rucksack/tests/package.lisp 2008/01/23 15:46:31 1.1 [40 lines skipped] --- /project/rucksack/cvsroot/rucksack/tests/regression-1.lisp 2008/01/23 15:46:31 NONE +++ /project/rucksack/cvsroot/rucksack/tests/regression-1.lisp 2008/01/23 15:46:31 1.1 [78 lines skipped] --- /project/rucksack/cvsroot/rucksack/tests/rucksack-test.asd 2008/01/23 15:46:31 NONE +++ /project/rucksack/cvsroot/rucksack/tests/rucksack-test.asd 2008/01/23 15:46:31 1.1 [87 lines skipped] --- /project/rucksack/cvsroot/rucksack/tests/unit-tests.lisp 2008/01/23 15:46:31 NONE +++ /project/rucksack/cvsroot/rucksack/tests/unit-tests.lisp 2008/01/23 15:46:31 1.1 [335 lines skipped] From alemmens at common-lisp.net Wed Jan 23 15:49:07 2008 From: alemmens at common-lisp.net (alemmens) Date: Wed, 23 Jan 2008 10:49:07 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack/tests Message-ID: <20080123154907.CD529690E2@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack/tests In directory clnet:/tmp/cvs-serv2612/tests Added Files: test-index-1a.lisp test-index-1b.lisp test-schema-update-1a.lisp test-schema-update-1b.lisp test-schema-update-1c.lisp test.lisp Log Message: Move all test files to the new tests directory. --- /project/rucksack/cvsroot/rucksack/tests/test-index-1a.lisp 2008/01/23 15:49:07 NONE +++ /project/rucksack/cvsroot/rucksack/tests/test-index-1a.lisp 2008/01/23 15:49:07 1.1 ;; $Id: test-index-1a.lisp,v 1.1 2008/01/23 15:49:07 alemmens Exp $ (in-package :rucksack-test) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Indexing example ;;; ;;; To run this example: ;;; - compile and load this file ;;; - (IN-PACKAGE :RUCKSACK-TEST) ;;; - (CREATE-HACKERS) ;;; - (SHOW-HACKERS) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *hackers* '("David" "Jim" "Peter" "Thomas" "Arthur" "Jans" "Klaus" "James" "Martin")) (defun random-elt (list) (elt list (random (length list)))) (eval-when (:compile-toplevel :load-toplevel :execute) ;; NOTE: The EVAL-WHEN above is necessary to ensure that the compiler ;; 'knows about' the HACKER class when it compiles the PRINT-OBJECT method ;; for HACKER. We could avoid this by splitting this file into two: ;; the first one would contain the class definitions, and the second ;; would contain everything else (especially methods that specialize on one ;; of the classes defined in the first one). (defparameter *hacker-rucksack* #p"/tmp/rucksack/hackers/") (with-rucksack (rs *hacker-rucksack* :if-exists :supersede) (with-transaction () ;; We define some persistent classes with indexed slots. ;; So we must wrap the class definition in a WITH-RUCKSACK, ;; otherwise the indexes can't be built. (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)) (: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) (format stream "~S called ~S" (hacker-id hacker) (name hacker)))) (defun create-hackers () (with-rucksack (rs *hacker-rucksack*) ;; Fill the rucksack with some hackers. (with-transaction () (loop repeat 20 do (make-instance 'hacker)) (loop repeat 10 do (make-instance 'lisp-hacker)) (rucksack-map-class rs 'hacker #'print)))) (defun show-hackers () (with-rucksack (rs *hacker-rucksack*) (with-transaction () (print "Hackers indexed by object id.") (rucksack-map-class rs 'hacker #'print) (print "Hackers indexed by name.") (rucksack-map-slot rs 'hacker 'name #'print) (print "Hackers indexed by hacker-id.") (rucksack-map-slot rs 'hacker 'id #'print) (print "Lisp hackers.") (rucksack-map-class rs 'lisp-hacker #'print) (print "Non-lisp hackers.") (rucksack-map-class rs 'hacker #'print :include-subclasses nil) (print "Hacker object ids.") (rucksack-map-class rs 'hacker #'print :id-only t)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Example output ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #| RS-TEST 3 > (create-hackers) # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # NIL T RS-TEST 4 > (show-hackers) "Hackers indexed by object id." # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # "Hackers indexed by name." # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # "Hackers indexed by hacker-id." # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # "Lisp hackers." # # # # # # # # # # "Non-lisp hackers." # # # # # # # # # # # # # # # # # # # # "Hacker object ids." 36 65 69 73 78 83 88 92 96 100 104 109 113 117 122 126 130 135 139 144 148 160 164 168 173 177 181 185 189 193 NIL T |# --- /project/rucksack/cvsroot/rucksack/tests/test-index-1b.lisp 2008/01/23 15:49:07 NONE +++ /project/rucksack/cvsroot/rucksack/tests/test-index-1b.lisp 2008/01/23 15:49:07 1.1 ;; $Id: test-index-1b.lisp,v 1.1 2008/01/23 15:49:07 alemmens Exp $ (in-package :rs-test) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Class redefinition example ;;; ;;; To run this example: ;;; - First run the indexing example in test-index-1a.lisp. ;;; - Compile and load this file ;;; This will change the class definition of HACKER. ;;; Because of this change, Rucksack will remove some slot indexes and ;;; create (and fill) other slot indexes. ;;; - (SHOW-HACKERS) ;;; Notice that "Hackers indexed by hacker-id." now doesn't list any hackers, ;;; because the ID index was removed. ;;; - (SHOW-HACKERS-BY-AGE) ;;; This will print the hackers sorted by age. It shows that: ;;; (1) the existing hackers all got a new age slot, initialized by ;;; UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS to a random ;;; number according to their initform ;;; (2) a new index has been created for the new age slot ;;; (3) the index has been filled with the new values for the age slot. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-rucksack (rs *hacker-rucksack*) (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 schemas and indexes are updated correctly. ;; In this case we redefine the HACKER class: we remove the index for ;; the ID slot, and we add a new AGE slot (with an index). (defclass hacker () ((id :initform (gensym "HACKER-") :reader hacker-id) (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)))) (defun show-hackers-by-age () (with-rucksack (rs *hacker-rucksack*) (with-transaction () (print "Hackers by age.") (rucksack-map-slot rs 'hacker 'age (lambda (hacker) (format t "~&~A has age ~D.~%" (name hacker) (age hacker))))))) --- /project/rucksack/cvsroot/rucksack/tests/test-schema-update-1a.lisp 2008/01/23 15:49:07 NONE +++ /project/rucksack/cvsroot/rucksack/tests/test-schema-update-1a.lisp 2008/01/23 15:49:07 1.1 ;; $Id: test-schema-update-1a.lisp,v 1.1 2008/01/23 15:49:07 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, evaluate: ;;; - (in-package :rucksack-test-schema-update) ;;; - (test-1) ;;; ;;; Then move on to 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 (rs *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)))) (defun test-1 () ;; Create some persons. (with-rucksack (rs *dir*) (with-transaction () [25 lines skipped] --- /project/rucksack/cvsroot/rucksack/tests/test-schema-update-1b.lisp 2008/01/23 15:49:07 NONE +++ /project/rucksack/cvsroot/rucksack/tests/test-schema-update-1b.lisp 2008/01/23 15:49:07 1.1 [131 lines skipped] --- /project/rucksack/cvsroot/rucksack/tests/test-schema-update-1c.lisp 2008/01/23 15:49:07 NONE +++ /project/rucksack/cvsroot/rucksack/tests/test-schema-update-1c.lisp 2008/01/23 15:49:07 1.1 [301 lines skipped] --- /project/rucksack/cvsroot/rucksack/tests/test.lisp 2008/01/23 15:49:07 NONE +++ /project/rucksack/cvsroot/rucksack/tests/test.lisp 2008/01/23 15:49:07 1.1 [735 lines skipped] From alemmens at common-lisp.net Wed Jan 23 15:49:08 2008 From: alemmens at common-lisp.net (alemmens) Date: Wed, 23 Jan 2008 10:49:08 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20080123154908.87D1181004@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv2612 Removed Files: test-index-1a.lisp test-index-1b.lisp test-schema-update-1a.lisp test-schema-update-1b.lisp test-schema-update-1c.lisp test.lisp Log Message: Move all test files to the new tests directory. From alemmens at common-lisp.net Thu Jan 24 12:38:52 2008 From: alemmens at common-lisp.net (alemmens) Date: Thu, 24 Jan 2008 07:38:52 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20080124123852.612972F053@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv24416 Modified Files: manual.txt Log Message: Simplify 'getting started' instructions (suggested by Edi Weitz). --- /project/rucksack/cvsroot/rucksack/manual.txt 2008/01/23 15:45:03 1.1 +++ /project/rucksack/cvsroot/rucksack/manual.txt 2008/01/24 12:38:52 1.2 @@ -5,11 +5,11 @@ 1. Make sure you have ASDF (Another System Definition Facility) loaded. -2. Compile and load rucksack.asd. +2. Load rucksack.asd. -3. Compile and load tests/rucksack-test.asd. +3. Load tests/rucksack-test.asd. -4. (asdf:oos 'asdf:load-op :rucksack-test :force t) +4. (asdf:oos 'asdf:load-op :rucksack-test) 5. (in-package :rucksack-test) From alemmens at common-lisp.net Thu Jan 24 12:39:45 2008 From: alemmens at common-lisp.net (alemmens) Date: Thu, 24 Jan 2008 07:39:45 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack/tests Message-ID: <20080124123945.3EF602F061@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack/tests In directory clnet:/tmp/cvs-serv24508 Modified Files: unit-tests.lisp Log Message: Add a test to verify that throwing an error inside a with-transaction form causes a transaction rollback. --- /project/rucksack/cvsroot/rucksack/tests/unit-tests.lisp 2008/01/23 15:46:31 1.1 +++ /project/rucksack/cvsroot/rucksack/tests/unit-tests.lisp 2008/01/24 12:39:45 1.2 @@ -244,5 +244,18 @@ (abort))) (with-rucksack-and-transaction () (let ((pc (car (rucksack-roots rs)))) + (assert-equal 1 (p-car pc)))) + ;; Test that transactions are also rolled back when we throw an + ;; error inside the body of a WITH-TRANSACTION form. + (assert-error 'error + (with-rucksack-and-transaction () + (let ((pc (first (rucksack-roots rs)))) + (setf (p-car pc) 5) + ;; Abort the transaction by causing an error. + (error "Something went wrong")))) + (with-rucksack-and-transaction () + ;; Verify that the error caused a transaction rollback. + (let ((pc (car (rucksack-roots rs)))) (assert-equal 1 (p-car pc))))) + From alemmens at common-lisp.net Thu Jan 31 13:03:43 2008 From: alemmens at common-lisp.net (alemmens) Date: Thu, 31 Jan 2008 08:03:43 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20080131130343.5A2C44C005@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv15987 Modified Files: import-export.lisp Log Message: Change DEFGENERIC IMPORT-RUCKSACK to DEFUN IMPORT-RUCKSACK to fix a compiler warning reported by Brad Beveridge. --- /project/rucksack/cvsroot/rucksack/import-export.lisp 2008/01/23 15:45:03 1.1 +++ /project/rucksack/cvsroot/rucksack/import-export.lisp 2008/01/31 13:03:39 1.2 @@ -23,12 +23,15 @@ (:documentation "Export all objects in a rucksack to a file. The resulting file can be imported by newer versions of Rucksack.")) -(defgeneric import-rucksack (pathname directory-designator - &rest args - &key (if-exists :error) - &allow-other-keys) - (:documentation "Creates a new rucksack in the directory specified by +(defun import-rucksack (pathname directory-designator + &rest args + &key (if-exists :error) + &allow-other-keys) + "Creates a new rucksack in the directory specified by DIRECTORY-DESIGNATOR, opens the new rucksack and imports all objects -that were exported to the file specified by PATHNAME.")) +that were exported to the file specified by PATHNAME." + (declare (ignore pathname directory-designator if-exists args)) + (error "Not implemented yet")) + From alemmens at common-lisp.net Thu Jan 31 20:26:09 2008 From: alemmens at common-lisp.net (alemmens) Date: Thu, 31 Jan 2008 15:26:09 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20080131202609.2E517461B1@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv25326 Modified Files: cache.lisp done.txt rucksack.asd rucksack.lisp Log Message: Version 0.1.14. Class and slot indexes now map directly to objects instead of object-ids. This fixes a bug where the garbage collector forgot to add all indexed objects to the root set. (Suggested by Sean Ross.) Increased default cache size to 100,000 objects. --- /project/rucksack/cvsroot/rucksack/cache.lisp 2007/01/20 18:17:55 1.12 +++ /project/rucksack/cvsroot/rucksack/cache.lisp 2008/01/31 20:26:08 1.13 @@ -1,4 +1,4 @@ -;; $Id: cache.lisp,v 1.12 2007/01/20 18:17:55 alemmens Exp $ +;; $Id: cache.lisp,v 1.13 2008/01/31 20:26:08 alemmens Exp $ (in-package :rucksack) @@ -183,7 +183,7 @@ (heap-options '()) (if-exists :overwrite) (if-does-not-exist :create) - (size 10000) + (size 100000) &allow-other-keys) (ensure-directories-exist directory) (let ((object-table (open-object-table (merge-pathnames "objects" directory) --- /project/rucksack/cvsroot/rucksack/done.txt 2008/01/23 15:43:42 1.14 +++ /project/rucksack/cvsroot/rucksack/done.txt 2008/01/31 20:26:08 1.15 @@ -1,3 +1,14 @@ +* 2008-01-31 - version 0.1.14 + +- Class and slot indexes now map directly to objects instead of + object-ids. This fixes a bug where the garbage collector forgot + to add all indexed objects to the root set. (Suggested by Sean + Ross.) + +- Increase default cache size to 100,000 objects. + + + * 2008-01-23 - version 0.1.13 - Add Brad Beveridge's basic unit test suite (modified to work --- /project/rucksack/cvsroot/rucksack/rucksack.asd 2008/01/23 15:43:42 1.15 +++ /project/rucksack/cvsroot/rucksack/rucksack.asd 2008/01/31 20:26:08 1.16 @@ -1,9 +1,9 @@ -;;; $Id: rucksack.asd,v 1.15 2008/01/23 15:43:42 alemmens Exp $ +;;; $Id: rucksack.asd,v 1.16 2008/01/31 20:26:08 alemmens Exp $ (in-package :cl-user) (asdf:defsystem :rucksack - :version "0.1.13" + :version "0.1.14" :serial t :components ((:file "queue") (:file "package") --- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2008/01/22 15:59:24 1.22 +++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2008/01/31 20:26:08 1.23 @@ -1,4 +1,4 @@ -;; $Id: rucksack.lisp,v 1.22 2008/01/22 15:59:24 alemmens Exp $ +;; $Id: rucksack.lisp,v 1.23 2008/01/31 20:26:08 alemmens Exp $ (in-package :rucksack) @@ -156,7 +156,7 @@ (defgeneric rucksack-map-slot (rucksack class slot function &key equal min max include-min include-max order - id-only include-subclasses) + include-subclasses) (:documentation " FUNCTION is a unary function that gets called for all instances of the specified class that have a slot value matching the EQUAL, MIN, @@ -304,13 +304,13 @@ (roots-changed-p :initform nil :accessor roots-changed-p) ;; Indexes (class-index-table :documentation - "A btree mapping class names to class indexes. Each class index -contains the ids of all instances from a class; technically speaking, -it maps object ids to themselves.") + "The object id of a btree mapping class names to class indexes. Each +class index contains the ids of all instances from a class; it maps +object ids to objects.") (slot-index-tables :documentation - "A btree mapping class names to slot index tables, where each slot -index table is a btree mapping slot names to slot indexes. Each slot -index maps slot values to object ids."))) + "The object id of a btree mapping class names to slot index tables, +where each slot index table is a btree mapping slot names to slot +indexes. Each slot index maps slot values to objects."))) (defmethod print-object ((rucksack rucksack) stream) (print-unreadable-object (rucksack stream :type t :identity t) @@ -326,6 +326,8 @@ ;; Create class-index-table if it doesn't exist yet. (flet ((do-it () (unless (slot-boundp rucksack 'class-index-table) + ;; Create a btree mapping class names to class + ;; indexes. (let ((btree (make-instance 'btree :rucksack rucksack :key< 'string< @@ -345,7 +347,9 @@ (defmethod slot-index-tables ((rucksack standard-rucksack)) ;; Create slot-index-tables if they don't exist yet. (flet ((do-it () - (unless (slot-boundp rucksack 'slot-index-tables) + (unless (slot-boundp rucksack 'slot-index-tables) + ;; Create a btree mapping class names to slot + ;; index tables. (let ((btree (make-instance 'btree :rucksack rucksack :key< 'string< @@ -380,7 +384,7 @@ (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. + ;; Also load the (object ids of the) class and slot index tables. (let ((roots-file (rucksack-roots-pathname rucksack))) (when (probe-file roots-file) (destructuring-bind (root-list class-index slot-index) @@ -449,8 +453,10 @@ &rest args &key (class 'serial-transaction-rucksack) - (if-exists :overwrite) (if-does-not-exist :create) - (cache-class 'standard-cache) (cache-args '()) + (if-exists :overwrite) + (if-does-not-exist :create) + (cache-class 'standard-cache) + (cache-args '()) &allow-other-keys) "Opens the rucksack in the directory designated by DIRECTORY-DESIGNATOR. :IF-DOES-NOT-EXIST can be either :CREATE (creates a new rucksack if the @@ -620,7 +626,7 @@ (lambda (object) (when (slot-boundp object slot-name) (index-insert index (slot-value object slot-name) - (object-id object)))))))) + object))))))) (defun replace-slot-index (rucksack class slot index-spec unique-p) @@ -639,8 +645,8 @@ ;; 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))) + (lambda (slot-value object) + (index-insert new-index slot-value object))) ;; We don't need to remove the old index explicitly, because ;; RUCKSACK-ADD-SLOT-INDEX already did that for us. )) @@ -691,6 +697,7 @@ (defmethod rucksack-add-class-index ((rucksack standard-rucksack) class &key (errorp nil)) + ;; Create and add a class index to the class index table. (unless (symbolp class) (setq class (class-name class))) (when (and errorp (btree-search (class-index-table rucksack) class @@ -750,24 +757,25 @@ class object) (let ((index (rucksack-class-index rucksack class :errorp nil))) (when index - (index-insert index (object-id object) (object-id object) + (index-insert index (object-id object) object :if-exists :error)))) (defmethod rucksack-map-class ((rucksack standard-rucksack) class function &key (id-only nil) (include-subclasses t)) - (let ((visited-p (make-hash-table)) - (cache (rucksack-cache rucksack))) + ;; EFFICIENCY: Follow Sean Ross' suggestion and implement ID-ONLY + ;; by defining a function MAP-INDEX-KEYS and then calling + ;; that function here (so that we don't need to load any objects + ;; that we don't want to load yet). + (let ((visited-p (make-hash-table))) (labels ((map-instances (class) (let ((index (rucksack-class-index rucksack class :errorp nil))) (when index (map-index index - (lambda (id ignore) - (declare (ignore ignore)) - (funcall function - (if id-only - id - (cache-get-object id cache))))) + (lambda (id object) + (if id-only + (funcall function id) + (funcall function object)))) (setf (gethash class visited-p) t)) (when include-subclasses (loop for class in (class-direct-subclasses @@ -805,7 +813,7 @@ (lambda (error) (declare (ignore error)) (simple-rucksack-error "Slot index for slot ~S of class ~S -already exists in ~A." +already exists in ~S." slot class rucksack)))) @@ -822,7 +830,7 @@ (flet ((oops (error) (declare (ignore error)) (simple-rucksack-error "Attempt to remove non-existing slot -index for slot ~S of class ~S in ~A." +index for slot ~S of class ~S in ~S." slot class rucksack))) @@ -873,15 +881,14 @@ :errorp nil :include-superclasses t))) (when index - (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 - :if-exists (if (slot-unique slot) - :error - :overwrite))))))) + (when old-boundp + (index-delete index old-value object + :if-does-not-exist :ignore)) + (when new-boundp + (index-insert index new-value object + :if-exists (if (slot-unique slot) + :error + :overwrite)))))) (defmethod rucksack-slot-index ((rucksack standard-rucksack) class slot @@ -902,7 +909,7 @@ thereis (find-index (class-name superclass)))) (and errorp (simple-rucksack-error - "Can't find slot index for slot ~S of class ~S in ~A." + "Can't find slot index for slot ~S of class ~S in ~S." slot class rucksack)))))) @@ -911,23 +918,18 @@ (defmethod rucksack-map-slot ((rucksack standard-rucksack) class slot function &key min max include-min include-max (equal nil equal-supplied) - (order :ascending) - (id-only nil) (include-subclasses t)) - (let ((cache (rucksack-cache rucksack)) - (visited-p (make-hash-table))) + (order :ascending) (include-subclasses t)) + (let ((visited-p (make-hash-table))) (labels ((map-slot (class) (let ((index (rucksack-slot-index rucksack class slot :errorp nil))) (when index - ;; The index maps slot values to object ids. + ;; The index maps slot values to objects. (apply #'map-index index - (lambda (slot-value object-id) + (lambda (slot-value object) (declare (ignore slot-value)) - (if id-only - (funcall function object-id) - (funcall function - (cache-get-object object-id cache)))) + (funcall function object)) :min min :max max :include-min include-min @@ -986,20 +988,19 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod rucksack-delete-object ((rucksack standard-rucksack) object) - (let ((object-id (object-id object)) - (class-name (class-name (class-of object)))) + (let ((class-name (class-name (class-of object)))) ;; Remove object from class index if necessary. (let ((class-index (rucksack-class-index rucksack (class-of object) :errorp nil))) (when class-index - (index-delete class-index object-id object-id))) + (index-delete class-index (object-id object) object))) ;; Remove object from slot indexes if necessary. (let ((indexed-slot-names (rucksack-indexed-slots-for-class rucksack (class-of object)))) (loop for slot-name in indexed-slot-names do (index-delete (rucksack-slot-index rucksack class-name slot-name) (slot-value object slot-name) - object-id + object :if-does-not-exist :ignore))) ;; Remove object from roots if necessary. (when (rucksack-root-p object rucksack)