[Organize prototype xmlisp2 source
clinton@unknownlamer.org**20090501173536
 Ignore-this: 3129751b92531e421d6659ee04d99210
 And now to build a saner initialization and serialization protocol!
] move ./src/xmlisp2.lisp ./src/serializer-class.lisp
addfile ./src/codec.lisp
hunk ./src/codec.lisp 1
-
+(in-package :xmlisp2)
+
+;;; Decode
+
+(defmethod xml-value->lisp-value (xml-value lisp-type)
+  xml-value)
+
+;; todo: use PARSE-NUMBER or similar for number subtypes
+(defmethod xml-value->lisp-value (xml-value (lisp-type (eql 'number)))
+  (let ((number (read-from-string xml-value)))
+    (assert (numberp number))
+    number))
+
+(defmethod xml-value->lisp-value (xml-value (lisp-type (eql 'float)))
+  (let ((number (read-from-string xml-value)))
+    (assert (floatp number))
+    number))
+
+;;; todo: short-float single-float double-float
+
+(defmethod xml-value->lisp-value (xml-value (lisp-type (eql 'integer)))
+  (parse-integer xml-value))
+
+(defmethod xml-value->lisp-value (xml-value (lisp-type (eql 'boolean)))
+  (cond ((string= xml-value "true") t)
+	((string= xml-value "false") nil)
+	(t (error "invalid boolean value"))))
+
+(defmethod xml-value->lisp-value (xml-value (lisp-type (eql 'character)))
+  (assert (= 1 (length xml-value)))
+  (char xml-value 0))
+
+(defmethod xml-value->lisp-value (xml-value (lisp-type (eql 'string)))
+  xml-value)
+
+;;; todo: pathname
+
+(defmethod xml-value->lisp-value (xml-value (lisp-type (eql 'list)))
+  (let ((list (read-from-string xml-value)))
+    (assert (listp list))
+    list))
+
+(defmethod xml-value->lisp-value (xml-value (lisp-type (eql 'array)))
+  (let ((array (read-from-string xml-value)))
+    (assert (arrayp array))
+    array))
+
+;;; Encode
+
+(defmethod lisp-value->xml-value (lisp-value)
+  (princ-to-string lisp-value))
+
+(defmethod lisp-value->xml-value ((lisp-value (eql t)))
+  "true")
+
+(defmethod lisp-value->xml-value ((lisp-value null))
+  "false")
addfile ./src/parse.lisp
hunk ./src/parse.lisp 1
+(in-package :xmlisp2)
+
+(defun xmlns->package (xmlns)
+  (cdr (assoc xmlns *xmlns-to-package* :test #'string=)))
+
+(defun normalize-symbol-case (name)
+ (ecase (readtable-case *readtable*)
+   (:upcase (string-upcase name))
+   (:downcase (string-downcase name))
+   (:preserve name)
+   (:invert
+    (cond
+     ((every #'upper-case-p name) (string-downcase name))
+     ((every #'lower-case-p name) (string-upcase name))
+     (t name)))))
+
+(defun xml-name->symbol (uri lname)
+  (let ((normal (normalize-symbol-case lname))
+	(package (if uri (xmlns->package uri) *package*)))
+    #+nil(break "xn-s: (~A ~A) [~A] p=~A" uri lname normal package)
+    (let ((sym (find-symbol normal package)))
+      #+nil(break "found symbol: ~A" sym)
+      sym)))
+
+(defun find-xml-class (uri lname)
+  (let ((class
+	 (find-class (xml-name->symbol uri lname))))
+    #+nil(break "found class: ~A" class)
+    class))
+
+(defun parse-and-make-instance (stream)
+  (with-open-source (source (cxml:make-source stream))
+    (parse-and-make-instance-1 source)))
+
+(defun parse-and-make-instance-1 (source)
+  (multiple-value-bind (key uri lname qname)
+      (find-event source :start-element)
+    (declare (ignore key qname))
+    (let ((instance (make-instance (find-xml-class uri lname))))
+      (map-attributes (lambda (uri lname qname value defaultp)
+			(declare (ignore qname defaultp))
+			#+nil(break "MAP-ATTRIBUTES (~A ~A)=~A" uri lname value)
+			(unless (string= uri "http://www.w3.org/2000/xmlns/")
+			  (set-attribute-value instance
+					       (xml-name->symbol uri lname)
+					       value)))
+		      source)
+      #+nil(break "scanning children")
+      (loop
+	 :until (eq (let ((ev (peek-next source)))
+		      #+nil(break "... event = ~A" ev)
+		      ev)
+		    :end-element)
+	 :do (ecase (peek source)
+	       ((:start-element)
+		(multiple-value-bind (key uri lname qname) (peek source)
+		  (declare (ignore qname))
+		  #+nil(break "subobject: (~A ~A) / ev ~A" uri lname key)
+		  (add-subobject instance
+				 (xml-name->symbol uri lname)
+				 (parse-and-make-instance-1 source))))
+	       ((:characters)
+		#+nil(break "chars: ~S" (current-characters source))
+		(add-character-data instance
+				    (current-characters source)
+				    (current-cdata-section-p source)))
+	       ((:processing-instruction)
+		(multiple-value-bind (target data) (peek-value source)
+		  (handle-processing-instruction instance target data)))
+	       ((:comment)
+		(handle-comment instance (peek-value source)))))
+      #+nil(break "created instance ~A" instance)
+      (finished-parsing instance))))
addfile ./src/protocol.lisp
hunk ./src/protocol.lisp 1
-
+(in-package :xmlisp2)
+
+;; deserialization
+(defgeneric set-attribute-value (serializer attribute-name xml-value))
+(defgeneric add-subobject (serializer tag-name subobject))
+(defgeneric add-character-data (serializer character-data cdatap))
+(defgeneric handle-processing-instruction (serializer target data))
+(defgeneric handle-comment (serializer comment-data))
+(defgeneric finished-parsing (serializer))
+
+;;; coding/decoding
+(defgeneric xml-value->lisp-value (xml-value lisp-type))
+(defgeneric lisp-value->xml-value (lisp-value))
+
+;;; serialization
+(defgeneric serialize-slot-p (object slot-name))
+(defgeneric serialize-as-attribute-p (object slot-name slot-type))
+(defgeneric serialize-as-subelement-p (object slot-name slot-type))
+(defgeneric serialize-xml-object (object sink))
hunk ./src/serializer-class.lisp 3
-(defvar *xmlns-to-package*
-  (list
-   (cons "http://www.w3.org/XML/1998/namespace"
-	 (find-package :xmlisp2))))
-
-(defvar *prefix-to-package* nil)
-
-(defun xmlns->package (xmlns)
-  (cdr (assoc xmlns *xmlns-to-package* :test #'string=)))
-
-(defun normalize-symbol-case (name)
- (ecase (readtable-case *readtable*)
-   (:upcase (string-upcase name))
-   (:downcase (string-downcase name))
-   (:preserve name)
-   (:invert
-    (cond
-     ((every #'upper-case-p name) (string-downcase name))
-     ((every #'lower-case-p name) (string-upcase name))
-     (t name)))))
-
-(defun xml-name->symbol (uri lname)
-  (let ((normal (normalize-symbol-case lname))
-	(package (if uri (xmlns->package uri) *package*)))
-    #+nil(break "xn-s: (~A ~A) [~A] p=~A" uri lname normal package)
-    (let ((sym (find-symbol normal package)))
-      #+nil(break "found symbol: ~A" sym)
-      sym)))
-
-(defun find-xml-class (uri lname)
-  (let ((class
-	 (find-class (xml-name->symbol uri lname))))
-    #+nil(break "found class: ~A" class)
-    class))
-
-(defgeneric set-attribute-value (serializer attribute-name xml-value))
-(defgeneric add-subobject (serializer tag-name subobject))
-(defgeneric add-character-data (serializer character-data cdatap))
-(defgeneric handle-processing-instruction (serializer target data))
-(defgeneric handle-comment (serializer comment-data))
-
-(defgeneric finished-parsing (serializer))
-
-(defun parse-and-make-instance (stream)
-  (with-open-source (source (cxml:make-source stream))
-    (parse-and-make-instance-1 source)))
-
-(defun parse-and-make-instance-1 (source)
-  (multiple-value-bind (key uri lname qname)
-      (find-event source :start-element)
-    (declare (ignore key qname))
-    (let ((instance (make-instance (find-xml-class uri lname))))
-      (map-attributes (lambda (uri lname qname value defaultp)
-			(declare (ignore qname defaultp))
-			#+nil(break "MAP-ATTRIBUTES (~A ~A)=~A" uri lname value)
-			(unless (string= uri "http://www.w3.org/2000/xmlns/")
-			  (set-attribute-value instance
-					       (xml-name->symbol uri lname)
-					       value)))
-		      source)
-      #+nil(break "scanning children")
-      (loop
-	 :until (eq (let ((ev (peek-next source)))
-		      #+nil(break "... event = ~A" ev)
-		      ev)
-		    :end-element)
-	 :do (ecase (peek source)
-	       ((:start-element)
-		(multiple-value-bind (key uri lname qname) (peek source)
-		  (declare (ignore qname))
-		  #+nil(break "subobject: (~A ~A) / ev ~A" uri lname key)
-		  (add-subobject instance
-				 (xml-name->symbol uri lname)
-				 (parse-and-make-instance-1 source))))
-	       ((:characters)
-		#+nil(break "chars: ~S" (current-characters source))
-		(add-character-data instance
-				    (current-characters source)
-				    (current-cdata-section-p source)))
-	       ((:processing-instruction)
-		(multiple-value-bind (target data) (peek-value source)
-		  (handle-processing-instruction instance target data)))
-	       ((:comment)
-		(handle-comment instance (peek-value source)))))
-      #+nil(break "created instance ~A" instance)
-      (finished-parsing instance))))
-
-(defgeneric xml-value->lisp-value (xml-value lisp-type))
-
-(defmethod xml-value->lisp-value (xml-value lisp-type)
-  xml-value)
-
-;; todo: use PARSE-NUMBER or similar for number subtypes
-(defmethod xml-value->lisp-value (xml-value (lisp-type (eql 'number)))
-  (let ((number (read-from-string xml-value)))
-    (assert (numberp number))
-    number))
-
-(defmethod xml-value->lisp-value (xml-value (lisp-type (eql 'float)))
-  (let ((number (read-from-string xml-value)))
-    (assert (floatp number))
-    number))
-
-;;; todo: short-float single-float double-float
-
-(defmethod xml-value->lisp-value (xml-value (lisp-type (eql 'integer)))
-  (parse-integer xml-value))
-
-(defmethod xml-value->lisp-value (xml-value (lisp-type (eql 'boolean)))
-  (cond ((string= xml-value "true") t)
-	((string= xml-value "false") nil)
-	(t (error "invalid boolean value"))))
-
-(defmethod xml-value->lisp-value (xml-value (lisp-type (eql 'character)))
-  (assert (= 1 (length xml-value)))
-  (char xml-value 0))
-
-(defmethod xml-value->lisp-value (xml-value (lisp-type (eql 'string)))
-  xml-value)
-
-;;; todo: pathname
-
-(defmethod xml-value->lisp-value (xml-value (lisp-type (eql 'list)))
-  (let ((list (read-from-string xml-value)))
-    (assert (listp list))
-    list))
-
-(defmethod xml-value->lisp-value (xml-value (lisp-type (eql 'array)))
-  (let ((array (read-from-string xml-value)))
-    (assert (arrayp array))
-    array))
-
hunk ./src/serializer-class.lisp 49
-(defgeneric serialize-slot-p (object slot-name))
-(defgeneric serialize-as-attribute-p (object slot-name slot-type))
-(defgeneric serialize-as-subelement-p (object slot-name slot-type))
-
-(defgeneric serialize-xml-object (object sink))
-
-(defgeneric lisp-value->xml-value (lisp-value))
-
hunk ./src/serializer-class.lisp 81
-
-(defmethod lisp-value->xml-value (lisp-value)
-  (princ-to-string lisp-value))
-
-(defmethod lisp-value->xml-value ((lisp-value (eql t)))
-  "true")
-
-(defmethod lisp-value->xml-value ((lisp-value null))
-  "false")
-
-(defun package->xmlns (package)
-  (or (car (find package *xmlns-to-package* :key #'cdr :test #'eql))
-      (package-name package)))
-
-(defun symbol-uri (symbol)
-  (package->xmlns (symbol-package symbol)))
-
-(defun symbol-local-name (symbol)
-  ;; todo: customizable...
-  (string-downcase (symbol-name symbol)))
-
-(defun symbol-qualified-name (symbol)
-  (format nil "~A:~A"
-	  (package-name (symbol-package symbol))
-	  (symbol-name symbol)))
-
-(defun package->xmlns-attribute (package)
-  (sax:make-attribute
-   :namespace-uri "http://www.w3.org/2000/xmlns/"
-   :local-name (package-name package)
-   :qname (format nil "xmlns:~A" (package-name package))
-   :value (package->xmlns package)
-   :specified-p t))
-
-(defvar *current-namespaces* nil)
-
-(defmethod serialize-xml-object ((object xml-serializer) sink)
-  #+nil(break "~A ~A" object sink)
-  (let* ((class-name (class-name (class-of object)))
-	 (class-name-package (symbol-package class-name))
-	 (xmlns (package->xmlns class-name-package))
-	 (xmlns-attributes (remove-if
-			    (lambda (ns)
-			      (some (lambda (namespaces)
-				      (member ns
-					      namespaces
-					      :test (lambda (i1 i2)
-						      (string=
-						       (sax:attribute-value i1)
-						       (sax:attribute-value i2)))))
-				    *current-namespaces*))
-			    (cons (package->xmlns-attribute class-name-package)
-				  (mapcar #'package->xmlns-attribute
-					  (remove-duplicates
-					   (mapcar (compose
-						    #'symbol-package
-						    #'c2mop:slot-definition-name)
-						   (c2mop:class-slots
-						    (class-of object)))))))))
-    (let ((*current-namespaces* (cons xmlns-attributes *current-namespaces*)))
-      #+nil(break "~A ~A ~A" class-name class-name-package xmlns)
-      (sax:start-element sink xmlns (symbol-local-name class-name)
-			 (symbol-qualified-name class-name)
-			 (nconc
-			  (mapcan (lambda (slot)
-				    (let ((name (c2mop:slot-definition-name slot))
-					  (type (c2mop:slot-definition-type slot)))
-				      (when (and (serialize-slot-p object name)
-						 (serialize-as-attribute-p object
-									   name
-									   type))
-					(list (sax:make-attribute
-					       :namespace-uri (symbol-uri name)
-					       :local-name (symbol-local-name name)
-					       :qname (symbol-qualified-name name)
-					       :value (lisp-value->xml-value
-						       (slot-value object name))
-					       :specified-p t)))))
-				  (c2mop:class-slots (class-of object)))
-			  xmlns-attributes))
-      (mapc (lambda (slot-def)
-	      (serialize-xml-object
-	       (slot-value object
-			   (c2mop:slot-definition-name slot-def))
-	       sink))
-	    (remove-if-not (lambda (slot)
-			     (let ((name (c2mop:slot-definition-name slot))
-				   (type (c2mop:slot-definition-type slot)))
-			       (and (serialize-slot-p object name)
-				    (serialize-as-subelement-p object
-							       name
-							       type))))
-			   (c2mop:class-slots (class-of object)))))
-    (sax:end-element sink xmlns (symbol-local-name class-name)
-		     (symbol-qualified-name class-name))))
-
-(defmethod serialize-xml-object ((object sequence) sink)
-  (map nil (lambda (subobject)
-	     (serialize-xml-object subobject sink))
-       object))
-
addfile ./src/unparse.lisp
hunk ./src/unparse.lisp 1
+(in-package :xmlisp2)
+
+(defun package->xmlns (package)
+  (or (car (find package *xmlns-to-package* :key #'cdr :test #'eql))
+      (package-name package)))
+
+(defun symbol-uri (symbol)
+  (package->xmlns (symbol-package symbol)))
+
+(defun symbol-local-name (symbol)
+  ;; todo: customizable...
+  (string-downcase (symbol-name symbol)))
+
+(defun symbol-qualified-name (symbol)
+  (format nil "~A:~A"
+	  (package-name (symbol-package symbol))
+	  (symbol-name symbol)))
+
+(defun package->xmlns-attribute (package)
+  (sax:make-attribute
+   :namespace-uri "http://www.w3.org/2000/xmlns/"
+   :local-name (package-name package)
+   :qname (format nil "xmlns:~A" (package-name package))
+   :value (package->xmlns package)
+   :specified-p t))
+
+(defvar *current-namespaces* nil)
+
+(defmethod serialize-xml-object ((object xml-serializer) sink)
+  #+nil(break "~A ~A" object sink)
+  (let* ((class-name (class-name (class-of object)))
+	 (class-name-package (symbol-package class-name))
+	 (xmlns (package->xmlns class-name-package))
+	 (xmlns-attributes (remove-if
+			    (lambda (ns)
+			      (some (lambda (namespaces)
+				      (member ns
+					      namespaces
+					      :test (lambda (i1 i2)
+						      (string=
+						       (sax:attribute-value i1)
+						       (sax:attribute-value i2)))))
+				    *current-namespaces*))
+			    (cons (package->xmlns-attribute class-name-package)
+				  (mapcar #'package->xmlns-attribute
+					  (remove-duplicates
+					   (mapcar (compose
+						    #'symbol-package
+						    #'c2mop:slot-definition-name)
+						   (c2mop:class-slots
+						    (class-of object)))))))))
+    (let ((*current-namespaces* (cons xmlns-attributes *current-namespaces*)))
+      #+nil(break "~A ~A ~A" class-name class-name-package xmlns)
+      (sax:start-element sink xmlns (symbol-local-name class-name)
+			 (symbol-qualified-name class-name)
+			 (nconc
+			  (mapcan (lambda (slot)
+				    (let ((name (c2mop:slot-definition-name slot))
+					  (type (c2mop:slot-definition-type slot)))
+				      (when (and (serialize-slot-p object name)
+						 (serialize-as-attribute-p object
+									   name
+									   type))
+					(list (sax:make-attribute
+					       :namespace-uri (symbol-uri name)
+					       :local-name (symbol-local-name name)
+					       :qname (symbol-qualified-name name)
+					       :value (lisp-value->xml-value
+						       (slot-value object name))
+					       :specified-p t)))))
+				  (c2mop:class-slots (class-of object)))
+			  xmlns-attributes))
+      (mapc (lambda (slot-def)
+	      (serialize-xml-object
+	       (slot-value object
+			   (c2mop:slot-definition-name slot-def))
+	       sink))
+	    (remove-if-not (lambda (slot)
+			     (let ((name (c2mop:slot-definition-name slot))
+				   (type (c2mop:slot-definition-type slot)))
+			       (and (serialize-slot-p object name)
+				    (serialize-as-subelement-p object
+							       name
+							       type))))
+			   (c2mop:class-slots (class-of object)))))
+    (sax:end-element sink xmlns (symbol-local-name class-name)
+		     (symbol-qualified-name class-name))))
+
+(defmethod serialize-xml-object ((object sequence) sink)
+  (map nil (lambda (subobject)
+	     (serialize-xml-object subobject sink))
+       object))
addfile ./src/vars.lisp
hunk ./src/vars.lisp 1
-
+(in-package :xmlisp2)
+
+(defvar *xmlns-to-package*
+  (list
+   (cons "http://www.w3.org/XML/1998/namespace"
+	 (find-package :xmlisp2))))
hunk ./xmlisp.asd 11
-    :components ((:module :src :components ((:file "packages")
-					    (:file "xmlisp" :depends-on ("packages")))))
+    :components
+    ((:module
+      :src :components ((:file "packages")
+			(:file "protocol" :depends-on ("packages"))
+			(:file "codec" :depends-on ("protocol" "packages"))
+			(:file "vars" :depends-on ("packages"))
+			(:file "parse"
+			       :depends-on ("protocol" "codec" "vars" "packages"))
+			(:file "unparse"
+			       :depends-on ("protocol" "codec" "vars" "packages"))
+			(:file "serializer-class"
+			       :depends-on ("protocol" "packages")))))