Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv4595/src/elephant
Modified Files: classindex.lisp controller.lisp package.lisp serializer1.lisp serializer2.lisp Log Message: Fix to map-index test; a tweaked version of Robert's symbol/pakage conversion diff and misc changes to serializer
--- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/20 20:03:45 1.20 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/21 04:47:42 1.21 @@ -164,13 +164,15 @@ (defmethod close-controller :before ((sc store-controller)) "Ensure the classes don't have stale references to closed stores!" (when (controller-class-root sc) - (with-transaction (:store-controller sc :txn-sync t :retries 2) - (map-btree (lambda (class-name index) - (declare (ignore index)) - (let ((class (find-class class-name nil))) - (when class - (setf (%index-cache class) nil)))) - (controller-class-root sc))))) + (handler-case + (with-transaction (:store-controller sc :txn-sync t :retries 2) + (map-btree (lambda (class-name index) + (declare (ignore index)) + (let ((class (find-class class-name nil))) + (when class + (setf (%index-cache class) nil)))) + (controller-class-root sc))) + (t (e) (warn "Unable to clear class index caches ~A" e)))))
;; ============================= --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/16 23:02:53 1.35 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/21 04:47:42 1.36 @@ -153,8 +153,7 @@ (let ((obj (get-cache oid (instance-cache sc)))) (if obj obj ;; Should get cached since make-instance calls cache-instance - (make-instance (handle-legacy-classes class-name nil) - :from-oid oid :sc sc)))) + (make-instance class-name :from-oid oid :sc sc))))
(defmethod flush-instance-cache ((sc store-controller)) "Reset the instance cache (flush object lookups). Useful @@ -253,30 +252,69 @@ ;; Handling package changes in legacy databases ;;
-(defparameter *legacy-conversions-db* - '(;; 0.5.0 support +(defvar *always-convert* nil) + +(defparameter *legacy-symbol-conversions* + '(;; 0.5.0 support (("elephant" . "bdb-btree") . ("sleepycat" . "bdb-btree")) (("elephant" . "bdb-indexed-btree") . ("sleepycat" . "bdb-indexed-btree")) - (("elephant" . "bdb-btree-index") . ("sleepycat" . "bdb-btree-index")) - ;; 0.6.0 support - (("sleepycat" . "bdb-btree") . ("db-bdb" . "bdb-btree")) - (("sleepycat" . "bdb-indexed-btree") . ("db-bdb" . "bdb-indexed-btree")) - (("sleepycat" . "bdb-btree-index") . ("db-bdb" . "bdb-btree-index")))) - - -(defun handle-legacy-classes (name version) - (declare (ignore version)) - (let ((entry (assoc (symbol->string-pair name) *legacy-conversions-db* :test #'equal))) + (("elephant" . "bdb-btree-index") . ("sleepycat" . "bdb-btree-index")))) + +(defun add-symbol-conversion (old-name old-package new-name new-package old-version) + "Users can specify specific symbol conversions on upgrade prior to + migrating old databases" + (declare (ignore old-version)) + (push (cons (cons old-name old-package) (cons new-name new-package)) *legacy-symbol-conversions*)) + +(defun map-legacy-symbols (symbol-string package-string old-version) + (declare (ignore old-version)) + (let ((entry (assoc (cons (string-upcase symbol-string) (string-upcase package-string)) + *legacy-symbol-conversions* :test #'equal))) (if entry - (string-pair->symbol (cdr entry)) - name))) + (values t (cadr entry) (cddr entry)) + nil)))
-(defun symbol->string-pair (name) - (cons (string-downcase (package-name (symbol-package name))) - (string-downcase (symbol-name name))))
-(defun string-pair->symbol (name) - (intern (string-upcase (cdr name)) (car name))) +(defparameter *legacy-package-conversions* + '(("ELEPHANT-CLSQL" . "DB-CLSQL") + ("SLEEPYCAT" . "DB-BDB"))) + +(defun add-package-conversion (old-package-string new-package-string old-version) + "Users can specify wholesale package name conversions on upgrade + prior to migrating old databases" + (declare (ignore old-version)) + (push (cons old-package-string new-package-string) *legacy-package-conversions*)) + +(defun map-legacy-package-names (package-string old-version) + (declare (ignore old-version)) + (let ((entry (assoc (string-upcase package-string) *legacy-package-conversions* :test #'equal))) + (if entry + (cdr entry) + package-string))) + +(defun map-legacy-names (symbol-name package-name old-version) + (multiple-value-bind (mapped? new-name new-package) + (map-legacy-symbols symbol-name package-name old-version) + (if mapped? + (values new-name new-package) + (values new-name (map-legacy-package-names package-name old-version))))) + +(defun translate-and-intern-symbol (symbol-name package-name db-version) + "Service for the serializer to translate any renamed packages or symbols + and then intern the decoded symbol." + (if package-name + (multiple-value-bind (sname pname) + (if (or *always-convert* (not (equal db-version *elephant-code-version*))) + (map-legacy-names symbol-name package-name db-version) + (values symbol-name package-name)) + (let ((package (find-package pname))) + (if package + (intern sname package) + (progn + (warn "Couldn't deserialize the package: ~A based on ~A~% + An uninterred symbol will be created" pname package-name) + (make-symbol sname))))) + (make-symbol symbol-name)))
;; ================================================================================ ;; --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/20 19:12:58 1.15 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/21 04:47:42 1.16 @@ -61,8 +61,9 @@ #:btree-index #:get-primary-key #:primary #:key-form #:key-fn
- #:btree-differ - #:migrate #:*inhibit-slot-copy* + #:migrate #:*inhibit-slot-copy* + #:add-symbol-conversion #:add-package-conversion + #:*always-convert*
#:lookup-persistent-symbol #:lookup-persistent-symbol-id --- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/16 23:02:53 1.9 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/21 04:47:42 1.10 @@ -33,7 +33,9 @@ oid int-byte-spec array-type-from-byte - byte-from-array-type)) + byte-from-array-type + database-version + translate-and-intern-symbol))
(in-package :elephant-serializer1)
@@ -345,24 +347,17 @@ ((= tag +ucs1-symbol+) (let ((name (buffer-read-ucs1-string bs (buffer-read-fixnum bs))) (maybe-package-name (%deserialize bs))) - (if maybe-package-name - (intern name (find-package maybe-package-name)) - (make-symbol name)))) + (translate-and-intern-symbol name maybe-package-name (database-version sc)))) #+(or lispworks (and allegro ics)) ((= tag +ucs2-symbol+) (let ((name (buffer-read-ucs2-string bs (buffer-read-fixnum bs))) (maybe-package-name (%deserialize bs))) - (if maybe-package-name - (intern name (find-package maybe-package-name)) - (make-symbol name)))) + (translate-and-intern-symbol name maybe-package-name (database-version sc)))) #+(and sbcl sb-unicode) ((= tag +ucs4-symbol+) (let ((name (buffer-read-ucs4-string bs (buffer-read-fixnum bs))) (maybe-package-name (%deserialize bs))) -;; (format t "ouput name = ~A~%" name) - (if maybe-package-name - (intern name (find-package maybe-package-name)) - (make-symbol name)))) + (translate-and-intern-symbol name maybe-package-name (database-version sc)))) ((= tag +ucs1-string+) (buffer-read-ucs1-string bs (buffer-read-fixnum bs))) #+(or lispworks (and allegro ics)) --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/17 16:48:17 1.25 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/21 04:47:42 1.26 @@ -32,7 +32,9 @@ oid int-byte-spec array-type-from-byte - byte-from-array-type)) + byte-from-array-type + database-version + translate-and-intern-symbol))
(in-package :elephant-serializer2)
@@ -164,7 +166,7 @@ ((%next-object-id () (incf lisp-obj-id)) (%serialize (frob) - (etypecase frob + (typecase frob (fixnum (if (< #.most-positive-fixnum +2^31+) ;; should be compiled away (progn @@ -306,10 +308,10 @@ (loop for i fixnum from 0 below (array-total-size frob) do (%serialize (row-major-aref frob i))))))) - ))) - (%serialize frob) - (release-circularity-hash circularity-hash) - bs))) + (t (format t "Can't serialize a object: ~A of type ~A~%" frob (type-of frob)))))) + (%serialize frob) + (release-circularity-hash circularity-hash) + bs)))
(defun serialize-bignum (frob bs) "Serialize bignum to buffer stream" @@ -418,10 +420,7 @@ ((= tag +symbol+) (let ((name (%deserialize bs)) (package (%deserialize bs))) - (declare (dynamic-extent name package)) - (if package - (intern name (find-package package)) - (make-symbol name)))) + (translate-and-intern-symbol name package (database-version sc)))) ((= tag +persistent+) (get-cached-instance sc (buffer-read-fixnum32 bs) @@ -444,8 +443,7 @@ ((= tag +cons+) (let* ((id (buffer-read-fixnum bs)) (maybe-cons (lookup-id id))) - (declare (dynamic-extent id maybe-cons) - (type fixnum id)) + (declare (type fixnum id)) (if maybe-cons maybe-cons (let ((c (cons nil nil))) (add-object c) @@ -455,8 +453,7 @@ ((= tag +hash-table+) (let* ((id (buffer-read-fixnum bs)) (maybe-hash (lookup-id id))) - (declare (dynamic-extent id maybe-hash) - (type fixnum id)) + (declare (type fixnum id)) (if maybe-hash maybe-hash (let* ((test (%deserialize bs)) (rehash-size (%deserialize bs)) @@ -480,7 +477,7 @@ ;; now, depending on what typedesig is, we might ;; or might not need to specify the store controller here.. (let ((o - (or (ignore-errors + (or (handler-case (if (subtypep typedesig 'persistent) (make-instance typedesig :sc sc) ;; if the this type doesn't exist in our object @@ -490,7 +487,8 @@ ;; prefer an abort here, but I prefer surviving... (make-instance typedesig) ) - ) + (error (v) (format t "got typedesig error: ~A ~A ~%" v typedesig) + (list 'caught-error v typedesig))) (list 'uninstantiable-object-of-type typedesig) ) )) @@ -525,16 +523,13 @@ do (setf (row-major-aref a i) (%deserialize bs))) a)))) - (t (error "deserialize fubar!"))) -;; (print-post-deserialize-tag value) -;; value) - ))) - (etypecase buf-str - (null (return-from deserialize nil)) - (buffer-stream - (let ((result (%deserialize buf-str))) - (release-circularity-vector circularity-vector) - result)))))) + (t (error (format nil "deserialize of object tagged with ~A failed" tag))))))) + (etypecase buf-str + (null (return-from deserialize nil)) + (buffer-stream + (let ((result (%deserialize buf-str))) + (release-circularity-vector circularity-vector) + result))))))
(defun deserialize-bignum (bs length positive) (declare (type buffer-stream bs) @@ -545,7 +540,7 @@ (ignorable int-byte-spec)) (loop for i from 0 below (/ length 4) for byte-spec = -;; #+(or cmu sbcl allegro) (progn (setf (cdr int-byte-spec) (* 32 i)) int-byte-spec) +;; #+(or allegro) (progn (setf (cdr int-byte-spec) (* 32 i)) int-byte-spec) #+(or allegro sbcl cmu lispworks openmcl) (byte 32 (* 32 i)) with num integer = 0 do