- cl-prevalence-devel@common-lisp.net - mailman3.common-lisp.net

[cl-prevalence-devel] Question on client-server usage.
by Yarek Kowalik 23 Aug '08

23 Aug '08

I've got two applications running on different hosts that I want to keep in sync using prevalence. How do I do this? Do I make one slave-server and one master-client? I tried that and even though the connections are established, I don't seem to be seeing any data flowing from client to server. Or, did I get that wrong? Is the data flowing from server to client? If I want to have data flowing in both directions, do I setup a dual channel connections where each side is both client and server but on different ports? Thanks, Yarek

1 1

[cl-prevalence-devel] Removal of managed prevalence object does not delete corresponding non-id indexes' entries and duplicate index values allowed
by Evan Monroig 09 Apr '08

09 Apr '08

(sorry for breaking the thread, I don't know how to recover it from pipermail. Original thread is here [1]) > On 18 Apr 2007, at 11:33, Nico de Jager wrote: > > When one deletes an object with tx-delete-object after creating an > > index on a slot (other than id) of a managed prevalence class, the > > corresponding index entry is not deleted. Because adding a new > > object with tx-create-object appears to update all the indexes on > > the class, one would expect tx-delete-object to also update the > > indexes accordingly. Is this a bug or the intended behaviour? > > The 'indexes on arbitrary slots' was contributed at one point. I do > think the implementation was quite clear and simple. But you are > right, this is a bug (or oversight): when deleting an object, the > index entries should be cleaned up. I was bitten by this too, and fixed it by writing my own version tx-delete-object2 which you can compare to the original tx-delete-object below. (defun tx-delete-object (system class id) "Delete the object of class with id from the system" (let ((object (find-object-with-id system class id))) (if object (let ((root-name (get-objects-root-name class)) (index-name (get-objects-slot-index-name class 'id))) (setf (get-root-object system root-name) (delete object (get-root-object system root-name))) (remhash id (get-root-object system index-name))) (error "no object of class ~a with id ~d found in ~s" class id system)))) (defun tx-delete-object2 (system class id &optional (indexed-slots '(id))) "Delete the object of class with id from the system" (let ((object (find-object-with-id system class id))) (if object (let ((root-name (get-objects-root-name class))) (setf (get-root-object system root-name) (delete object (get-root-object system root-name))) (dolist (slot indexed-slots) (remove-object-from-slot-index system class slot object))) (error "no object of class ~a with id ~d found in ~s" class id system)))) tx-delete-object2 doesn't address the possibility of an index having the possibility of pointing to several objects for each value as mentioned below. > > Also, shouldn't tx-create-object (or tx-change-object-slots) signal > > a condition when the addition of an object or the change of a slot > > results in duplicate slot values for an indexed slot? > > Apart from indexes on keys (like ID), which are necessarily unique, > indexes on arbitrary slots could theoretically be unique or not (as in > SQL). The current implementation is using hashtables and is > overwriting entries: so there too, there is a bug (or oversight): > either we should enforce unique indexes by signalling errors, or we > should allow multiple objects with the same indexed slot value, but > then there should be a list as value there (and we have to manage all > that correctly, esp. wrt. deleting objects). > > What to you think ? How are you using this feature ? > > So, thanks for reporting this problem. Do you feel like trying to fix > this with a patch ? > > Are there any other people on the list who would like to comment ? I also have wanted something like this. Use cases include slots that may be common among objects, or joins. For example, we have two classes Company and Person; each person has a slot company-id, and we may like to have an index on this slot to retrieve all the persons that have a specific company-id. Basically, this is a join, and having it precomputed in the form of indexes would speed up searching a lot once the database grows beyond some size. Evan [1] http://common-lisp.net/pipermail/cl-prevalence-devel/2007-April/000038.html

1 0

[cl-prevalence-devel] restore operation fails with linked objects
by Evan Monroig 16 Mar '08

16 Mar '08

Hi, I found a bug in cl-prevalence, where the objects that are linked are not properly reconstructed from the transaction log (restoring from a snapshot is fine). I included minimal example code in the attached file and also on lisp paste [1] for easy reference. Joe and Ma Dalton are two persons, and the slot 'PARENT of Joe is Ma. When the objects are reconstructed from the transaction log, three objects are created: Joe, Ma and another Ma that is the value of the slot 'PARENT of Joe, but not the same object as the first Ma. A look at the transaction-log.xml file shows that in the transaction for the creation of Joe, Ma is referred to as a person and the values of its slots are indicated, instead of referring to the previously created instance. Can anyone reproduce this? Any ideas to fix? I guess that the serialization doesn't know of the already existing objects. I'm working on SBCL 1.0.6 on Ubuntu 07.10 and cl-prevalence is the last released version. Thanks in advance, Evan [1] http://paste.lisp.org/display/57271

3 5

[cl-prevalence-devel] [PATCH] Use WITH-STANDARD-IO-SYNTAX
by Maciej Katafiasz 21 Feb '08

21 Feb '08

Hi, the patch below adds WITH-STANDARD-IO-SYNTAX to all places where reading and writing is done, which fixes the breakage when XML is (de)serialised across images with different READTABLE-CASE. I did a quick test on data that used to break before, and it seems to work fine. Cheers, Maciej ? doc Index: src/serialization.lisp =================================================================== RCS file: /project/cl-prevalence/cvsroot/cl-prevalence/src/serialization.lisp,v retrieving revision 1.11 diff -u -u -r1.11 serialization.lisp --- src/serialization.lisp 16 Mar 2007 15:37:18 -0000 1.11 +++ src/serialization.lisp 21 Feb 2008 11:31:19 -0000 @@ -101,26 +101,28 @@ (defconstant +keyword-package+ (find-package :keyword)) (defun print-symbol-xml (symbol stream) - (let ((package (symbol-package symbol)) - (name (prin1-to-string symbol))) - (cond ((eq package +cl-package+) (write-string "CL:" stream)) - ((eq package +keyword-package+) (write-char #\: stream)) - (t (s-xml:print-string-xml (package-name package) stream) - (write-string "::" stream))) - (if (char= (char name (1- (length name))) #\|) - (s-xml:print-string-xml name stream :start (position #\| name)) - (s-xml:print-string-xml name stream :start (1+ (or (position #\: name :from-end t) -1)))))) + (with-standard-io-syntax + (let ((package (symbol-package symbol)) + (name (prin1-to-string symbol))) + (cond ((eq package +cl-package+) (write-string "CL:" stream)) + ((eq package +keyword-package+) (write-char #\: stream)) + (t (s-xml:print-string-xml (package-name package) stream) + (write-string "::" stream))) + (if (char= (char name (1- (length name))) #\|) + (s-xml:print-string-xml name stream :start (position #\| name)) + (s-xml:print-string-xml name stream :start (1+ (or (position #\: name :from-end t) -1))))))) (defun print-symbol (symbol stream) - (let ((package (symbol-package symbol)) - (name (prin1-to-string symbol))) - (cond ((eq package +cl-package+) (write-string "CL:" stream)) - ((eq package +keyword-package+) (write-char #\: stream)) - (t (s-xml:print-string-xml (package-name package) stream) - (write-string "::" stream))) - (if (char= (char name (1- (length name))) #\|) - (write-string name stream :start (position #\| name)) - (write-string name stream :start (1+ (or (position #\: name :from-end t) -1)))))) + (with-standard-io-syntax + (let ((package (symbol-package symbol)) + (name (prin1-to-string symbol))) + (cond ((eq package +cl-package+) (write-string "CL:" stream)) + ((eq package +keyword-package+) (write-char #\: stream)) + (t (s-xml:print-string-xml (package-name package) stream) + (write-string "::" stream))) + (if (char= (char name (1- (length name))) #\|) + (write-string name stream :start (position #\| name)) + (write-string name stream :start (1+ (or (position #\: name :from-end t) -1))))))) (defmethod serializable-slots ((object structure-object)) #+openmcl @@ -234,15 +236,18 @@ (defmethod serialize-sexp-internal ((object string) stream serialization-state) (declare (ignore serialization-state)) - (prin1 object stream)) + (with-standard-io-syntax + (prin1 object stream))) (defmethod serialize-sexp-internal ((object character) stream serialization-state) (declare (ignore serialization-state)) - (prin1 object stream)) + (with-standard-io-syntax + (prin1 object stream))) (defmethod serialize-sexp-internal ((object symbol) stream serialization-state) (declare (ignore serialization-state)) - (print-symbol object stream)) + (with-standard-io-syntax + (print-symbol object stream))) (defun sequence-type-and-length(sequence) (if (listp sequence) @@ -256,226 +261,234 @@ (values :proper-sequence (length sequence)))) (defmethod serialize-xml-internal ((object sequence) stream serialization-state) - (flet ((proper-sequence (length) - (let ((id (set-known-object serialization-state object))) - (write-string "<SEQUENCE ID=\"" stream) - (prin1 id stream) - (write-string "\" CLASS=\"" stream) - (print-symbol-xml (etypecase object (list 'list) (vector 'vector)) stream) - (write-string "\" SIZE=\"" stream) - (prin1 length stream) - (write-string "\">" stream) - (map nil - #'(lambda (element) - (serialize-xml-internal element stream serialization-state)) - object) - (write-string "</SEQUENCE>" stream))) - (improper-list () - (let ((id (set-known-object serialization-state object))) - (write-string "<CONS ID=\"" stream) - (prin1 id stream) - (write-string "\">" stream) - (serialize-xml-internal (car object) stream serialization-state) - (write-char #\Space stream) - (serialize-xml-internal (cdr object) stream serialization-state) - (write-string "</CONS>" stream)))) + (with-standard-io-syntax + (flet ((proper-sequence (length) + (let ((id (set-known-object serialization-state object))) + (write-string "<SEQUENCE ID=\"" stream) + (prin1 id stream) + (write-string "\" CLASS=\"" stream) + (print-symbol-xml (etypecase object (list 'list) (vector 'vector)) stream) + (write-string "\" SIZE=\"" stream) + (prin1 length stream) + (write-string "\">" stream) + (map nil + #'(lambda (element) + (serialize-xml-internal element stream serialization-state)) + object) + (write-string "</SEQUENCE>" stream))) + (improper-list () + (let ((id (set-known-object serialization-state object))) + (write-string "<CONS ID=\"" stream) + (prin1 id stream) + (write-string "\">" stream) + (serialize-xml-internal (car object) stream serialization-state) + (write-char #\Space stream) + (serialize-xml-internal (cdr object) stream serialization-state) + (write-string "</CONS>" stream)))) + (let ((id (known-object-id serialization-state object))) + (if id + (progn + (write-string "<REF ID=\"" stream) + (prin1 id stream) + (write-string "\"/>" stream)) + (multiple-value-bind (seq-type length) (sequence-type-and-length object) + (ecase seq-type + ((:proper-sequence :proper-list) (proper-sequence length)) + ((:dotted-list :circular-list) (improper-list))))))))) + +(defmethod serialize-sexp-internal ((object sequence) stream serialization-state) + (with-standard-io-syntax + (flet ((proper-sequence (length) + (let ((id (set-known-object serialization-state object))) + (write-string "(:SEQUENCE " stream) + (prin1 id stream) + (write-string " :CLASS " stream) + (print-symbol (etypecase object (list 'list) (vector 'vector)) stream) + (write-string " :SIZE " stream) + (prin1 length stream) + (unless (zerop length) + (write-string " :ELEMENTS (" stream) + (map nil + #'(lambda (element) + (write-string " " stream) + (serialize-sexp-internal element stream serialization-state)) + object)) + (write-string " ) )" stream))) + (improper-list () + (let ((id (set-known-object serialization-state object))) + (write-string "(:CONS " stream) + (prin1 id stream) + (write-char #\Space stream) + (serialize-sexp-internal (car object) stream serialization-state) + (write-char #\Space stream) + (serialize-sexp-internal (cdr object) stream serialization-state) + (write-string " ) " stream)))) + (let ((id (known-object-id serialization-state object))) + (if id + (progn + (write-string "(:REF . " stream) + (prin1 id stream) + (write-string ")" stream)) + (multiple-value-bind (seq-type length) (sequence-type-and-length object) + (ecase seq-type + ((:proper-sequence :proper-list) (proper-sequence length)) + ((:dotted-list :circular-list) (improper-list))))))))) + +(defmethod serialize-xml-internal ((object hash-table) stream serialization-state) + (with-standard-io-syntax (let ((id (known-object-id serialization-state object))) (if id (progn (write-string "<REF ID=\"" stream) (prin1 id stream) - (write-string "\"/>" stream)) - (multiple-value-bind (seq-type length) (sequence-type-and-length object) - (ecase seq-type - ((:proper-sequence :proper-list) (proper-sequence length)) - ((:dotted-list :circular-list) (improper-list)))))))) + (write-string "\"/>" stream)) + (progn + (setf id (set-known-object serialization-state object)) + (write-string "<HASH-TABLE ID=\"" stream) + (prin1 id stream) + (write-string "\" TEST=\"" stream) + (print-symbol-xml (hash-table-test object) stream) + (write-string "\" SIZE=\"" stream) + (prin1 (hash-table-size object) stream) + (write-string "\">" stream) + (maphash #'(lambda (key value) + (write-string "<ENTRY><KEY>" stream) + (serialize-xml-internal key stream serialization-state) + (write-string "</KEY><VALUE>" stream) + (serialize-xml-internal value stream serialization-state) + (princ "</VALUE></ENTRY>" stream)) + object) + (write-string "</HASH-TABLE>" stream)))))) -(defmethod serialize-sexp-internal ((object sequence) stream serialization-state) - (flet ((proper-sequence (length) - (let ((id (set-known-object serialization-state object))) - (write-string "(:SEQUENCE " stream) - (prin1 id stream) - (write-string " :CLASS " stream) - (print-symbol (etypecase object (list 'list) (vector 'vector)) stream) - (write-string " :SIZE " stream) - (prin1 length stream) - (unless (zerop length) - (write-string " :ELEMENTS (" stream) - (map nil - #'(lambda (element) - (write-string " " stream) - (serialize-sexp-internal element stream serialization-state)) - object)) - (write-string " ) )" stream))) - (improper-list () - (let ((id (set-known-object serialization-state object))) - (write-string "(:CONS " stream) - (prin1 id stream) - (write-char #\Space stream) - (serialize-sexp-internal (car object) stream serialization-state) - (write-char #\Space stream) - (serialize-sexp-internal (cdr object) stream serialization-state) - (write-string " ) " stream)))) +(defmethod serialize-sexp-internal ((object hash-table) stream serialization-state) + (with-standard-io-syntax (let ((id (known-object-id serialization-state object))) (if id (progn (write-string "(:REF . " stream) (prin1 id stream) (write-string ")" stream)) - (multiple-value-bind (seq-type length) (sequence-type-and-length object) - (ecase seq-type - ((:proper-sequence :proper-list) (proper-sequence length)) - ((:dotted-list :circular-list) (improper-list)))))))) - -(defmethod serialize-xml-internal ((object hash-table) stream serialization-state) - (let ((id (known-object-id serialization-state object))) - (if id - (progn - (write-string "<REF ID=\"" stream) - (prin1 id stream) - (write-string "\"/>" stream)) - (progn - (setf id (set-known-object serialization-state object)) - (write-string "<HASH-TABLE ID=\"" stream) - (prin1 id stream) - (write-string "\" TEST=\"" stream) - (print-symbol-xml (hash-table-test object) stream) - (write-string "\" SIZE=\"" stream) - (prin1 (hash-table-size object) stream) - (write-string "\">" stream) - (maphash #'(lambda (key value) - (write-string "<ENTRY><KEY>" stream) - (serialize-xml-internal key stream serialization-state) - (write-string "</KEY><VALUE>" stream) - (serialize-xml-internal value stream serialization-state) - (princ "</VALUE></ENTRY>" stream)) - object) - (write-string "</HASH-TABLE>" stream))))) - -(defmethod serialize-sexp-internal ((object hash-table) stream serialization-state) - (let ((id (known-object-id serialization-state object))) - (if id - (progn - (write-string "(:REF . " stream) - (prin1 id stream) - (write-string ")" stream)) - (let ((count (hash-table-count object))) - (setf id (set-known-object serialization-state object)) - (write-string "(:HASH-TABLE " stream) - (prin1 id stream) - (write-string " :TEST " stream) - (print-symbol (hash-table-test object) stream) - (write-string " :SIZE " stream) - (prin1 (hash-table-size object) stream) - (write-string " :REHASH-SIZE " stream) - (prin1 (hash-table-rehash-size object) stream) - (write-string " :REHASH-THRESHOLD " stream) - (prin1 (hash-table-rehash-threshold object) stream) - (unless (zerop count) - (write-string " :ENTRIES (" stream) - (maphash #'(lambda (key value) - (write-string " (" stream) - (serialize-sexp-internal key stream serialization-state) - (write-string " . " stream) - (serialize-sexp-internal value stream serialization-state) - (princ ")" stream)) - object) - (write-string " )" stream)) - (write-string " )" stream))))) + (let ((count (hash-table-count object))) + (setf id (set-known-object serialization-state object)) + (write-string "(:HASH-TABLE " stream) + (prin1 id stream) + (write-string " :TEST " stream) + (print-symbol (hash-table-test object) stream) + (write-string " :SIZE " stream) + (prin1 (hash-table-size object) stream) + (write-string " :REHASH-SIZE " stream) + (prin1 (hash-table-rehash-size object) stream) + (write-string " :REHASH-THRESHOLD " stream) + (prin1 (hash-table-rehash-threshold object) stream) + (unless (zerop count) + (write-string " :ENTRIES (" stream) + (maphash #'(lambda (key value) + (write-string " (" stream) + (serialize-sexp-internal key stream serialization-state) + (write-string " . " stream) + (serialize-sexp-internal value stream serialization-state) + (princ ")" stream)) + object) + (write-string " )" stream)) + (write-string " )" stream)))))) (defmethod serialize-xml-internal ((object structure-object) stream serialization-state) - (let ((id (known-object-id serialization-state object))) - (if id - (progn - (write-string "<REF ID=\"" stream) - (prin1 id stream) - (write-string "\"/>" stream)) - (progn - (setf id (set-known-object serialization-state object)) - (write-string "<STRUCT ID=\"" stream) - (prin1 id stream) - (write-string "\" CLASS=\"" stream) - (print-symbol-xml (class-name (class-of object)) stream) - (write-string "\">" stream) - (mapc #'(lambda (slot) - (write-string "<SLOT NAME=\"" stream) - (print-symbol-xml slot stream) - (write-string "\">" stream) - (serialize-xml-internal (slot-value object slot) stream serialization-state) - (write-string "</SLOT>" stream)) - (get-serializable-slots serialization-state object)) - (write-string "</STRUCT>" stream))))) + (with-standard-io-syntax + (let ((id (known-object-id serialization-state object))) + (if id + (progn + (write-string "<REF ID=\"" stream) + (prin1 id stream) + (write-string "\"/>" stream)) + (progn + (setf id (set-known-object serialization-state object)) + (write-string "<STRUCT ID=\"" stream) + (prin1 id stream) + (write-string "\" CLASS=\"" stream) + (print-symbol-xml (class-name (class-of object)) stream) + (write-string "\">" stream) + (mapc #'(lambda (slot) + (write-string "<SLOT NAME=\"" stream) + (print-symbol-xml slot stream) + (write-string "\">" stream) + (serialize-xml-internal (slot-value object slot) stream serialization-state) + (write-string "</SLOT>" stream)) + (get-serializable-slots serialization-state object)) + (write-string "</STRUCT>" stream)))))) (defmethod serialize-sexp-internal ((object structure-object) stream serialization-state) - (let ((id (known-object-id serialization-state object))) - (if id - (progn - (write-string "(:REF . " stream) - (prin1 id stream) - (write-string ")" stream)) - (let ((serializable-slots (get-serializable-slots serialization-state object))) - (setf id (set-known-object serialization-state object)) - (write-string "(:STRUCT " stream) - (prin1 id stream) - (write-string " :CLASS " stream) - (print-symbol (class-name (class-of object)) stream) - (when serializable-slots - (write-string " :SLOTS (" stream) - (mapc #'(lambda (slot) - (write-string " (" stream) - (print-symbol slot stream) - (write-string " . " stream) - (serialize-sexp-internal (slot-value object slot) stream serialization-state) - (write-string ")" stream)) - serializable-slots)) - (write-string " ) )" stream))))) + (with-standard-io-syntax + (let ((id (known-object-id serialization-state object))) + (if id + (progn + (write-string "(:REF . " stream) + (prin1 id stream) + (write-string ")" stream)) + (let ((serializable-slots (get-serializable-slots serialization-state object))) + (setf id (set-known-object serialization-state object)) + (write-string "(:STRUCT " stream) + (prin1 id stream) + (write-string " :CLASS " stream) + (print-symbol (class-name (class-of object)) stream) + (when serializable-slots + (write-string " :SLOTS (" stream) + (mapc #'(lambda (slot) + (write-string " (" stream) + (print-symbol slot stream) + (write-string " . " stream) + (serialize-sexp-internal (slot-value object slot) stream serialization-state) + (write-string ")" stream)) + serializable-slots)) + (write-string " ) )" stream)))))) (defmethod serialize-xml-internal ((object standard-object) stream serialization-state) - (let ((id (known-object-id serialization-state object))) - (if id - (progn - (write-string "<REF ID=\"" stream) - (prin1 id stream) - (write-string "\"/>" stream)) - (progn - (setf id (set-known-object serialization-state object)) - (write-string "<OBJECT ID=\"" stream) - (prin1 id stream) - (write-string "\" CLASS=\"" stream) - (print-symbol-xml (class-name (class-of object)) stream) - (princ "\">" stream) - (loop :for slot :in (get-serializable-slots serialization-state object) - :do (when (slot-boundp object slot) - (write-string "<SLOT NAME=\"" stream) - (print-symbol-xml slot stream) - (write-string "\">" stream) - (serialize-xml-internal (slot-value object slot) stream serialization-state) - (write-string "</SLOT>" stream))) - (write-string "</OBJECT>" stream))))) + (with-standard-io-syntax + (let ((id (known-object-id serialization-state object))) + (if id + (progn + (write-string "<REF ID=\"" stream) + (prin1 id stream) + (write-string "\"/>" stream)) + (progn + (setf id (set-known-object serialization-state object)) + (write-string "<OBJECT ID=\"" stream) + (prin1 id stream) + (write-string "\" CLASS=\"" stream) + (print-symbol-xml (class-name (class-of object)) stream) + (princ "\">" stream) + (loop :for slot :in (get-serializable-slots serialization-state object) + :do (when (slot-boundp object slot) + (write-string "<SLOT NAME=\"" stream) + (print-symbol-xml slot stream) + (write-string "\">" stream) + (serialize-xml-internal (slot-value object slot) stream serialization-state) + (write-string "</SLOT>" stream))) + (write-string "</OBJECT>" stream)))))) (defmethod serialize-sexp-internal ((object standard-object) stream serialization-state) - (let ((id (known-object-id serialization-state object))) - (if id - (progn - (write-string "(:REF . " stream) - (prin1 id stream) - (write-string ")" stream)) - (let ((serializable-slots (get-serializable-slots serialization-state object))) - (setf id (set-known-object serialization-state object)) - (write-string "(:OBJECT " stream) - (prin1 id stream) - (write-string " :CLASS " stream) - (print-symbol (class-name (class-of object)) stream) - (when serializable-slots - (princ " :SLOTS (" stream) - (loop :for slot :in serializable-slots - :do (when (slot-boundp object slot) - (write-string " (" stream) - (print-symbol slot stream) - (write-string " . " stream) - (serialize-sexp-internal (slot-value object slot) stream serialization-state) - (write-string ")" stream)))) - (write-string " ) )" stream))))) + (with-standard-io-syntax + (let ((id (known-object-id serialization-state object))) + (if id + (progn + (write-string "(:REF . " stream) + (prin1 id stream) + (write-string ")" stream)) + (let ((serializable-slots (get-serializable-slots serialization-state object))) + (setf id (set-known-object serialization-state object)) + (write-string "(:OBJECT " stream) + (prin1 id stream) + (write-string " :CLASS " stream) + (print-symbol (class-name (class-of object)) stream) + (when serializable-slots + (princ " :SLOTS (" stream) + (loop :for slot :in serializable-slots + :do (when (slot-boundp object slot) + (write-string " (" stream) + (print-symbol slot stream) + (write-string " . " stream) + (serialize-sexp-internal (slot-value object slot) stream serialization-state) + (write-string ")" stream)))) + (write-string " ) )" stream)))))) ;;; Deserialize CLOS instances and Lisp primitives from the XML representation @@ -484,68 +497,70 @@ (defun deserialize-xml-new-element (name attributes seed) (declare (ignore seed) (special *deserialized-objects*)) - (case name - (:sequence (let ((id (parse-integer (get-attribute-value :id attributes))) - (class (read-from-string (get-attribute-value :class attributes))) - (size (parse-integer (get-attribute-value :size attributes)))) - (setf (gethash id *deserialized-objects*) - (make-sequence class size)))) - (:object (let ((id (parse-integer (get-attribute-value :id attributes))) - (class (read-from-string (get-attribute-value :class attributes)))) - (setf (gethash id *deserialized-objects*) - (make-instance class)))) - (:cons (setf (gethash (parse-integer (get-attribute-value :id attributes)) - *deserialized-objects*) - (cons nil nil))) - (:struct (let ((id (parse-integer (get-attribute-value :id attributes))) - (class (read-from-string (get-attribute-value :class attributes)))) - (setf (gethash id *deserialized-objects*) - (funcall (intern (concatenate 'string "MAKE-" (symbol-name class)) (symbol-package class)))))) - (:hash-table (let ((id (parse-integer (get-attribute-value :id attributes))) - (test (read-from-string (get-attribute-value :test attributes))) - (size (parse-integer (get-attribute-value :size attributes)))) - (setf (gethash id *deserialized-objects*) - (make-hash-table :test test :size size))))) + (with-standard-io-syntax + (case name + (:sequence (let ((id (parse-integer (get-attribute-value :id attributes))) + (class (read-from-string (get-attribute-value :class attributes))) + (size (parse-integer (get-attribute-value :size attributes)))) + (setf (gethash id *deserialized-objects*) + (make-sequence class size)))) + (:object (let ((id (parse-integer (get-attribute-value :id attributes))) + (class (read-from-string (get-attribute-value :class attributes)))) + (setf (gethash id *deserialized-objects*) + (make-instance class)))) + (:cons (setf (gethash (parse-integer (get-attribute-value :id attributes)) + *deserialized-objects*) + (cons nil nil))) + (:struct (let ((id (parse-integer (get-attribute-value :id attributes))) + (class (read-from-string (get-attribute-value :class attributes)))) + (setf (gethash id *deserialized-objects*) + (funcall (intern (concatenate 'string "MAKE-" (symbol-name class)) (symbol-package class)))))) + (:hash-table (let ((id (parse-integer (get-attribute-value :id attributes))) + (test (read-from-string (get-attribute-value :test attributes))) + (size (parse-integer (get-attribute-value :size attributes)))) + (setf (gethash id *deserialized-objects*) + (make-hash-table :test test :size size)))))) '()) (defun deserialize-xml-finish-element (name attributes parent-seed seed) (declare (special *deserialized-objects*)) - (cons (case name - (:int (parse-integer seed)) - ((:float :ratio :complex :symbol) (read-from-string seed)) - (:null nil) - (:true t) - (:string (or seed "")) - (:character (char seed 0)) - (:key (car seed)) - (:value (car seed)) - (:entry (nreverse seed)) - (:slot (let ((name (read-from-string (get-attribute-value :name attributes)))) - (cons name (car seed)))) - (:sequence (let* ((id (parse-integer (get-attribute-value :id attributes))) - (sequence (gethash id *deserialized-objects*))) - (map-into sequence #'identity (nreverse seed)))) - (:cons (let* ((id (parse-integer (get-attribute-value :id attributes))) - (cons-pair (gethash id *deserialized-objects*))) - (rplaca cons-pair (second seed)) - (rplacd cons-pair (first seed)))) - (:object (let* ((id (parse-integer (get-attribute-value :id attributes))) - (object (gethash id *deserialized-objects*))) - (dolist (pair seed object) - (when (slot-exists-p object (car pair)) - (setf (slot-value object (car pair)) (cdr pair)))))) - (:struct (let* ((id (parse-integer (get-attribute-value :id attributes))) - (object (gethash id *deserialized-objects*))) - (dolist (pair seed object) - (when (slot-exists-p object (car pair)) - (setf (slot-value object (car pair)) (cdr pair)))))) - (:hash-table (let* ((id (parse-integer (get-attribute-value :id attributes))) - (hash-table (gethash id *deserialized-objects*))) - (dolist (pair seed hash-table) - (setf (gethash (car pair) hash-table) (cadr pair))))) - (:ref (let ((id (parse-integer (get-attribute-value :id attributes)))) - (gethash id *deserialized-objects*)))) - parent-seed)) + (with-standard-io-syntax + (cons (case name + (:int (parse-integer seed)) + ((:float :ratio :complex :symbol) (read-from-string seed)) + (:null nil) + (:true t) + (:string (or seed "")) + (:character (char seed 0)) + (:key (car seed)) + (:value (car seed)) + (:entry (nreverse seed)) + (:slot (let ((name (read-from-string (get-attribute-value :name attributes)))) + (cons name (car seed)))) + (:sequence (let* ((id (parse-integer (get-attribute-value :id attributes))) + (sequence (gethash id *deserialized-objects*))) + (map-into sequence #'identity (nreverse seed)))) + (:cons (let* ((id (parse-integer (get-attribute-value :id attributes))) + (cons-pair (gethash id *deserialized-objects*))) + (rplaca cons-pair (second seed)) + (rplacd cons-pair (first seed)))) + (:object (let* ((id (parse-integer (get-attribute-value :id attributes))) + (object (gethash id *deserialized-objects*))) + (dolist (pair seed object) + (when (slot-exists-p object (car pair)) + (setf (slot-value object (car pair)) (cdr pair)))))) + (:struct (let* ((id (parse-integer (get-attribute-value :id attributes))) + (object (gethash id *deserialized-objects*))) + (dolist (pair seed object) + (when (slot-exists-p object (car pair)) + (setf (slot-value object (car pair)) (cdr pair)))))) + (:hash-table (let* ((id (parse-integer (get-attribute-value :id attributes))) + (hash-table (gethash id *deserialized-objects*))) + (dolist (pair seed hash-table) + (setf (gethash (car pair) hash-table) (cadr pair))))) + (:ref (let ((id (parse-integer (get-attribute-value :id attributes)))) + (gethash id *deserialized-objects*)))) + parent-seed))) (defun deserialize-xml-text (string seed) (declare (ignore seed))

2 1

[cl-prevalence-devel] simple-array serialization patch
by Michael J. Forster 19 Apr '07

19 Apr '07

Hi Sven, I don't know if you or anyone else is interested, but I have implemented xml and sexp serialization/deserialization of simple arrays -- I needed it for an app that uses cl-prevalence. I've attached the patch. BTW, I would like to say that cl-prevalence is fantastic. We've been using it for five non-trivial (>25 classes, avg. 3000 instances per class) webapps without a hitch for almost a year now. Regards, Mike -- Michael J. Forster <mike(a)sharedlogic.ca>

2 3

Re: [cl-prevalence-devel] Removal of managed prevalence object does not delete corresponding non-id indexes' entries and duplicate index values allowed
by Nico de Jager 18 Apr '07

18 Apr '07

On Wednesday 18 April 2007 13:45, Sven Van Caekenberghe wrote: > Nico, > > On 18 Apr 2007, at 11:33, Nico de Jager wrote: > > > When one deletes an object with tx-delete-object after creating an > > index on a slot (other than id) of a managed prevalence class, the > > corresponding index entry is not deleted. Because adding a new > > object with tx-create-object appears to update all the indexes on > > the class, one would expect tx-delete-object to also update the > > indexes accordingly. Is this a bug or the intended behaviour? > > The 'indexes on arbitrary slots' was contributed at one point. I do > think the implementation was quite clear and simple. > But you are right, this is a bug (or oversight): when deleting an > object, the index entries should be cleaned up. > > > Also, shouldn't tx-create-object (or tx-change-object-slots) signal > > a condition when the addition of an object or the change of a slot > > results in duplicate slot values for an indexed slot? > > Apart from indexes on keys (like ID), which are necessarily unique, > indexes on arbitrary slots could theoretically be unique or not (as > in SQL). The current implementation is using hashtables and is > overwriting entries: so there too, there is a bug (or oversight): > either we should enforce unique indexes by signalling errors, or we > should allow multiple objects with the same indexed slot value, but > then there should be a list as value there (and we have to manage all > that correctly, esp. wrt. deleting objects). > > What to you think ? How are you using this feature ? It would be really nice if INDEX-ON had an optional UNIQUE parameter that allows one to choose between either a unique or non-unique index. I would use both types. B.t.w. why is SLOTS an optional parameter in the definition of INDEX-ON? As it is the function would do nothing if SLOTS is not supplied: (defun index-on (system class &optional slots (test 'equalp)) "Create indexes on each of the slots provided." (dolist (slot slots) (execute-transaction (tx-create-objects-slot-index system class slot test)))) > > So, thanks for reporting this problem. Do you feel like trying to fix > this with a patch ? I would give it a try as soon as I can find the time. I am not an expert Lisper yet, so it will probably take me longer. But it will definitely be worth it, I have replaced all my CLSQL databases with cl-prevalence. > > Are there any other people on the list who would like to comment ? > > Sven > Thanks for your quick feedback. Nico

1 0

[cl-prevalence-devel] Removal of managed prevalence object does not delete corresponding non-id indexes' entries and duplicate index values allowed
by Nico de Jager 18 Apr '07

18 Apr '07

Hi When one deletes an object with tx-delete-object after creating an index on a slot (other than id) of a managed prevalence class, the corresponding index entry is not deleted. Because adding a new object with tx-create-object appears to update all the indexes on the class, one would expect tx-delete-object to also update the indexes accordingly. Is this a bug or the intended behaviour? Also, shouldn't tx-create-object (or tx-change-object-slots) signal a condition when the addition of an object or the change of a slot results in duplicate slot values for an indexed slot? Thanks. Nico

2 1

[cl-prevalence-devel] cl-prevalence speed issues
by Gabor Vitez 04 Apr '07

04 Apr '07

Hi, I just started to toy around with cl-prevalence; however I found strange speed issues: loading a database from transaction log is way faster than loading it from snapshot. I modified one of the test scripts from the cl-prevalence distribution: (require 'asdf) (require 'cl-prevalence) (in-package :cl-prevalence) (defclass numbers () ((numbers-list :accessor get-numbers-list :initform nil)) (:documentation "Object to hold our list of numbers")) (defun tx-create-numbers-root (system) "Transaction function to create a numbers instance as a root object" (setf (get-root-object system :numbers) (make-instance 'numbers))) (defun tx-add-number (system number) "Transaction function to add a number to the numbers list" (let ((numbers (get-root-object system :numbers))) (push number (get-numbers-list numbers)))) (defparameter *system-location* (pathname "/tmp/demo1-prevalence-system/") "Filesystem location of the prevalence system") (defvar *system* (time (make-prevalence-system *system-location*)) ) (execute *system* (make-transaction 'tx-create-numbers-root)) (time (dotimes (i 100000) (execute *system* (make-transaction 'tx-add-number i))) ) ;(time (snapshot *system*)) (close-open-streams *system*) I use this script to create a database; later to load it; then to snapshot it and load it again (uncommenting the appropriate parts between the runs). Creating and snapshotting is fast; however loading from snapshot is slow. Times: creating: 19.89 seconds loading from transaction log: 53.942 seconds < this is good snapshotting: 5.297 seconds loading from snapshot: 182.713 seconds < this is strange snapshotting again: 1.165 seconds Any ideas what this strangeness can be? Gabor

2 1

[cl-prevalence-devel] set-slot-values
by Nico de Jager 29 Mar '07

29 Mar '07

Hi The symbol SET-SLOT-VALUES is exported from the cl-prevalence package, but there is no such function. Grepping for the string "set-slot-values" shows the string only in the files src/package.lisp and doc/CL-PREVALENCE.html. I downloaded the cl-prevalence.tgz tarball from common-lisp.net today to make sure I have the latest version of the library. Has this function been dropped accidentally or was it deprecated and should it be removed from the documentation file and package.lisp or am I missing something? Thanks. Nico

2 1

[cl-prevalence-devel] Re: bug in cl-prevalence
by Sven Van Caekenberghe 16 Mar '07

16 Mar '07

On 15 Mar 2007, at 16:43, Phlex wrote: > Hello, > > I beleive I found a bug in your cl-prevalence package. It is in the > src/serialization.lisp file. > Here is what i think is the correct (serialize-sexp-internal hash- > table ? ?) method. > > (defmethod serialize-sexp-internal ((object hash-table) stream > serialization-state) > (let ((id (known-object-id serialization-state object))) > (if id > (progn > (write-string "(:REF . " stream) > (prin1 id stream) > (write-string ")" stream)) > (let ((count (hash-table-count object))) > (setf id (set-known-object serialization-state object)) > (write-string "(:HASH-TABLE " stream) > (prin1 id stream) > (write-string " :TEST " stream) > (print-symbol (hash-table-test object) stream) > (write-string " :SIZE " stream) > (prin1 (hash-table-size object) stream) > (write-string " :REHASH-SIZE " stream) > (prin1 (hash-table-rehash-size object) stream) > (write-string " :REHASH-THRESHOLD " stream) > (prin1 (hash-table-rehash-threshold object) stream) > (unless (zerop count) > (write-string " :ENTRIES (" stream) > (maphash #'(lambda (key value) > (write-string " (" stream) > (serialize-sexp-internal key stream > serialization-state) > (write-string " . " stream) > (serialize-sexp-internal value stream > serialization-state) > (princ ")" stream)) > object) > (write-string " )" stream)) ;;this line was added > (write-string " )" stream))))) ;;a closing parenthesis was > removed from the output string > > I hope this helps, and thanks for your work on this library. > > Sacha De Vos Thanks for noticing/reporting/fixing this bug, Sascha! I applied your change, committed it and re-released the tarball. Sven

1 0