[bknr-cvs] hans changed trunk/bknr/datastore/src/

[BKNR Commits]

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))