changeset 5:10bb32fe1122

added hooks for selecting which slots to serialize, and mapping those slots to values
author John Leuner <jewel@subvert-the-dominant-paradigm.net>
date Thu, 29 May 2008 05:08:30 +0530
parents 591eb9a4d1b0
children 2d904b2f35ff
files lisp/slurp.lisp
diffstat 1 files changed, 18 insertions(+), 8 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/slurp.lisp	Mon May 19 03:48:38 2008 +0530
+++ b/lisp/slurp.lisp	Thu May 29 05:08:30 2008 +0530
@@ -1,6 +1,6 @@
 (defpackage #:slurp
   (:use #:cl  :flexi-streams)
-  (:export :writer :reader :decode :encode :make-slurp-writer :make-slurp-reader)
+  (:export :writer :reader :decode :encode :make-slurp-writer :make-slurp-reader :select-slots-to-serialize :serialize-slot)
 )
 (defpackage #:test-slurp
   (:use #:cl :slurp))
@@ -123,7 +123,7 @@
     ;    (format t "ro ~A~%" foo)
     foo))
 
- (defmethod write-object ((writer writer) object)
+(defmethod write-object ((writer writer) object)
   (let ((stream (lisp-stream writer))
 	(*writer* writer)
 	(*state-descriptors* (state-descriptors writer)))
@@ -157,7 +157,7 @@
 	    (t (let ((state-descriptor (find-state-descriptor-by-class (class-of object))))
 		 (when (null state-descriptor)
 ;		   (format t "could not find sd for obj ~A of class ~A~%" object (class-of object))
-		   (setf state-descriptor (make-state-descriptor (class-of object)))
+		   (setf state-descriptor (make-state-descriptor object (class-of object)))
 		   (write-state-descriptor stream state-descriptor))
 		 (write-datum stream +unsigned-integer+ (code state-descriptor))
 		 (write-datum stream state-descriptor object)
@@ -184,9 +184,13 @@
 					    (discard-placeholders (slot-value object name) recursion-set)))))
 	  object))))
 
-(defun make-state-descriptor (class)
+(defgeneric select-slots-to-serialize (object))
+(defmethod select-slots-to-serialize (object)
+  (sb-pcl:class-slots (class-of object)))
+
+(defun make-state-descriptor (object class)
   (let* ((code (+ 1 (hash-table-count *state-descriptors*) +state-descriptor-base+))
-	 (slots (sb-pcl:class-slots class))
+	 (slots (loop for slot in (select-slots-to-serialize object) collect (string (sb-pcl:slot-definition-name slot))))
 	 (state-descriptor (make-instance 'state-descriptor 
 					  :code code
 					  :shape (logior (if slots
@@ -194,7 +198,7 @@
 							     0))
 					  :package-string (package-name (symbol-package (class-name class)))
 					  :name (symbol-name (class-name class))
-					  :named-slots (loop for slot in slots collect (string (sb-pcl:slot-definition-name slot))))))
+					  :named-slots slots)))
     (setf (gethash class *state-descriptors*) state-descriptor)
 ;    (break "state descriptors ~A" *state-descriptors*)
     state-descriptor))
@@ -264,14 +268,19 @@
 		   (format t "error ~A setting slot ~A in class ~A with value ~A~%" condition slot-name class-name value))))))
     placeholder))
 
+(defgeneric serialize-slot (object slot-name default-mapper))
+(defmethod serialize-slot (object slot-name default-mapper)
+  (funcall default-mapper object slot-name))
 (defmethod write-datum (stream (state-descriptor state-descriptor) object)
 ;  (break state-descriptor)
   (when (has-named-slots state-descriptor)
     ;    (format t "writing state descriptor slots ~A ~%" (name state-descriptor))
+    (let ((default-mapper #'(lambda (object slot-name)
+			      (handler-case (slot-value object (intern slot-name (find-package (intern (package-string state-descriptor)))))
+				(unbound-slot () nil)))))
     (loop for slot in (named-slots state-descriptor) do
 	  (write-object *writer*
-			(handler-case (slot-value object (intern slot (find-package (intern (package-string state-descriptor)))))
-			  (unbound-slot () nil))))))
+			(serialize-slot object slot default-mapper))))))
 
 (defmethod read-datum (stream (data-type (eql +nil+))) nil)
 
@@ -308,6 +317,7 @@
 
 (defmethod read-datum (stream (data-type (eql +object-array+)))
   (let* ((dimensions (read-datum stream +cons+))
+;	 (dummy (break "arr length ~A" dimensions))
 	 (buffer (make-array dimensions :element-type t))
 	 (length (array-total-size buffer)))
     (loop for index from 0 below length do