Revision: 3950 Author: hans URL: http://bknr.net/trac/changeset/3950 Make it possible to restore datastores when packages have been deleted which are referenced by objects in the store. U trunk/bknr/datastore/src/data/encoding.lisp U trunk/bknr/datastore/src/data/object-tests.lisp U trunk/bknr/datastore/src/data/object.lisp U trunk/bknr/datastore/src/indices/indices.lisp Modified: trunk/bknr/datastore/src/data/encoding.lisp =================================================================== --- trunk/bknr/datastore/src/data/encoding.lisp 2008-09-23 19:26:10 UTC (rev 3949) +++ trunk/bknr/datastore/src/data/encoding.lisp 2008-09-23 19:27:58 UTC (rev 3950) @@ -355,12 +355,42 @@ (assert (= n (read-sequence buffer stream))) (octets-to-string buffer)))) -(defun %decode-symbol (stream) - (let ((p (%decode-string stream)) - (n (%decode-string stream))) - (intern n (or (find-package p) - (error "package ~A for symbol ~A not found" p n))))) +(defun find-symbol-in-all-packages (name) + (let (symbols) + (do-all-symbols (symbol symbols) + (when (string-equal symbol name) + (pushnew symbol symbols))))) +(defun find-symbol-interactively (package-name symbol-name usage) + (let ((keyword (string-equal package-name "KEYWORD"))) + (restart-case + (multiple-value-bind (symbol status) + (funcall (if keyword + #'intern + #'find-symbol) + symbol-name + (or (find-package package-name) + (error "package ~A for symbol ~A~@[ naming ~A~] not found" package-name symbol-name usage))) + (if (or keyword status) + symbol + (error "symbol ~A~@[ naming ~A~] not found in package ~A" symbol-name usage package-name))) + (use-other-symbol (new-symbol) + :interactive (lambda () + (format t "Enter symbol~@[ (homonyms: ~{~S~^, ~})~]: " (find-symbol-in-all-packages symbol-name)) + (let ((new-symbol (ignore-errors (read)))) + (list new-symbol))) + :report (lambda (stream) (format stream "Use another symbol~@[, homonyms: ~S~]" (find-symbol-in-all-packages symbol-name))) + new-symbol) + (read-as-nil () + :report "Read symbol as NIL" + nil)))) + +(defun %decode-symbol (stream &key (intern t) usage) + (let ((package-name (%decode-string stream)) + (symbol-name (%decode-string stream))) + (when intern + (find-symbol-interactively package-name symbol-name usage)))) + (defun %decode-list (stream) (let* ((n (%decode-integer stream)) (result (loop repeat n collect (decode stream))) @@ -370,7 +400,7 @@ result)) (defun %decode-hash-table (stream) - (let* ((test (%decode-symbol stream)) + (let* ((test (%decode-symbol stream :usage "hash table test")) (rehash-size (%decode-double-float stream)) (n (%decode-integer stream)) (result (make-hash-table :test test :size n :rehash-size rehash-size))) @@ -408,7 +438,7 @@ (%decode-uint32 stream))) (defun %decode-array (stream) - (let* ((element-type (%decode-symbol stream)) + (let* ((element-type (%decode-symbol stream :usage "array element type")) (flags (read-byte stream)) (vectorp (logbitp 0 flags)) (adjustablep (logbitp 1 flags)) Modified: trunk/bknr/datastore/src/data/object-tests.lisp =================================================================== --- trunk/bknr/datastore/src/data/object-tests.lisp 2008-09-23 19:26:10 UTC (rev 3949) +++ trunk/bknr/datastore/src/data/object-tests.lisp 2008-09-23 19:27:58 UTC (rev 3950) @@ -278,9 +278,7 @@ (test-equal o1 (parent-child o2)))) (defdstest abort-anonymous-transaction () - (let (parent) - (with-transaction (:initial) - (setf parent (make-instance 'parent :child nil))) + (let ((parent (make-instance 'parent :child nil))) (ignore-errors (with-transaction (:abort) (setf (parent-child parent) (make-instance 'child)) Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-09-23 19:26:10 UTC (rev 3949) +++ trunk/bknr/datastore/src/data/object.lisp 2008-09-23 19:27:58 UTC (rev 3950) @@ -459,10 +459,12 @@ (defun snapshot-read-layout (stream layouts) (let* ((id (%decode-integer stream)) - (class-name (%decode-symbol stream)) + (class-name (%decode-symbol stream :usage "class")) (nslots (%decode-integer stream)) (class (find-class-with-interactive-renaming class-name)) - (slot-names (loop repeat nslots collect (%decode-symbol stream))) + (slot-names (loop repeat nslots collect (%decode-symbol stream + :intern (not (null class)) + :usage "slot"))) (slots (if class (find-class-slots-with-interactive-renaming class slot-names) slot-names))) Modified: trunk/bknr/datastore/src/indices/indices.lisp =================================================================== --- trunk/bknr/datastore/src/indices/indices.lisp 2008-09-23 19:26:10 UTC (rev 3949) +++ trunk/bknr/datastore/src/indices/indices.lisp 2008-09-23 19:27:58 UTC (rev 3950) @@ -295,7 +295,7 @@ (defmethod index-values ((index array-index)) (error "An ARRAY-INDEX cannot enumerate its values.")) -(defmethod index-mapvalues ((index array-index) fun) +(defmethod index-mapvalues ((index array-index) (fun function)) (error "An ARRAY-INDEX cannot enumerate its values.")) (defmethod index-reinitialize ((new-index array-index) (old-index array-index))