[elephant-cvs] CVS elephant/src/elephant
ieslick
ieslick at common-lisp.net
Wed Feb 21 04:47:47 UTC 2007
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
More information about the Elephant-cvs
mailing list