February 2005 - cl-store-cvs@common-lisp.net

[cl-store-cvs] CVS update: cl-store/ChangeLog
by sross＠common-lisp.net 18 Feb '05

18 Feb '05

Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv23964 Modified Files: ChangeLog Log Message: Date: Fri Feb 18 14:51:15 2005 Author: sross Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.24 cl-store/ChangeLog:1.25 --- cl-store/ChangeLog:1.24 Fri Feb 18 09:15:49 2005 +++ cl-store/ChangeLog Fri Feb 18 14:51:14 2005 @@ -1,4 +1,5 @@ 2005-02-18 Sean Ross <sross(a)common-lisp.net> + Version 0.5 Release. * utils.lisp, package.lisp: Took a lesson from the MOP and changed serializable-slots to call the new GF serializable-slots-using-class.

1 0

[cl-store-cvs] CVS update: cl-store/doc/cl-store.texi
by sross＠common-lisp.net 18 Feb '05

18 Feb '05

Update of /project/cl-store/cvsroot/cl-store/doc In directory common-lisp.net:/tmp/cvs-serv15747/doc Modified Files: cl-store.texi Log Message: Changelog 2005-02-18 Date: Fri Feb 18 12:11:03 2005 Author: sross Index: cl-store/doc/cl-store.texi diff -u cl-store/doc/cl-store.texi:1.7 cl-store/doc/cl-store.texi:1.8 --- cl-store/doc/cl-store.texi:1.7 Fri Feb 18 09:50:09 2005 +++ cl-store/doc/cl-store.texi Fri Feb 18 12:11:03 2005 @@ -407,12 +407,44 @@ Stores @emph{object} into @emph{place}. This should be used inside @code{defstore-cl-store} to output parts of objects. @code{store} should not be used. - @end deffn + @anchor {Generic restore-object} @deffn {Generic} restore-object place Restore an object, written out using @code{store-object} from @emph{place}. @end deffn + +@anchor {Generic get-slot-details} +@deffn {Generic} get-slot-details slot-definition +Generic function which returns a list of slots details +which can be used as an argument to @code{ensure-class}. +Currently it is only specialized on slot-definition +@end deffn + +@anchor {Generic serializable-slots} +@deffn {Generic} serializable-slots object +Method which returns a list of slot-definition objects +which will be serialized for @emph{object}. The default +is to call @code{serializable-slots-using-class}. +@end deffn + +@anchor {Generic serializable-slots-using-class} +@deffn {Generic} serializable-slots-using-class object class +Returns a list of slot-definition objects which will +be serialized for object and class. +Example. +When serializing cl-sql objects to disk or to another +lisp session the view-database slot should not be serialized. +Instead of specializing serializable-slots for each view-class +created you can do this. +@lisp +(defmethod serializable-slots-using-class + ((object t) (class clsql-sys::standard-db-class)) + (delete 'clsql-sys::view-database (call-next-method) + :key 'slot-definition-name)) +@end lisp +@end deffn + @vskip 0pt plus 1filll

1 0

[cl-store-cvs] CVS update: cl-store/circularities.lisp cl-store/cl-store.asd cl-store/default-backend.lisp cl-store/plumbing.lisp cl-store/tests.lisp cl-store/utils.lisp
by sross＠common-lisp.net 18 Feb '05

