cl-prevalence-cvs January 2006

cl-prevalence-cvs@common-lisp.net

1 participants
9 discussions

[cl-prevalence-cvs] CVS cl-prevalence
by scaekenberghe 31 Jan '06

31 Jan '06

Update of /project/cl-prevalence/cvsroot/cl-prevalence In directory common-lisp:/tmp/cvs-serv12270 Modified Files: ChangeLog Log Message: added patches and tests contributed by Henrik Hjelte (henrik(a)evahjelte.com) to (de)serialize improper lists and conses --- /project/cl-prevalence/cvsroot/cl-prevalence/ChangeLog 2006/01/31 12:41:48 1.3 +++ /project/cl-prevalence/cvsroot/cl-prevalence/ChangeLog 2006/01/31 12:41:54 1.4 @@ -1,6 +1,6 @@ 2006-01-31 Sven Van Caekenberghe <svc(a)mac.com> - * added patches contributed by Henrik Hjelte (henrik(a)evahjelte.com) to (de)serialize improper lists and conses + * added patches and tests contributed by Henrik Hjelte (henrik(a)evahjelte.com) to (de)serialize improper lists and conses 2005-01-22 Sven Van Caekenberghe <svc(a)mac.com>

1 0

[cl-prevalence-cvs] CVS cl-prevalence/test
by scaekenberghe 31 Jan '06

31 Jan '06

