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

[cl-prevalence-devel] A useful macro?
by Anthony Fairchild 08 Nov '11

08 Nov '11

Hi cl-prevalence devs, I have been playing around a bit with cl-prevalence and found the following macro useful: (defmacro deftxn (name (system &rest args) &body body) (let ((tx-name (intern (format nil "TX-~A" NAME)))) `(progn (defun ,tx-name (,system ,@args) ,@body) (defun ,name (,system ,@args) (execute-transaction (,tx-name ,system ,@args)))))) So my question is, is this pattern worth abstracting or is there a reason to use the more explicit method of defining a tx-* function then calling (execute (make-transaction ...)) or (execute-transaction ...). Thanks! Anthony

1 0

[cl-prevalence-devel] 2D arrays
by Krzysztof Drewniak 05 Jul '10

05 Jul '10

Is there any major problems with getting 2D arrays (sequences of sequences) serialized? (I'm working on a game and trying to find a serialization libraryt that does what I need) Krzysztof Drewniak -- X-Real-Email-With-Antispam: krzysdrewniak at gmail dot com pgp key on keyserver.ubuntu.com and maybe some other place too

2 2

Re: [cl-prevalence-devel] Patch for serialization of arbitrary data
by Leslie P. Polzer 05 Jul '10

05 Jul '10

Krzysztof Drewniak wrote: > --- src/serialization/xml.lisp.old 2010-06-10 20:50:24.000000000 -0500 > +++ src/serialization/xml.lisp 2010-06-10 21:24:34.000000000 -0500 > @@ -196,6 +196,12 @@ > (write-string "</SLOT>" stream))) > (write-string "</OBJECT>" stream))))) > > +;;anything we don't know about > +(defmethod serialize-xml-internal (object stream serialization-state) > + (declare (ignore serialization-state)) > + (write-string "<ARBITRARY>" stream) > + (print object stream) > + (write-string "</ARBITRARY>" stream)) > > ;;;; DESERIALIZATION > > @@ -283,6 +289,11 @@ > (declare (ignore name attributes parent-seed seed)) > nil)) > > +(defmethod deserialize-xml-finish-element-aux ((name (eql :arbitrary)) > + attributes parent-seed seed) > + (declare (ignore name attributes parent-seed)) > + (read (make-string-input-stream seed))) > + I'm not sure whether this one is good. We're mixing XML and SEXP serialization. Do you have a specific use case? Leslie

1 0

[cl-prevalence-devel] Opening the transaction log - Clozure CL
by William Bruschi 04 Jul '10

04 Jul '10

The Clozure CL implementation has added additional keywords to OPEN, including the :SHARING keyword which controls the access to the stream by multiple threads. The default value is :PRIVATE, which allows access to only the thread that created the stream. More info here: http://openmcl.clozure.com/manual/chapter9.1.html#CCL-Stream-Extensions I was using cl-prevalence as a backend for a Weblocks application when I stumbled upon thread locking errors while accessing the site with multiple browsers. Setting :SHARING to nil fixed my problem. Should this be the default behavior for cl-prevalence? After skimming the code, it appears cl-prevalence has it's own locking mechanisms, making Clozure's extra keyword arguments unnecessary. I also noticed in the TODO file that porting to ccl is on the list. In case anyone is curious, here's how to reproduce the error in Weblocks: 1. Create a new project as outlined in the bottom of http://trac.common-lisp.net/cl-weblocks/wiki/UserManual 2. Edit you init-session.lisp file to this: (defun init-user-session (root) (setf (widget-children root) (list (make-grid-edit)))) (defclass thing () ((id :initform nil :initarg :id :accessor thing-id :type (or null integer)) (name :initform nil :initarg :name :accessor thing-name))) (defun make-grid-edit () (make-instance 'gridedit :data-class 'thing)) 3. Open the site using two different browsers. Add a record using each browser. The second time you add a record, you receive this error: SIMPLE-ERROR: Stream #<BASIC-FILE-CHARACTER-OUTPUT-STREAM ("/<path-to-file>/transaction-log.xml"/15 ISO-8859-1) #x1987FB3E> is private to #<PROCESS Hunchentoot worker (client: 127.0.0.1:47448)(14) [Reset] #x1983AA9E>

2 1

[cl-prevalence-devel] Patch for serialization of arbitrary data
by Krzysztof Drewniak 11 Jun '10

11 Jun '10

This patch allows the xml serialization to serialize anything not explicitly covered by the code (some implementations can print functions etc.). Also, the 3.5 download is broken and I'd look si;;y telling my users pull the latest development code of cl-prevalence. -- X-Real-Email-With-Antispam: krzysdrewniak at gmail dot com pgp key on keyserver.ubuntu.com and maybe some other place too

2 3

[cl-prevalence-devel] 20090926 cummulative patchset
by Alexey Voznyuk 08 Oct '09

08 Oct '09

Hello! Here is what I have done since 20090828 in 'hg diff' format: http://swizard.info/misc/cl-prevalence-3.patch It is going slightly uncomfortable for me to maintain patchfiles, maybe I should make a mercurial branch or something? Detailed changelog: 1. SEXP standard-object serializing: fixed a bug with no-slots objects. 2. Backup method for guarded-prevalence-system: key parameter bugfix. 3. Files external format support for prevalence-system with tests available (test/test-external-format.lisp). 4. Moved from 'copy-file'+'delete-file' to 'rename-file' in snapshot method. Have no idea why it was like that :) 5. Removed reset serialization context invocations in serialize-sexp, deserialize-sexp, serialize-xml and deserialize-xml. Context reset moved to 'snapshot' method. 6. test/test-complex-serialize.lisp: emulation of complex datasets processing under heavy load.

2 4

[cl-prevalence-devel] Keeping state during transactions
by Alexey Voznyuk 26 Sep '09

26 Sep '09

Hello! I've faced annoying cl-prevalence behavior which I don't know how to deal with. For example, consider this code that I want to run within a transaction: (defun tx-add-item (store index item) (declare (ignore store)) (setf (gethash item index) t)) Current cl-prevalence implementation invokes (reset serialization-state) before each (serialize-*) call. So as long as I insert new items into the index, each log entry becomes bigger and bigger because it needs to deeply serialize "index" parameter with all its elements, including the new ones. The problem that the index can contains thousands elements, and each of them can be a complex object itself with maybe more index tables. In such case a single transaction can consume a lot of resource. My proposal is to not reset serialization-state before each transaction serialize step but to keep it until full snapshot is occurred. For me it seems to work correctly, but maybe I miss something?

2 5

[cl-prevalence-devel] [feature proposal][patch] :external-format for file operations
by Alexey Voznyuk 25 Sep '09

25 Sep '09

Hello! Current cl-prevalence version does not allow to set specific :external-format when reading or writing files. This is very uncomfortable when current working encoding in application differs from the system locale's one: cl recodes strings on serializing. Please check this patchset implementing the feature (cumulative with my previous bugfixes for "serialize-sexp-external" and "backup"). Maybe there are some crossplatform-related changes required. % hg diff diff -r 1edf5cd93bb9 src/prevalence.lisp --- a/src/prevalence.lisp Sun Jul 26 11:10:13 2009 +0200 +++ b/src/prevalence.lisp Tue Sep 08 22:44:04 2009 +0400 @@ -103,7 +103,11 @@ (transaction-hook ;; type function :accessor get-transaction-hook :initarg :transaction-hook - :initform #'identity)) + :initform #'identity) + (external-format ;; external encoding for file operations + :reader get-external-format + :initarg :external-format + :initform :utf-8)) (:documentation "Base Prevalence system implementation object")) (defclass guarded-prevalence-system (prevalence-system) @@ -156,7 +160,8 @@ (setf transaction-log-stream (open (get-transaction-log system) :direction :output :if-does-not-exist :create - :if-exists :append))))) + :if-exists :append + :external-format (get-external-format system)))))) (defmethod close-open-streams ((system prevalence-system) &key abort) "Close all open stream associated with system (optionally aborting operations in progress)" @@ -242,7 +247,7 @@ :type (get-file-extension system)) snapshot))) (with-open-file (out snapshot - :direction :output :if-does-not-exist :create :if-exists :supersede) + :direction :output :if-does-not-exist :create :if-exists :supersede :external-format (get-external-format system)) (funcall (get-serializer system) (get-root-objects system) out (get-serialization-state system))) (when (probe-file transaction-log) (copy-file transaction-log (merge-pathnames (make-pathname :name (get-transaction-log-filename system timetag) @@ -273,7 +278,7 @@ (clrhash (get-root-objects system)) (close-open-streams system) (when (probe-file (get-snapshot system)) - (with-open-file (in (get-snapshot system) :direction :input) + (with-open-file (in (get-snapshot system) :direction :input :external-format (get-external-format system)) (setf (get-root-objects system) (funcall (get-deserializer system) in (get-serialization-state system))))) (when (probe-file (get-transaction-log system)) (let ((position 0)) @@ -284,7 +289,7 @@ condition) (truncate-file (get-transaction-log system) position) (return-from restore)))) - (with-open-file (in (get-transaction-log system) :direction :input) + (with-open-file (in (get-transaction-log system) :direction :input :external-format (get-external-format system)) (loop (let ((transaction (funcall (get-deserializer system) in (get-serialization-state system)))) (setf position (file-position in)) @@ -310,7 +315,7 @@ (defmethod backup ((system guarded-prevalence-system) &key directory) "Do a backup on a system controlled by a guard" (funcall (get-guard system) - #'(lambda () (call-next-method system directory)))) + #'(lambda () (call-next-method system :directory directory)))) (defmethod restore ((system guarded-prevalence-system)) "Restore a system controlled by a guard" @@ -343,8 +348,8 @@ (buffer (make-string 4096)) (index 0) (read-count 0)) - (with-open-file (in file :direction :input) - (with-open-file (out tmp-file :direction :output :if-exists :overwrite :if-does-not-exist :create) + (with-open-file (in file :direction :input :external-format (get-external-format system)) + (with-open-file (out tmp-file :direction :output :if-exists :overwrite :if-does-not-exist :create :external-format (get-external-format system)) (when (> position (file-length in)) (return-from truncate-file)) (loop (when (= index position) (return)) @@ -360,8 +365,8 @@ (defun copy-file (source target) (let ((buffer (make-string 4096)) (read-count 0)) - (with-open-file (in source :direction :input) - (with-open-file (out target :direction :output :if-exists :overwrite :if-does-not-exist :create) + (with-open-file (in source :direction :input :external-format (get-external-format system)) + (with-open-file (out target :direction :output :if-exists :overwrite :if-does-not-exist :create :external-format (get-external-format system)) (loop (setf read-count (read-sequence buffer in)) (write-sequence buffer out :end read-count) diff -r 1edf5cd93bb9 src/serialization/sexp.lisp --- a/src/serialization/sexp.lisp Sun Jul 26 11:10:13 2009 +0200 +++ b/src/serialization/sexp.lisp Tue Sep 08 22:44:04 2009 +0400 @@ -145,8 +145,9 @@ (write-string " . " stream) (serialize-sexp-internal (slot-value object slot) stream serialization-state) (write-string ")" stream)) - serializable-slots)) - (write-string " ) )" stream))))) + serializable-slots) + (write-string " )" stream)) + (write-string " )" stream))))) ;;; objects (defmethod serialize-sexp-internal ((object standard-object) stream serialization-state)

2 4

[cl-prevalence-devel] [patch] serialize-sexp-internal bug: serializing object with no slots
by Alexey Voznyuk 31 Aug '09

31 Aug '09

Hello! I didn't get if the cl-prevalence project is still alive but maybe someone will need this patch: --- serialization.lisp.orig 2009-08-28 21:04:00.624489057 +0400 +++ serialization.lisp 2009-08-28 21:16:44.758777912 +0400 @@ -475,6 +475,7 @@ (write-string " . " stream) (serialize-sexp-internal (slot-value object slot) stream serialization-state) - (write-string ")" stream)))) - (write-string " ) )" stream))))) + (write-string ")" stream))) + (princ " )" stream)) + (write-string " )" stream))))) ;;; Deserialize CLOS instances and Lisp primitives from the XML representation

3 7

Re: [cl-prevalence-devel] News
by Leslie P. Polzer 02 Aug '09

02 Aug '09

evrim.ulu(a)core.gen.tr wrote: > It is very unfortunate that the site does not work in your browser. > I am willing to see the error. Can you rephrase that sentence? I didn't get it. >> How does WITH-TRANSACTION work? >> > > It serializes the closure the body as a closure along with its > environment. Ah, that's nice. How do you implement closure serialization? In particular, how do you capture the environment and restore environments shared by multiple closures? > PS: Could you add my email addrss to devel list, > i'm continuatiosly getting bounces from list admin. Sorry, I don't have access to the list admin interface. Please subscribe yourself (and set yourself on holiday mode if you don't want to receive mail). Cheers, Leslie -- http://www.linkedin.com/in/polzer

1 0

Re: [cl-prevalence-devel] News
by Leslie P. Polzer 30 Jul '09

30 Jul '09

Hello Evrim, evrim.ulu(a)core.gen.tr wrote: > This is very unfortunate, which browser you are using? I'm using Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.9.1.1) Gecko/20090715 Firefox/3.5.1 > Maybe you should can try enabling javascript? It's enabled. > http://labs.core.gen.tr/repos/core-server/src/database/database.lisp > > Please have a look and then we'll discuss. Alright, that's a lot of stuff. What does it do? How does WITH-TRANSACTION work? Leslie -- http://www.linkedin.com/in/polzer

1 0

Re: [cl-prevalence-devel] News
by Leslie P. Polzer 27 Jul '09

27 Jul '09

Evrim, unfortunately I can't access anything on the site you've mentioned -- I always get "Loading, please hold...". Can you fix that or send me a tarball of your cl-prevalence version? Of course it would be even better if you could send a patch against the current hg version of clp. Thanks, Leslie -- http://www.linkedin.com/in/polzer

1 0

[cl-prevalence-devel] News
by Leslie P. Polzer 26 Jul '09

26 Jul '09

Hello everyone, we've managed to set me up as co-maintainer for cl-prevalence. I intend to release the next version soon; it will be mostly a bugfix/cleanup release*. All changes made so far are here: http://bitbucket.org/skypher/cl-prevalence/ Anton, I've merged your CLISP changes. I can't merge Tomas Zellerin's PROBE-DIRECTORY fixes because I don't have write access to S-SYSDEPS. If someone would prepare a patch purely for cl-prevalence I'd likely commit it. Are there still CLISP people reading this? If yes then please test whether the version above works for you (excluding multi-processing). Tests from people using other implementations would be nice too. Cheers, Leslie * the larger fix for correct object references and identity will be part of a later release. -- http://www.linkedin.com/in/polzer

1 0

None
by None 12 Mar '09

12 Mar '09

1 0

[cl-prevalence-devel] CLISP patch
by Leslie P. Polzer 08 Feb '09

08 Feb '09

Anton, could you merge your patch with Tomas Zellerin's? His patch should also be separated into CLISP-specific and other parts. Leslie

2 1

[cl-prevalence-devel] what concurrency approach you use with cl-prevalence
by Anton Vodonosov 07 Feb '09

07 Feb '09

Hello everyone, Could you share your approach to concurrency in combination with cl-prevalence? As far as I understand, simultaneous transactions (IOW modifications) of the database are impossible, because all transactions use the same transaction log file and therefore must happen sequentially to avoid the transaction log corruption caused by concurrent writes. What about reading operations for persistent data? Has anyone implemented multiple-read/single write locking? Or you don't care and just user one global lock for all your database? Best regards, - Anton

1 0

[cl-prevalence-devel] clisp patch
by Anton Vodonosov 07 Feb '09

07 Feb '09

Hello. Attached is the patch (against CVS HEAD) for SERIALIZABLE-SLOTS methods for CLISP. I've just tried cl-prevalece. With this patch I can presist/load objects. Is porting of cl-prevalence as trivial as implementing these two methods? BTW, why these methods have #+sbcl conditionals two times? Best regards, - Anton

1 1

Re: [cl-prevalence-devel] Extending the serializer
by Leslie P. Polzer 03 Feb '09

03 Feb '09

> Is your branch going to be integrated with the mainline (perhaps you > should get commit permissions) or are you likely to maintain a > parallel branch that deals with weblocks integration issues? This branch contains changes that I'd like to see in the main repository. I intend to contribute more to cl-prevalence since it's a central component of some of my applications. I have asked Sven for commit access but he hasn't responded yet. He's probably not reading mail right now. In the meantime all my contributions will go into the hg branch, which is also easier to work with than CVS.

1 0

[cl-prevalence-devel] Extending the serializer
by Ian Eslick 03 Feb '09

03 Feb '09

I've extended cl-prevalence slightly to support some custom serialization and deserialization of user data types. The attached diff contains a patch that allows users to hook into the serialization protocol at the appropriate places. Here is an example of how to hook into the protocol. The last two functions (of 3) were added in the diff. ;; Serializer support for persistent objects (defmethod s-serialization::serialize-xml-internal ((object persistent) stream serialization-state) (declare (ignore serialization-state)) (write-string "<PERSISTENT ID=\"" stream) (prin1 (oid object) stream) (write-string "\"/>" stream)) (defmethod s-serialization::deserialize-xml-new-element-aux ((name (eql :persistent)) attributes) (elephant::controller-recreate-instance *store-controller* (parse-integer (s-serialization::get-attribute-value :id attributes)))) ;; Not needed in this app: ;; (defgeneric deserialize-xml-finish-element-aux ((name (eql :persistent)) attributes parent-seed seed) ;; seed) Regards, Ian

2 2

[cl-prevalence-devel] Fix for object cross-references
by Leslie P. Polzer 29 Jan '09

29 Jan '09

Attached is an experimental fix for sane object cross-references[1] Please test it (and possibly add an appropriate test case for it to the suite), everyone. It works fine for me so far. Leslie [1] http://common-lisp.net/pipermail/cl-prevalence-devel/2008-March/000097.html -- LinkedIn Profile: http://www.linkedin.com/in/polzer Xing Profile: https://www.xing.com/profile/LeslieP_Polzer Blog: http://blog.viridian-project.de/

1 0

[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

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

cl-prevalence-devel