18 Feb '05

Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv15747 Modified Files: circularities.lisp cl-store.asd default-backend.lisp plumbing.lisp tests.lisp utils.lisp Log Message: Changelog 2005-02-18 Date: Fri Feb 18 12:11:00 2005 Author: sross Index: cl-store/circularities.lisp diff -u cl-store/circularities.lisp:1.15 cl-store/circularities.lisp:1.16 --- cl-store/circularities.lisp:1.15 Fri Feb 11 13:00:31 2005 +++ cl-store/circularities.lisp Fri Feb 18 12:10:59 2005 @@ -19,6 +19,7 @@ ;; programs according to the Hyperspec(notes in EQ). (in-package :cl-store) +(declaim (optimize speed (debug 0) (safety 1))) (defvar *check-for-circs* t) @@ -30,7 +31,7 @@ (defun force (delay) (unless (delay-completed delay) - (setf (delay-value delay) (funcall (delay-value delay)) + (setf (delay-value delay) (funcall (the function (delay-value delay))) (delay-completed delay) t)) (delay-value delay)) Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.23 cl-store/cl-store.asd:1.24 --- cl-store/cl-store.asd:1.23 Fri Feb 18 09:20:10 2005 +++ cl-store/cl-store.asd Fri Feb 18 12:11:00 2005 @@ -40,7 +40,7 @@ :name "CL-STORE" :author "Sean Ross <sdr(a)jhb.ucs.co.za>" :maintainer "Sean Ross <sdr(a)jhb.ucs.co.za>" - :version "0.4.18" + :version "0.5" :description "Serialization package" :long-description "Portable CL Package to serialize data types" :licence "MIT" Index: cl-store/default-backend.lisp diff -u cl-store/default-backend.lisp:1.22 cl-store/default-backend.lisp:1.23 --- cl-store/default-backend.lisp:1.22 Fri Feb 18 09:15:49 2005 +++ cl-store/default-backend.lisp Fri Feb 18 12:11:00 2005 @@ -4,6 +4,8 @@ ;; The cl-store backend. (in-package :cl-store) +(declaim (optimize speed (debug 0) (safety 1))) + (defbackend cl-store :magic-number 1349740876 :stream-type '(unsigned-byte 8) :old-magic-numbers (1912923 1886611788 1347635532 1886611820 @@ -183,7 +185,7 @@ (store-object sign stream))))) (defrestore-cl-store (float stream) - (float (* (get-float-type (read-byte stream)) + (float (* (the float (get-float-type (read-byte stream))) (* (the integer (restore-object stream)) (expt (the integer (restore-object stream)) (the integer (restore-object stream)))) @@ -545,6 +547,7 @@ (store-object (external-symbols obj) stream)) (defun remove-remaining (times stream) + (declare (type fixnum times)) (dotimes (x times) (restore-object stream))) Index: cl-store/plumbing.lisp diff -u cl-store/plumbing.lisp:1.11 cl-store/plumbing.lisp:1.12 --- cl-store/plumbing.lisp:1.11 Wed Feb 16 13:40:24 2005 +++ cl-store/plumbing.lisp Fri Feb 18 12:11:00 2005 @@ -6,6 +6,8 @@ (in-package :cl-store) +(declaim (optimize speed (debug 0) (safety 1))) + (defvar *store-used-packages* nil "If non-nil will serialize each used package otherwise will only store the package name") Index: cl-store/tests.lisp diff -u cl-store/tests.lisp:1.15 cl-store/tests.lisp:1.16 --- cl-store/tests.lisp:1.15 Wed Feb 16 13:40:24 2005 +++ cl-store/tests.lisp Fri Feb 18 12:11:00 2005 @@ -502,8 +502,7 @@ (deftestit gfunction.1 #'cl-store:restore) (deftestit gfunction.2 #'cl-store:store) -#-(or clisp openmcl) -(deftestit gfunction.3 #'(setf cl-store:restore)) + (deftest nocirc.1 (let* ((string "FOO") Index: cl-store/utils.lisp diff -u cl-store/utils.lisp:1.13 cl-store/utils.lisp:1.14 --- cl-store/utils.lisp:1.13 Fri Feb 18 09:15:49 2005 +++ cl-store/utils.lisp Fri Feb 18 12:11:00 2005 @@ -92,7 +92,8 @@ (defun store-32-bit (obj stream) "Write OBJ down STREAM as a 32 bit integer." - (declare (optimize speed)) + (declare (optimize speed (debug 0) (safety 1)) + (type sb32 obj)) (let ((obj (logand #XFFFFFFFF obj))) (write-byte (ldb (byte 8 0) obj) stream) (write-byte (ldb (byte 8 8) obj) stream) @@ -104,7 +105,7 @@ (defun read-32-bit (buf &optional (signed t)) "Read a signed or unsigned byte off STREAM." - (declare (optimize speed)) + (declare (optimize speed (debug 0) (safety 1))) (let ((byte1 (read-byte buf)) (byte2 (read-byte buf)) (byte3 (read-byte buf))

1 0

[cl-store-cvs] CVS update: cl-store/doc/cl-store.texi
by sross＠common-lisp.net 18 Feb '05

18 Feb '05

Update of /project/cl-store/cvsroot/cl-store/doc In directory common-lisp.net:/tmp/cvs-serv5237 Modified Files: cl-store.texi Log Message: Updated Manual Date: Fri Feb 18 09:50:09 2005 Author: sross Index: cl-store/doc/cl-store.texi diff -u cl-store/doc/cl-store.texi:1.6 cl-store/doc/cl-store.texi:1.7 --- cl-store/doc/cl-store.texi:1.6 Tue Feb 1 09:27:40 2005 +++ cl-store/doc/cl-store.texi Fri Feb 18 09:50:09 2005 @@ -79,9 +79,10 @@ the same purpose as Java's ObjectOutput and ObjectInputStream, although it's somewhat more extensible. -The CL-STORE Home Page is at @uref{http://www.common-lisp.net/project/cl-store} -where one can find details about mailing lists, cvs repositories (I hope i spelled that -right) and various releases. +The CL-STORE Home Page is at @uref{http://common-lisp.net/project/cl-store} +where one can find details about mailing lists, cvs repositories and various releases. + +This documentation is for CL-STORE version 0.5 . Enjoy Sean. @@ -120,6 +121,7 @@ @item Lispworks @item Allegro CL @item OpenMCL +@item ECL @end itemize @@ -146,7 +148,7 @@ @item DOWNLOAD -The latest cl-store release will always be available from @uref{http://www.common-lisp.net,,cl.net}. +The latest cl-store release will always be available from @uref{http://common-lisp.net,,cl.net}. Download and untar in an appropriate directory then symlink @file{cl-store.asd} to a directory on @code{asdf:*central-registry*} (see the documentation for asdf for details about setting up asdf). @@ -154,8 +156,8 @@ @item CVS If you feel the need to be on the bleeding edge you can use -anonymous CVS access, see the @uref{http://www.common-lisp.net/project/cl-store,,Home Page} - for more details for accessing the archive. Once downloaded follow the symlink instructions above. +anonymous CVS access, see the @uref{http://common-lisp.net/project/cl-store,,Home Page} +for more details for accessing the archive. Once downloaded follow the symlink instructions above. @end itemize @@ -201,6 +203,21 @@ @end deftp +@anchor {Variable *nuke-existing-packages*} +@vindex *nuke-existing-packages* +@deftp {Variable} *nuke-existing-packages* @emph{Default NIL} +If @code{*nuke-existing-packages*} is non-nil then packages which +already exist will be deleted when restoring packages. +@end deftp + +@anchor {Variable *store-used-packages*} +@vindex *store-used-packages* +@deftp {Variable} *store-used-packages* @emph{Default NIL} +The variable determines the how packages on a package use +list will be serialized. If non-nil the the package will +be fully serialized, otherwise only the name will be stored. +@end deftp + @anchor {Variable *store-hash-size*} @vindex *store-hash-size* @deftp {Variable} *store-hash-size* @emph{Default 1000} @@ -232,21 +249,13 @@ your data (eg spam-filter hash-tables). @end deftp - @anchor {Variable *default-backend*} @vindex *default-backend* -@deftp {Variable} *default-backend* @emph{Default *cl-store-backend*} +@deftp {Variable} *default-backend* The backend that will be used by default. @end deftp -@anchor {Variable *cl-store-backend*} -@vindex *cl-store-backend* -@deftp {Variable} *cl-store-backend* -The CL-STORE Backend. -@end deftp - - @section Functions @anchor {Generic store} @deffn {Generic} store object place &optional (backend *default-backend*) @@ -282,22 +291,10 @@ @section Macros -@anchor {Macro multiple-value-store} -@deffn {Macro} multiple-value-store form place &optional (backend *default-backend*) -Stores all values returned by @emph{form} into @emph{place} using @emph{backend}. -As usual @emph{place} must be @code{stream} or a @code{pathname-designator}. -Restoring values stored using @code{multiple-value-store} will return all values. -eg. -@lisp -(multiple-value-store (values 1 2 3) "/tmp/values.out") -(restore "/tmp/values.out") -=> 1, 2, 3 -@end lisp -@end deffn - @anchor {Macro with-backend} @deffn {Macro} with-backend backend &body body -Execute @emph{body} with @code{*default-backend*} bound to @emph{backend}. +Execute @emph{body} with @code{*default-backend*} bound to the +backend designated by @emph{backend}. @end deffn @@ -345,7 +342,7 @@ (use-package :cl-store) -(setf *default-backend* *cl-store-backend*) +(setf *default-backend* (find-backend 'cl-store)) ;; Create the custom class (defclass random-obj () ((a :accessor a :initarg :a))) @@ -381,11 +378,11 @@ @subsection Functions @anchor {Function register-code} -@deffn {Function} register-code name &optional (errorp t) +@deffn {Function} register-code code name &optional (errorp t) Registers @emph{name} under the code @emph{code} into the cl-store-backend. The backend will use this mapping when restoring values. Will signal an error if code is already registered and @emph{errorp} is not NIL. -Currently codes 1 through 25 are in use. +Currently codes 1 through 33 are in use. @end deffn @anchor {Function output-type-code} @@ -406,7 +403,7 @@ @end deffn @anchor {Generic store-object} -@deffn {Generic} store-object object place +@deffn {Generic} store-object object place Stores @emph{object} into @emph{place}. This should be used inside @code{defstore-cl-store} to output parts of objects. @code{store} should not be used. @@ -427,19 +424,13 @@ is stored using @code{store-object} with @emph{var} bound to the object to be stored and @emph{stream} bound to the stream to output to. If @emph{qualifier} is given it must be a legal qualifier to @code{defmethod}. -Example Expansion. +Example. @lisp (defstore-cl-store (obj ratio stream) (output-type-code +ratio-code+ stream) (store-object (numerator obj) stream) (store-object (denominator obj) stream)) -== - -(defmethod internal-store-object ((obj ratio) stream (backend cl-store-backend)) - (output-type-code +ratio-code+ stream) - (store-object (numerator obj) stream) - (store-object (denominator obj) stream)) @end lisp @end deffn @@ -449,21 +440,11 @@ registered using @code{register-code}.@emph{Body} will be executed with @emph{stream} being the input stream to restore an object from. -Example Expansion. +Example. @lisp (defrestore-cl-store (ratio stream) (/ (restore-object stream) (restore-object stream))) - -== - -(flet ((#:cl-store-ratio4109 (stream) - (/ (restore-object stream) (restore-object stream)))) - (let* ((backend (find-backend 'cl-store)) - (restorers (restorer-funs backend))) - (when (gethash 'ratio restorers) - (warn "redefining restorer ~a for backend ~(~a~)" 'ratio (name backend))) - (setf (gethash 'ratio restorers) #'#:cl-store-ratio4109))) @end lisp @end deffn @@ -530,11 +511,6 @@ @end lisp @end deffn -@subsection Variables -@anchor {Variable *postfix-setters*} -@deftp {Variable} *postfix-setters* @emph{Default (gethash)} -Setfable places which take the object to set after all other arguments. -@end deftp @node New Backends @chapter New Backends @@ -557,7 +533,7 @@ eg. (from the cl-store-backend) @lisp (defbackend cl-store :magic-number 1347643724 - :stream-type 'binary + :stream-type '(unsigned-byte 8) :old-magic-numbers (1912923 1886611788 1347635532) :extends resolving-backend :fields ((restorers :accessor restorers :initform (make-hash-table)))) @@ -575,6 +551,7 @@ eg. (from the cl-store-backend) @lisp +(defvar *cl-store-backend* (find-backend 'cl-store)) ;; This is a util method to register the code with a symbol (defun register-code (code name &optional (errorp t)) (aif (and (gethash code (restorers *cl-store-backend*)) errorp) @@ -586,7 +563,7 @@ (defconstant +ratio-code+ (register-code 7 'ratio)) ;; Extending the get-next-reader method -(defmethod get-next-reader ((stream stream) (backend cl-store-backend)) +(defmethod get-next-reader ((backend cl-store) (stream stream)) (let ((type-code (read-type-code stream))) (or (gethash type-code (restorers backend)) (values nil (format nil "Type ~A" type-code))))) @@ -609,10 +586,10 @@ done you can use @code{resolving-object} and @code{setting} to resolve circularities in objects. -eg (from the cl-store-backend) +eg (from the cl-store backend) @lisp (defconstant +referrer-code+ (register-code 1 'referrer nil)) -(defmethod store-referrer (ref stream (backend cl-store-backend)) +(defmethod store-referrer (ref stream (backend cl-store)) (output-type-code +referrer-code+ stream) (store-32-bit ref stream)) @@ -629,7 +606,7 @@ (in-package :cl-user) (use-package :cl-store) -(defbackend pickle :stream-type 'char) +(defbackend pickle :stream-type 'character) @end lisp @vskip 0pt plus 2filll @@ -641,7 +618,7 @@ (defvar *pickle-mapping* '((#\S . string))) -(defmethod get-next-reader ((stream stream) (backend pickle-backend)) +(defmethod get-next-reader ((backend pickle) (stream stream)) (let ((type-code (read-char stream))) (or (cdr (assoc type-code *pickle-mapping*)) (values nil (format nil "Type ~A" type-code))))) @@ -666,12 +643,12 @@ >>> pickle.dump('Foobar', open('/tmp/foo.p', 'w')) Lisp -* (cl-store:restore "/tmp/foo.p" (find-backend 'pickle)) +* (cl-store:restore "/tmp/foo.p" 'pickle) => "Foobar" And Lisp -* (cl-store:store "BarFoo" "/tmp/foo.p" (find-backend 'pickle)) +* (cl-store:store "BarFoo" "/tmp/foo.p" 'pickle) Python >>> pickle.load(open('/tmp/foo.p')) @@ -684,33 +661,33 @@ @subsection Functions @anchor {Generic backend-restore} -@deffn {Generic} backend-restore place backend +@deffn {Generic} backend-restore backend place Restore the object found in stream @emph{place} using backend @emph{backend}. Checks the magic-number and invokes @code{backend-restore-object}. Called by @code{restore}, override for custom restoring. @end deffn @anchor {Generic backend-restore-object} -@deffn {Generic} backend-restore place backend +@deffn {Generic} backend-restore backend place Find the next function to call to restore the next object with @emph{backend} and invoke it with @emph{place}. Called by @code{restore-object}, override this method to do custom restoring (see @file{circularities.lisp} for an example). @end deffn @anchor {Generic backend-store} -@deffn {Generic} backend-store obj place backend +@deffn {Generic} backend-store backend place obj Stores the backend code and calls @code{store-object}. This is called by @code{store}. Override for custom storing. @end deffn @anchor {Generic backend-store-object} -@deffn {Generic} backend-store-object obj place backend +@deffn {Generic} backend-store-object backend obj place Called by @code{store-object}, override this to do custom storing (see @file{circularities.lisp} for an example). @end deffn @anchor {Generic get-next-reader} -@deffn {Generic} get-next-reader place backend +@deffn {Generic} get-next-reader backend place Method which must be specialized for @emph{backend} to return the next symbol designating a @code{defrestore} instance to restore an object from @emph{place}. If no reader is found return a second value which will be included in the error. @@ -720,9 +697,9 @@ @subsection Macros @anchor {Macro defbackend} @deffn {Macro} defbackend name &key (stream-type (required-arg "stream-type")) magic-number fields (extends 'backend) old-magic-numbers -eg. @lisp (defbackend pickle :stream-type 'char) @end lisp +eg. @lisp (defbackend pickle :stream-type 'character) @end lisp This creates a new backend called @emph{name}, @emph{stream-type} describes the type of stream that the -backend will serialize to, currently one of 'binary or 'char. @emph{Magic-number}, when present, must be of type +backend will serialize to which must be suitable as an argument to open. @emph{Magic-number}, when present, must be of type (unsigned-byte 32) which will be written as a verifier for the backend. @emph{Fields} are extra fields to be added to the new class which will be created. By default the @emph{extends} keyword is @emph{backend},the root backend, but this can be any legal backend. @emph{Old-magic-numbers} holds previous magic-numbers that have been used by the backend @@ -732,11 +709,18 @@ @node Notes @chapter Notes +@section Backend Designators +The @emph{backend} argument to store, restore and with-backend +is a backend designator which can be one of. +@itemize @bullet +@item A backend returned by @code{(find-backend name)} +@item A symbol designating a backend (the first argument to defbackend). +@end itemize + @section Known Issues @itemize @bullet @item CLISP, OpenMCL, Allegro CL cannot store structure instances. @item Structure definitions are only supported in SBCL and CMUCL. -@item MOP classes aren't supported. @item Due to the fact that function's aren't fully supported CLOS Classes initfunction slot cannot be serialized. @end itemize @@ -747,6 +731,7 @@ @item Common-Lisp.net: For project hosting. @item Alain Picard : Structure Storing and support for Infinite Floats for Lispworks. @item Robert Sedgewick: Package Imports for OpenMCL and suggesting Multiple Backends. +@item Thomas Stenhaug: Comprehensive package storing and miscellaneous improvements. @end itemize @node Index

1 0

[cl-store-cvs] CVS update: cl-store/ecl/.cvsignore
by sross＠common-lisp.net 18 Feb '05

18 Feb '05

Update of /project/cl-store/cvsroot/cl-store/ecl In directory common-lisp.net:/tmp/cvs-serv3668/ecl Added Files: .cvsignore Log Message: Changelog 2005-02-18 Date: Fri Feb 18 09:20:11 2005 Author: sross

1 0

[cl-store-cvs] CVS update: cl-store/cl-store.asd
by sross＠common-lisp.net 18 Feb '05

18 Feb '05

Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv3668 Modified Files: cl-store.asd Log Message: Changelog 2005-02-18 Date: Fri Feb 18 09:20:10 2005 Author: sross Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.22 cl-store/cl-store.asd:1.23 --- cl-store/cl-store.asd:1.22 Thu Feb 17 09:23:48 2005 +++ cl-store/cl-store.asd Fri Feb 18 09:20:10 2005 @@ -40,7 +40,7 @@ :name "CL-STORE" :author "Sean Ross <sdr(a)jhb.ucs.co.za>" :maintainer "Sean Ross <sdr(a)jhb.ucs.co.za>" - :version "0.4.17" + :version "0.4.18" :description "Serialization package" :long-description "Portable CL Package to serialize data types" :licence "MIT"

1 0

[cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/default-backend.lisp cl-store/package.lisp cl-store/utils.lisp
by sross＠common-lisp.net 18 Feb '05

18 Feb '05

Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv2911 Modified Files: ChangeLog default-backend.lisp package.lisp utils.lisp Log Message: Changelog 2005-02-18 Date: Fri Feb 18 09:15:50 2005 Author: sross Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.23 cl-store/ChangeLog:1.24 --- cl-store/ChangeLog:1.23 Thu Feb 17 09:23:48 2005 +++ cl-store/ChangeLog Fri Feb 18 09:15:49 2005 @@ -1,3 +1,8 @@ +2005-02-18 Sean Ross <sross(a)common-lisp.net> + * utils.lisp, package.lisp: Took a lesson from the MOP + and changed serializable-slots to call the new GF + serializable-slots-using-class. + 2005-02-17 Sean Ross <sross(a)common-lisp.net> * package.lisp, utils.lisp, default-backend.lisp: Patch from Thomas Stenhaug which changed get-slot-details to Index: cl-store/default-backend.lisp diff -u cl-store/default-backend.lisp:1.21 cl-store/default-backend.lisp:1.22 --- cl-store/default-backend.lisp:1.21 Thu Feb 17 09:23:48 2005 +++ cl-store/default-backend.lisp Fri Feb 18 09:15:49 2005 @@ -531,6 +531,7 @@ (setf (schar res x) (code-char (funcall reader stream)))) res)) + ;; packages (from Thomas Stenhaug) (defstore-cl-store (obj package stream) (output-type-code +package-code+ stream) @@ -543,14 +544,17 @@ (store-object (internal-symbols obj) stream) (store-object (external-symbols obj) stream)) +(defun remove-remaining (times stream) + (dotimes (x times) + (restore-object stream))) + (defrestore-cl-store (package stream) (let* ((package-name (restore-object stream)) (existing-package (find-package package-name))) (cond ((or (not existing-package) (and existing-package *nuke-existing-packages*)) (restore-package package-name stream :force *nuke-existing-packages*)) - (t (dotimes (x 5) ; remove remaining objects from the stream - (restore-object stream)) + (t (remove-remaining 5 stream) existing-package)))) (defun internal-symbols (package) @@ -579,7 +583,7 @@ (loop for symbol across (restore-object stream) do (export symbol package)) package)) - + ;; Function storing hack. ;; This just stores the function name if we can find it ;; or signal a store-error. Index: cl-store/package.lisp diff -u cl-store/package.lisp:1.19 cl-store/package.lisp:1.20 --- cl-store/package.lisp:1.19 Thu Feb 17 09:23:48 2005 +++ cl-store/package.lisp Fri Feb 18 09:15:49 2005 @@ -22,7 +22,8 @@ #:multiple-value-store #:*postfix-setters* #:caused-by #:store-32-bit #:read-32-bit #:*check-for-circs* #:*store-hash-size* #:*restore-hash-size* #:get-slot-details - #:*store-used-packages* #:*nuke-existing-packages*) + #:*store-used-packages* #:*nuke-existing-packages* + #:serializable-slots-using-class) #+sbcl (:import-from #:sb-mop #:generic-function-name Index: cl-store/utils.lisp diff -u cl-store/utils.lisp:1.12 cl-store/utils.lisp:1.13 --- cl-store/utils.lisp:1.12 Thu Feb 17 09:23:48 2005 +++ cl-store/utils.lisp Fri Feb 18 09:15:49 2005 @@ -18,14 +18,33 @@ (defgeneric serializable-slots (object) (:documentation "Return a list of slot-definitions to serialize. The default - is to call compute-slots on the objects class") + is to call serializable-slots-using-class with the object + and the objects class") (:method ((object standard-object)) - (compute-slots (class-of object))) + (serializable-slots-using-class object (class-of object))) #+(or sbcl cmu) (:method ((object structure-object)) - (compute-slots (class-of object))) + (serializable-slots-using-class object (class-of object))) (:method ((object condition)) - (compute-slots (class-of object)))) + (serializable-slots-using-class object (class-of object)))) + +; unfortunately the metaclass of conditions in sbcl and cmu +; are not standard-class +(defgeneric serializable-slots-using-class (object class) + (:documentation "Return a list of slot-definitions to serialize. + The default calls compute slots with class") + (:method ((object t) (class standard-class)) + (compute-slots class)) +#+(or sbcl cmu) + (:method ((object t) (class structure-class)) + (compute-slots class)) +#+sbcl + (:method ((object t) (class sb-pcl::condition-class)) + (compute-slots class)) +#+cmu + (:method ((object t) (class pcl::condition-class)) + (compute-slots class))) + ; Generify get-slot-details for customization (from Thomas Stenhaug) (defgeneric get-slot-details (slot-definition)

1 0

[cl-store-cvs] CVS update: cl-store/sbcl/custom.lisp
by sross＠common-lisp.net 17 Feb '05

17 Feb '05

Update of /project/cl-store/cvsroot/cl-store/sbcl In directory common-lisp.net:/tmp/cvs-serv24114/sbcl Modified Files: custom.lisp Log Message: Changelog 2005-02-17 Date: Thu Feb 17 09:23:54 2005 Author: sross Index: cl-store/sbcl/custom.lisp diff -u cl-store/sbcl/custom.lisp:1.6 cl-store/sbcl/custom.lisp:1.7 --- cl-store/sbcl/custom.lisp:1.6 Fri Feb 11 13:00:47 2005 +++ cl-store/sbcl/custom.lisp Thu Feb 17 09:23:54 2005 @@ -31,6 +31,7 @@ ;; Custom structure storing + (defstore-cl-store (obj structure-object stream) (output-type-code +structure-object-code+ stream) (store-type-object obj stream))

1 0

[cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/cl-store.asd cl-store/default-backend.lisp cl-store/package.lisp cl-store/utils.lisp
by sross＠common-lisp.net 17 Feb '05

17 Feb '05

Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv24114 Modified Files: ChangeLog cl-store.asd default-backend.lisp package.lisp utils.lisp Log Message: Changelog 2005-02-17 Date: Thu Feb 17 09:23:49 2005 Author: sross Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.22 cl-store/ChangeLog:1.23 --- cl-store/ChangeLog:1.22 Wed Feb 16 13:40:24 2005 +++ cl-store/ChangeLog Thu Feb 17 09:23:48 2005 @@ -1,3 +1,11 @@ +2005-02-17 Sean Ross <sross(a)common-lisp.net> + * package.lisp, utils.lisp, default-backend.lisp: Patch + from Thomas Stenhaug which changed get-slot-details to + a generic-function so that it can be customized. + Added serializable-slots (returns a list of slot-definitions) + which can be overridden to customize which slots are + serialized when storing clos instances. + 2005-02-16 Sean Ross <sross(a)common-lisp.net> * default-backend.lisp, package.lisp, plumbing.lisp: Patch from Thomas Stenhaug which adds more comprehensive package Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.21 cl-store/cl-store.asd:1.22 --- cl-store/cl-store.asd:1.21 Wed Feb 16 13:40:24 2005 +++ cl-store/cl-store.asd Thu Feb 17 09:23:48 2005 @@ -40,7 +40,7 @@ :name "CL-STORE" :author "Sean Ross <sdr(a)jhb.ucs.co.za>" :maintainer "Sean Ross <sdr(a)jhb.ucs.co.za>" - :version "0.4.15" + :version "0.4.17" :description "Serialization package" :long-description "Portable CL Package to serialize data types" :licence "MIT" Index: cl-store/default-backend.lisp diff -u cl-store/default-backend.lisp:1.20 cl-store/default-backend.lisp:1.21 --- cl-store/default-backend.lisp:1.20 Wed Feb 16 13:40:24 2005 +++ cl-store/default-backend.lisp Thu Feb 17 09:23:48 2005 @@ -101,8 +101,8 @@ ;; so we we have a little optimization for it ;; We need this for circularity stuff. -(defmethod int-sym-or-char-p ((backend cl-store) (fn symbol)) - (find fn '(integer character 32-bit-integer symbol))) +(defmethod int-sym-or-char-p ((backend cl-store) (type symbol)) + (find type '(integer character 32-bit-integer symbol))) (defstore-cl-store (obj integer stream) (if (typep obj 'sb32) @@ -335,7 +335,7 @@ (defun store-type-object (obj stream) (let* ((all-slots (remove-if-not (lambda (x) (slot-boundp obj (slot-definition-name x))) - (compute-slots (class-of obj)))) + (serializable-slots obj))) (slots (if *store-class-slots* all-slots (remove-if #'(lambda (x) (eql (slot-definition-allocation x) Index: cl-store/package.lisp diff -u cl-store/package.lisp:1.18 cl-store/package.lisp:1.19 --- cl-store/package.lisp:1.18 Wed Feb 16 13:40:24 2005 +++ cl-store/package.lisp Thu Feb 17 09:23:48 2005 @@ -14,20 +14,21 @@ #:backend-store-object #:get-class-details #:get-array-values #:restore #:backend-restore #:cl-store #:referrerp #:check-magic-number #:get-next-reader #:int-sym-or-char-p - #:restore-object #:backend-restore-object + #:restore-object #:backend-restore-object #:serializable-slots #:defstore-cl-store #:defrestore-cl-store #:register-code #:output-type-code #:store-referrer #:resolving-object #:internal-store-object #:setting #:simple-standard-string #:float-type #:get-float-type #:make-referrer #:setting-hash #:multiple-value-store #:*postfix-setters* #:caused-by #:store-32-bit #:read-32-bit #:*check-for-circs* - #:*store-hash-size* #:*restore-hash-size* + #:*store-hash-size* #:*restore-hash-size* #:get-slot-details #:*store-used-packages* #:*nuke-existing-packages*) #+sbcl (:import-from #:sb-mop #:generic-function-name #:slot-definition-name #:slot-definition-allocation + #:slot-definition #:compute-slots #:slot-definition-initform #:slot-definition-initargs @@ -55,6 +56,7 @@ #:slot-definition-name #:slot-definition-allocation #:compute-slots + #:slot-definition #:slot-definition-initform #:slot-definition-initargs #:slot-definition-name @@ -78,6 +80,7 @@ #:slot-definition-name #:slot-definition-allocation #:compute-slots + #:slot-definition #:slot-definition-initform #:slot-definition-initargs #:slot-definition-name @@ -105,6 +108,7 @@ #:generic-function-name #:slot-definition-allocation #:compute-slots + #:slot-definition #:slot-definition-initform #:slot-definition-initargs #:slot-definition-name @@ -121,6 +125,7 @@ #:slot-definition-name #:generic-function-name #:slot-definition-allocation + #:slot-definition #:compute-slots #:slot-definition-initform #:slot-definition-initargs Index: cl-store/utils.lisp diff -u cl-store/utils.lisp:1.11 cl-store/utils.lisp:1.12 --- cl-store/utils.lisp:1.11 Fri Feb 11 13:00:31 2005 +++ cl-store/utils.lisp Thu Feb 17 09:23:48 2005 @@ -15,18 +15,33 @@ (defun mappend (fn &rest lsts) (apply #'append (apply #'mapcar fn lsts))) +(defgeneric serializable-slots (object) + (:documentation + "Return a list of slot-definitions to serialize. The default + is to call compute-slots on the objects class") + (:method ((object standard-object)) + (compute-slots (class-of object))) +#+(or sbcl cmu) + (:method ((object structure-object)) + (compute-slots (class-of object))) + (:method ((object condition)) + (compute-slots (class-of object)))) -(defun get-slot-details (slot-definition) - "Return a list of slot details which can be - used as an argument to ensure-class" - (list :name (slot-definition-name slot-definition) - :allocation (slot-definition-allocation slot-definition) - :initargs (slot-definition-initargs slot-definition) - ;; :initform. dont use initform until we can - ;; serialize functions - :readers (slot-definition-readers slot-definition) - :type (slot-definition-type slot-definition) - :writers (slot-definition-writers slot-definition))) +; Generify get-slot-details for customization (from Thomas Stenhaug) +(defgeneric get-slot-details (slot-definition) + (:documentation + "Return a list of slot details which can be used + as an argument to ensure-class") + (:method ((slot-definition #+(or ecl clisp) t + #-(or ecl clisp) slot-definition)) + (list :name (slot-definition-name slot-definition) + :allocation (slot-definition-allocation slot-definition) + :initargs (slot-definition-initargs slot-definition) + ;; :initform. dont use initform until we can + ;; serialize functions + :readers (slot-definition-readers slot-definition) + :type (slot-definition-type slot-definition) + :writers (slot-definition-writers slot-definition)))) (defmacro awhen (test &body body) `(aif ,test

1 0

[cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/cl-store.asd cl-store/default-backend.lisp cl-store/package.lisp cl-store/plumbing.lisp cl-store/tests.lisp
by sross＠common-lisp.net 16 Feb '05

16 Feb '05

Update of /project/cl-store/cvsroot/cl-store In directory common-lisp.net:/tmp/cvs-serv26077 Modified Files: ChangeLog cl-store.asd default-backend.lisp package.lisp plumbing.lisp tests.lisp Log Message: Changelog 2005-02-16 Date: Wed Feb 16 13:40:24 2005 Author: sross Index: cl-store/ChangeLog diff -u cl-store/ChangeLog:1.21 cl-store/ChangeLog:1.22 --- cl-store/ChangeLog:1.21 Mon Feb 14 10:02:33 2005 +++ cl-store/ChangeLog Wed Feb 16 13:40:24 2005 @@ -1,3 +1,8 @@ +2005-02-16 Sean Ross <sross(a)common-lisp.net> + * default-backend.lisp, package.lisp, plumbing.lisp: Patch + from Thomas Stenhaug which adds more comprehensive package + storing. + 2005-02-14 Sean Ross <sross(a)common-lisp.net> * default-backend.lisp: Applied patch from Thomas Stenhaug to default null superclasses of a restored class to Index: cl-store/cl-store.asd diff -u cl-store/cl-store.asd:1.20 cl-store/cl-store.asd:1.21 --- cl-store/cl-store.asd:1.20 Mon Feb 14 10:02:34 2005 +++ cl-store/cl-store.asd Wed Feb 16 13:40:24 2005 @@ -40,7 +40,7 @@ :name "CL-STORE" :author "Sean Ross <sdr(a)jhb.ucs.co.za>" :maintainer "Sean Ross <sdr(a)jhb.ucs.co.za>" - :version "0.4.14" + :version "0.4.15" :description "Serialization package" :long-description "Portable CL Package to serialize data types" :licence "MIT" Index: cl-store/default-backend.lisp diff -u cl-store/default-backend.lisp:1.19 cl-store/default-backend.lisp:1.20 --- cl-store/default-backend.lisp:1.19 Mon Feb 14 10:02:34 2005 +++ cl-store/default-backend.lisp Wed Feb 16 13:40:24 2005 @@ -21,7 +21,6 @@ ;; Type code constants (defvar +referrer-code+ (register-code 1 'referrer nil)) -;(defvar +values-code+ (register-code 2 'values-object nil)) (defvar +unicode-string-code+ (register-code 3 'unicode-string nil)) (defvar +integer-code+ (register-code 4 'integer nil)) (defvar +simple-string-code+ (register-code 5 'simple-string nil)) @@ -42,14 +41,12 @@ (defvar +simple-vector-code+ (register-code 20 'simple-vector nil)) (defvar +package-code+ (register-code 21 'package nil)) -;; Used by lispworks (defvar +positive-infinity-code+ (register-code 22 'positive-infinity nil)) (defvar +negative-infinity-code+ (register-code 23 'negative-infinity nil)) ;; new storing for 32 bit ints (defvar +32-bit-integer-code+ (register-code 24 '32-bit-integer nil)) -;; More for lispworks (defvar +float-nan-code+ (register-code 25 'nan-float nil)) (defvar +function-code+ (register-code 26 'function nil)) @@ -187,10 +184,10 @@ (defrestore-cl-store (float stream) (float (* (get-float-type (read-byte stream)) - (* (restore-object stream) - (expt (restore-object stream) - (restore-object stream))) - (restore-object stream)))) + (* (the integer (restore-object stream)) + (expt (the integer (restore-object stream)) + (the integer (restore-object stream)))) + (the integer (restore-object stream))))) (defun handle-special-float (code name) (aif (rassoc code *special-floats*) @@ -534,15 +531,55 @@ (setf (schar res x) (code-char (funcall reader stream)))) res)) -;; packages +;; packages (from Thomas Stenhaug) (defstore-cl-store (obj package stream) - (output-type-code +package-code+ stream) - (store-object (package-name obj) stream)) + (output-type-code +package-code+ stream) + (store-object (package-name obj) stream) + (store-object (package-nicknames obj) stream) + (store-object (mapcar (if *store-used-packages* #'identity #'package-name) + (package-use-list obj)) + stream) + (store-object (package-shadowing-symbols obj) stream) + (store-object (internal-symbols obj) stream) + (store-object (external-symbols obj) stream)) (defrestore-cl-store (package stream) - (find-package (restore-object stream))) - - + (let* ((package-name (restore-object stream)) + (existing-package (find-package package-name))) + (cond ((or (not existing-package) + (and existing-package *nuke-existing-packages*)) + (restore-package package-name stream :force *nuke-existing-packages*)) + (t (dotimes (x 5) ; remove remaining objects from the stream + (restore-object stream)) + existing-package)))) + +(defun internal-symbols (package) + (let ((acc (make-array 100 :adjustable t :fill-pointer 0)) + (used (package-use-list package))) + (do-symbols (symbol package) + (unless (find (symbol-package symbol) used) + (vector-push-extend symbol acc))) + acc)) + +(defun external-symbols (package) + (let ((acc (make-array 100 :adjustable t :fill-pointer 0))) + (do-external-symbols (symbol package) + (vector-push-extend symbol acc)) + acc)) + +(defun restore-package (package-name stream &key force) + (when force + (delete-package package-name)) + (let ((package (make-package package-name + :nicknames (restore-object stream) + :use (restore-object stream)))) + (shadow (restore-object stream) package) + (loop for symbol across (restore-object stream) do + (import symbol package)) + (loop for symbol across (restore-object stream) do + (export symbol package)) + package)) + ;; Function storing hack. ;; This just stores the function name if we can find it ;; or signal a store-error. Index: cl-store/package.lisp diff -u cl-store/package.lisp:1.17 cl-store/package.lisp:1.18 --- cl-store/package.lisp:1.17 Fri Feb 11 13:00:31 2005 +++ cl-store/package.lisp Wed Feb 16 13:40:24 2005 @@ -21,7 +21,8 @@ #:float-type #:get-float-type #:make-referrer #:setting-hash #:multiple-value-store #:*postfix-setters* #:caused-by #:store-32-bit #:read-32-bit #:*check-for-circs* - #:*store-hash-size* #:*restore-hash-size*) + #:*store-hash-size* #:*restore-hash-size* + #:*store-used-packages* #:*nuke-existing-packages*) #+sbcl (:import-from #:sb-mop #:generic-function-name Index: cl-store/plumbing.lisp diff -u cl-store/plumbing.lisp:1.10 cl-store/plumbing.lisp:1.11 --- cl-store/plumbing.lisp:1.10 Fri Feb 11 13:00:31 2005 +++ cl-store/plumbing.lisp Wed Feb 16 13:40:24 2005 @@ -6,6 +6,11 @@ (in-package :cl-store) +(defvar *store-used-packages* nil + "If non-nil will serialize each used package otherwise will +only store the package name") +(defvar *nuke-existing-packages* nil + "Whether or not to overwrite existing packages on restoration.") (defvar *nuke-existing-classes* nil "Do we overwrite existing class definitions on restoration.") (defvar *store-class-superclasses* nil Index: cl-store/tests.lisp diff -u cl-store/tests.lisp:1.14 cl-store/tests.lisp:1.15 --- cl-store/tests.lisp:1.14 Fri Feb 11 13:00:31 2005 +++ cl-store/tests.lisp Wed Feb 16 13:40:24 2005 @@ -191,7 +191,29 @@ ;; packages (deftestit package.1 (find-package :cl-store)) +(defpackage foo + (:nicknames foobar) + (:use :cl) + (:shadow cl:format) + (:export bar)) +(defun package-restores () + (store (find-package :foo) *test-file*) + (delete-package :foo) + (restore *test-file*) + (list (package-name (find-package :foo)) + (mapcar #'package-name (package-use-list :foo)) + (package-nicknames :foo) + (equalp (remove-duplicates (package-shadowing-symbols :foo)) + (list (find-symbol "FORMAT" "FOO"))) + (equalp (cl-store::external-symbols (find-package :foo)) + (make-array 1 :initial-element (find-symbol "BAR" "FOO"))))) + +; unfortunately it's difficult to portably test the internal symbols +; in a package so we just have to assume that it's OK. +(deftest package.2 + (package-restores) + ("FOO" ("COMMON-LISP") ("FOOBAR") t t)) ;; objects (defclass foo ()

1 0