Update of /project/cl-prevalence/cvsroot/cl-prevalence/test In directory common-lisp:/tmp/cvs-serv12214/test Modified Files: test-prevalence.lisp test-serialization.lisp Log Message: added patches and tests contributed by Henrik Hjelte (henrik(a)evahjelte.com) to (de)serialize improper lists and conses --- /project/cl-prevalence/cvsroot/cl-prevalence/test/test-prevalence.lisp 2004/10/05 11:35:30 1.3 +++ /project/cl-prevalence/cvsroot/cl-prevalence/test/test-prevalence.lisp 2006/01/31 12:41:48 1.4 @@ -1,6 +1,6 @@ ;;;; -*- mode: Lisp -*- ;;;; -;;;; $Id: test-prevalence.lisp,v 1.3 2004/10/05 11:35:30 scaekenberghe Exp $ +;;;; $Id: test-prevalence.lisp,v 1.4 2006/01/31 12:41:48 scaekenberghe Exp $ ;;;; ;;;; Testing Object Prevalence in Common Lisp ;;;; @@ -39,7 +39,7 @@ (defun tx-create-person (system firstname lastname) (let* ((persons (get-root-object system :persons)) - (id (tx-get-next-id system)) + (id (next-id system)) (person (make-instance 'person :id id :firstname firstname :lastname lastname))) (setf (gethash id persons) person))) --- /project/cl-prevalence/cvsroot/cl-prevalence/test/test-serialization.lisp 2005/01/24 10:04:18 1.4 +++ /project/cl-prevalence/cvsroot/cl-prevalence/test/test-serialization.lisp 2006/01/31 12:41:48 1.5 @@ -1,6 +1,6 @@ ;;;; -*- mode: Lisp -*- ;;;; -;;;; $Id: test-serialization.lisp,v 1.4 2005/01/24 10:04:18 scaekenberghe Exp $ +;;;; $Id: test-serialization.lisp,v 1.5 2006/01/31 12:41:48 scaekenberghe Exp $ ;;;; ;;;; Testing XML and S-Expression based Serialization for Common Lisp and CLOS ;;;; @@ -168,6 +168,56 @@ (equal (serialize-and-deserialize-sexp (list 1 2 3)) (list 1 2 3))) +(assert + (equal (serialize-and-deserialize-xml (cons 1 2)) + (cons 1 2))) + +(assert + (equal (serialize-and-deserialize-sexp (cons 1 2)) + (cons 1 2))) + +(assert + (equal (serialize-and-deserialize-xml '(1 2 3 4 5 6 7 8 9 . 0)) + '(1 2 3 4 5 6 7 8 9 . 0))) + +(assert + (equal (serialize-and-deserialize-sexp '(1 2 3 4 5 6 7 8 9 . 0)) + '(1 2 3 4 5 6 7 8 9 . 0))) + +(assert + (equal (serialize-and-deserialize-xml (cons 'hi 2)) + (cons 'hi 2))) + +(assert + (equal (serialize-and-deserialize-sexp (cons 'hi 2)) + (cons 'hi 2))) + +(defun circular-list (&rest elements) + (let ((cycle (copy-list elements))) + (nconc cycle cycle))) + +(assert + (equal (third (serialize-and-deserialize-sexp (circular-list 'a 'b))) + 'a)) +(assert + (equal (third (serialize-and-deserialize-xml (circular-list 'a 'b))) + 'a)) + +(assert + (equal (serialize-and-deserialize-xml (cons 'hi 2)) + (cons 'hi 2))) + +(assert + (equal (serialize-and-deserialize-sexp (cons 'hi 2)) + (cons 'hi 2))) + +(assert + (equal (third (serialize-and-deserialize-sexp (circular-list 'a 'b))) + 'a)) +(assert + (equal (third (serialize-and-deserialize-xml (circular-list 'a 'b))) + 'a)) + ;; simple objects (defclass foobar ()

1 0

[cl-prevalence-cvs] CVS cl-prevalence
by scaekenberghe 31 Jan '06

31 Jan '06

Update of /project/cl-prevalence/cvsroot/cl-prevalence In directory common-lisp:/tmp/cvs-serv12214 Modified Files: ChangeLog Log Message: added patches and tests contributed by Henrik Hjelte (henrik(a)evahjelte.com) to (de)serialize improper lists and conses --- /project/cl-prevalence/cvsroot/cl-prevalence/ChangeLog 2005/01/24 10:04:14 1.2 +++ /project/cl-prevalence/cvsroot/cl-prevalence/ChangeLog 2006/01/31 12:41:48 1.3 @@ -1,3 +1,7 @@ +2006-01-31 Sven Van Caekenberghe <svc(a)mac.com> + + * added patches contributed by Henrik Hjelte (henrik(a)evahjelte.com) to (de)serialize improper lists and conses + 2005-01-22 Sven Van Caekenberghe <svc(a)mac.com> * added serialization support for characters (suggested by ian eslick)

1 0

[cl-prevalence-cvs] CVS cl-prevalence/src
by scaekenberghe 31 Jan '06

31 Jan '06

Update of /project/cl-prevalence/cvsroot/cl-prevalence/src In directory common-lisp:/tmp/cvs-serv12214/src Modified Files: serialization.lisp Log Message: added patches and tests contributed by Henrik Hjelte (henrik(a)evahjelte.com) to (de)serialize improper lists and conses --- /project/cl-prevalence/cvsroot/cl-prevalence/src/serialization.lisp 2005/01/24 10:04:15 1.9 +++ /project/cl-prevalence/cvsroot/cl-prevalence/src/serialization.lisp 2006/01/31 12:41:48 1.10 @@ -1,6 +1,6 @@ ;;;; -*- mode: Lisp -*- ;;;; -;;;; $Id: serialization.lisp,v 1.9 2005/01/24 10:04:15 scaekenberghe Exp $ +;;;; $Id: serialization.lisp,v 1.10 2006/01/31 12:41:48 scaekenberghe Exp $ ;;;; ;;;; XML and S-Expression based Serialization for Common Lisp and CLOS ;;;; @@ -244,51 +244,88 @@ (declare (ignore serialization-state)) (print-symbol object stream)) +(defun sequence-type-and-length(sequence) + (if (listp sequence) + (handler-case + (let ((length (list-length sequence))) + (if length + (values :proper-list length) + (values :circular-list nil))) + (type-error () + (values :dotted-list nil))) + (values :proper-sequence (length sequence)))) + (defmethod serialize-xml-internal ((object sequence) 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 "<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 object) stream) - (write-string "\">" stream) - (map nil - #'(lambda (element) - (serialize-xml-internal element stream serialization-state)) - object) - (write-string "</SEQUENCE>" stream))))) + (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) - (let ((id (known-object-id serialization-state object))) - (if id - (progn - (write-string "(:REF . " stream) - (prin1 id stream) - (write-string ")" stream)) - (let ((length (length object))) - (setf 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))))) + (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) (let ((id (known-object-id serialization-state object))) @@ -297,23 +334,23 @@ (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))))) + (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))) @@ -322,28 +359,28 @@ (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))))) + (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))))) (defmethod serialize-xml-internal ((object structure-object) stream serialization-state) (let ((id (known-object-id serialization-state object))) @@ -456,6 +493,9 @@ (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*) @@ -483,24 +523,28 @@ (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)))) - (:object (let* ((id (parse-integer (get-attribute-value :id attributes))) - (object (gethash id *deserialized-objects*))) - (dolist (pair seed object) + (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) + (: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)) + (: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)) @@ -509,40 +553,46 @@ (defun deserialize-sexp-internal (sexp deserialized-objects) (if (atom sexp) sexp - (ecase (first sexp) - (:sequence (destructuring-bind (id &key class size elements) (rest sexp) - (let ((sequence (make-sequence class size))) - (setf (gethash id deserialized-objects) sequence) - (map-into sequence - #'(lambda (x) (deserialize-sexp-internal x deserialized-objects)) - elements)))) - (:hash-table (destructuring-bind (id &key test size rehash-size rehash-threshold entries) (rest sexp) - (let ((hash-table (make-hash-table :size size - :test test - :rehash-size rehash-size - :rehash-threshold rehash-threshold))) - (setf (gethash id deserialized-objects) hash-table) - (dolist (entry entries) - (setf (gethash (deserialize-sexp-internal (first entry) deserialized-objects) hash-table) - (deserialize-sexp-internal (rest entry) deserialized-objects))) - hash-table))) - (:object (destructuring-bind (id &key class slots) (rest sexp) - (let ((object (make-instance class))) - (setf (gethash id deserialized-objects) object) - (dolist (slot slots) - (when (slot-exists-p object (first slot)) - (setf (slot-value object (first slot)) - (deserialize-sexp-internal (rest slot) deserialized-objects)))) - object))) - (:struct (destructuring-bind (id &key class slots) (rest sexp) - (let ((object (funcall (intern (concatenate 'string "MAKE-" (symbol-name class)) - (symbol-package class))))) - (setf (gethash id deserialized-objects) object) - (dolist (slot slots) - (when (slot-exists-p object (first slot)) - (setf (slot-value object (first slot)) - (deserialize-sexp-internal (rest slot) deserialized-objects)))) - object))) - (:ref (gethash (rest sexp) deserialized-objects))))) + (ecase (first sexp) + (:sequence (destructuring-bind (id &key class size elements) (rest sexp) + (let ((sequence (make-sequence class size))) + (setf (gethash id deserialized-objects) sequence) + (map-into sequence + #'(lambda (x) (deserialize-sexp-internal x deserialized-objects)) + elements)))) + (:hash-table (destructuring-bind (id &key test size rehash-size rehash-threshold entries) (rest sexp) + (let ((hash-table (make-hash-table :size size + :test test + :rehash-size rehash-size + :rehash-threshold rehash-threshold))) + (setf (gethash id deserialized-objects) hash-table) + (dolist (entry entries) + (setf (gethash (deserialize-sexp-internal (first entry) deserialized-objects) hash-table) + (deserialize-sexp-internal (rest entry) deserialized-objects))) + hash-table))) + (:object (destructuring-bind (id &key class slots) (rest sexp) + (let ((object (make-instance class))) + (setf (gethash id deserialized-objects) object) + (dolist (slot slots) + (when (slot-exists-p object (first slot)) + (setf (slot-value object (first slot)) + (deserialize-sexp-internal (rest slot) deserialized-objects)))) + object))) + (:struct (destructuring-bind (id &key class slots) (rest sexp) + (let ((object (funcall (intern (concatenate 'string "MAKE-" (symbol-name class)) + (symbol-package class))))) + (setf (gethash id deserialized-objects) object) + (dolist (slot slots) + (when (slot-exists-p object (first slot)) + (setf (slot-value object (first slot)) + (deserialize-sexp-internal (rest slot) deserialized-objects)))) + object))) + (:cons (destructuring-bind (id cons-car cons-cdr) (rest sexp) + (let ((conspair (cons nil nil))) + (setf (gethash id deserialized-objects) + conspair) + (rplaca conspair (deserialize-sexp-internal cons-car deserialized-objects)) + (rplacd conspair (deserialize-sexp-internal cons-cdr deserialized-objects))))) + (:ref (gethash (rest sexp) deserialized-objects))))) ;;;; eof

1 0

[cl-prevalence-cvs] CVS update: cl-prevalence/src/master-slave.lisp cl-prevalence/src/prevalence.lisp cl-prevalence/src/sysdeps.lisp
by scaekenberghe＠common-lisp.net 09 Jan '06

09 Jan '06

Update of /project/cl-prevalence/cvsroot/cl-prevalence/src In directory common-lisp.net:/tmp/cvs-serv20683/src Modified Files: master-slave.lisp prevalence.lisp Removed Files: sysdeps.lisp Log Message: now using S-SYSDEPS Date: Mon Jan 9 20:21:45 2006 Author: scaekenberghe Index: cl-prevalence/src/master-slave.lisp diff -u cl-prevalence/src/master-slave.lisp:1.1 cl-prevalence/src/master-slave.lisp:1.2 --- cl-prevalence/src/master-slave.lisp:1.1 Mon Jun 28 13:57:30 2004 +++ cl-prevalence/src/master-slave.lisp Mon Jan 9 20:21:44 2006 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: master-slave.lisp,v 1.1 2004/06/28 11:57:30 scaekenberghe Exp $ +;;;; $Id: master-slave.lisp,v 1.2 2006/01/09 19:21:44 scaekenberghe Exp $ ;;;; ;;;; The master-slave system keeps one prevalence system in sync with another ;;;; by sending transactions over a socket @@ -16,7 +16,7 @@ (defun start-master-client (prevalence-system &key (host "localhost") (port 7651)) "Start a connection to host:port to deliver transactions from prevalence-system" (stop-master-client prevalence-system) - (let ((out (open-socket-stream host port))) + (let ((out (s-sysdeps:open-socket-stream host port))) (setf (get-transaction-hook prevalence-system) #'(lambda (transaction) (funcall (get-serializer prevalence-system) @@ -38,7 +38,7 @@ (defun start-slave-server (prevalence-system &key (port 7651)) "Start a server on port accepting transactions to be executed on prevalence-system" - (start-standard-server + (s-sysdeps:start-standard-server :port port :name "prevalence-slave-server" :connection-handler #'(lambda (stream) @@ -50,9 +50,5 @@ (eq transaction :stop)) (return) (execute prevalence-system transaction))))))) - -(defun stop-slave-server (name) - "Stop a slave server by name" - (stop-server name)) ;;;; eof Index: cl-prevalence/src/prevalence.lisp diff -u cl-prevalence/src/prevalence.lisp:1.7 cl-prevalence/src/prevalence.lisp:1.8 --- cl-prevalence/src/prevalence.lisp:1.7 Mon Oct 4 16:25:13 2004 +++ cl-prevalence/src/prevalence.lisp Mon Jan 9 20:21:44 2006 @@ -1,6 +1,6 @@ ;;;; -*- mode: Lisp -*- ;;;; -;;;; $Id: prevalence.lisp,v 1.7 2004/10/04 14:25:13 scaekenberghe Exp $ +;;;; $Id: prevalence.lisp,v 1.8 2006/01/09 19:21:44 scaekenberghe Exp $ ;;;; ;;;; Object Prevalence in Common Lisp ;;;; @@ -169,7 +169,7 @@ "Totally destroy system from permanent storage by deleting any files used by the system, remove all root objects" (close-open-streams system :abort abort) (when (probe-file (get-directory system)) - (dolist (pathname (directory (merge-pathnames (make-pathname :type (get-file-extension system)) + (dolist (pathname (directory (merge-pathnames (make-pathname :name :wild :type (get-file-extension system)) (get-directory system)))) (delete-file pathname))) (clrhash (get-root-objects system)))

1 0

[cl-prevalence-cvs] CVS update: cl-prevalence/cl-prevalence.asd
by scaekenberghe＠common-lisp.net 09 Jan '06

09 Jan '06

Update of /project/cl-prevalence/cvsroot/cl-prevalence In directory common-lisp.net:/tmp/cvs-serv20683 Modified Files: cl-prevalence.asd Log Message: now using S-SYSDEPS Date: Mon Jan 9 20:21:43 2006 Author: scaekenberghe Index: cl-prevalence/cl-prevalence.asd diff -u cl-prevalence/cl-prevalence.asd:1.3 cl-prevalence/cl-prevalence.asd:1.4 --- cl-prevalence/cl-prevalence.asd:1.3 Thu Jan 5 15:08:22 2006 +++ cl-prevalence/cl-prevalence.asd Mon Jan 9 20:21:43 2006 @@ -1,6 +1,6 @@ ;;;; -*- Mode: LISP -*- ;;;; -;;;; $Id: cl-prevalence.asd,v 1.3 2006/01/05 14:08:22 scaekenberghe Exp $ +;;;; $Id: cl-prevalence.asd,v 1.4 2006/01/09 19:21:43 scaekenberghe Exp $ ;;;; ;;;; The CL-PREVALENCE ASDF system definition ;;;; @@ -29,9 +29,8 @@ (:file "serialization" :depends-on ("package")) (:file "prevalence" :depends-on ("serialization")) (:file "managed-prevalence" :depends-on ("prevalence")) - (:file "sysdeps" :depends-on ("package")) - (:file "master-slave" :depends-on ("prevalence" "sysdeps")) + (:file "master-slave" :depends-on ("prevalence")) (:file "blob" :depends-on ("managed-prevalence"))))) - :depends-on (:s-xml)) + :depends-on (:s-xml :s-sysdeps)) ;;;; eof

1 0

[cl-prevalence-cvs] CVS update: cl-prevalence/src/managed-prevalence.lisp
by scaekenberghe＠common-lisp.net 05 Jan '06

05 Jan '06

Update of /project/cl-prevalence/cvsroot/cl-prevalence/src In directory common-lisp.net:/tmp/cvs-serv27807/src Modified Files: managed-prevalence.lisp Log Message: changed signature Date: Thu Jan 5 15:08:52 2006 Author: scaekenberghe Index: cl-prevalence/src/managed-prevalence.lisp diff -u cl-prevalence/src/managed-prevalence.lisp:1.4 cl-prevalence/src/managed-prevalence.lisp:1.5 --- cl-prevalence/src/managed-prevalence.lisp:1.4 Mon Feb 14 21:20:02 2005 +++ cl-prevalence/src/managed-prevalence.lisp Thu Jan 5 15:08:50 2006 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: managed-prevalence.lisp,v 1.4 2005/02/14 20:20:02 scaekenberghe Exp $ +;;;; $Id: managed-prevalence.lisp,v 1.5 2006/01/05 14:08:50 scaekenberghe Exp $ ;;;; ;;;; The code in this file adds another layer above plain object prevalence. ;;;; We manage objects with ids in an organized fashion, adding an id counter and preferences. @@ -58,7 +58,7 @@ (when index (gethash id index)))) -(defgeneric find-object-with-slot (system class slot value &optional (test #'equalp)) +(defgeneric find-object-with-slot (system class slot value &optional test) (:documentation "Find and return the object in system of class with slot equal to value, null if not found")) (defmethod find-object-with-slot ((system prevalence-system) class slot value &optional (test #'equalp))

1 0

[cl-prevalence-cvs] CVS update: cl-prevalence/cl-prevalence.asd
by scaekenberghe＠common-lisp.net 05 Jan '06

05 Jan '06

Update of /project/cl-prevalence/cvsroot/cl-prevalence In directory common-lisp.net:/tmp/cvs-serv27775 Modified Files: cl-prevalence.asd Log Message: s-xml::echo-xml is now optional; made debug-prevalence optional as well, noted dependency in a comment Date: Thu Jan 5 15:08:23 2006 Author: scaekenberghe Index: cl-prevalence/cl-prevalence.asd diff -u cl-prevalence/cl-prevalence.asd:1.2 cl-prevalence/cl-prevalence.asd:1.3 --- cl-prevalence/cl-prevalence.asd:1.2 Mon Jun 28 13:57:26 2004 +++ cl-prevalence/cl-prevalence.asd Thu Jan 5 15:08:22 2006 @@ -1,6 +1,6 @@ ;;;; -*- Mode: LISP -*- ;;;; -;;;; $Id: cl-prevalence.asd,v 1.2 2004/06/28 11:57:26 scaekenberghe Exp $ +;;;; $Id: cl-prevalence.asd,v 1.3 2006/01/05 14:08:22 scaekenberghe Exp $ ;;;; ;;;; The CL-PREVALENCE ASDF system definition ;;;; @@ -28,7 +28,6 @@ ((:file "package") (:file "serialization" :depends-on ("package")) (:file "prevalence" :depends-on ("serialization")) - (:file "debug-prevalence" :depends-on ("prevalence")) (:file "managed-prevalence" :depends-on ("prevalence")) (:file "sysdeps" :depends-on ("package")) (:file "master-slave" :depends-on ("prevalence" "sysdeps"))

1 0

[cl-prevalence-cvs] CVS update: cl-prevalence/src/debug-prevalence.lisp
by scaekenberghe＠common-lisp.net 05 Jan '06

05 Jan '06

Update of /project/cl-prevalence/cvsroot/cl-prevalence/src In directory common-lisp.net:/tmp/cvs-serv27775/src Modified Files: debug-prevalence.lisp Log Message: s-xml::echo-xml is now optional; made debug-prevalence optional as well, noted dependency in a comment Date: Thu Jan 5 15:08:24 2006 Author: scaekenberghe Index: cl-prevalence/src/debug-prevalence.lisp diff -u cl-prevalence/src/debug-prevalence.lisp:1.2 cl-prevalence/src/debug-prevalence.lisp:1.3 --- cl-prevalence/src/debug-prevalence.lisp:1.2 Mon Jul 5 23:22:08 2004 +++ cl-prevalence/src/debug-prevalence.lisp Thu Jan 5 15:08:24 2006 @@ -1,6 +1,6 @@ ;;;; -*- Mode: LISP -*- ;;;; -;;;; $Id: debug-prevalence.lisp,v 1.2 2004/07/05 21:22:08 scaekenberghe Exp $ +;;;; $Id: debug-prevalence.lisp,v 1.3 2006/01/05 14:08:24 scaekenberghe Exp $ ;;;; ;;;; Some debugging routines for CL-PREVALENCE ;;;; @@ -12,11 +12,13 @@ (in-package :cl-prevalence) +;; the code for #'s-xml::echo-xml is in "echo.lisp" in S-XML's test code + (defun print-transaction-log (system) "Echo the XML making up the transaction log of system to t" (with-open-file (in (get-transaction-log system) :direction :input) (loop - (let ((transaction (s-xml:echo-xml in *standard-output*))) + (let ((transaction (s-xml::echo-xml in *standard-output*))) (when (null transaction) (return))))) t) @@ -33,7 +35,7 @@ (defun print-snapshot (system) "Echo the XML making up the snapshot of system to t" (with-open-file (in (get-snapshot system) :direction :input) - (s-xml:echo-xml in *standard-output*)) + (s-xml::echo-xml in *standard-output*)) t) (defun transaction-log-tail (system &optional (count 8))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

cl-prevalence-cvs January 2006