[Initial xmlisp replacement prototype
clinton@unknownlamer.org**20090430230219
 Ignore-this: 9fb77513229306a6827a604776d62f19
 This does nothing terribly useful *yet*
] hunk ./src/packages.lisp 3
+(defpackage :xmlisp2
+  (:use :cl :klacks :cxml)
+  (:import-from :arnesi :cond-bind :if-bind :when-bind))
+
addfile ./src/xmlisp2.lisp
hunk ./src/xmlisp2.lisp 1
+(in-package :xmlisp2)
+
+(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 extend-xmlns-package-map (source)
+  (let ((mappings (list)))
+    (map-current-namespace-declarations
+     (lambda (prefix uri)
+       (push (cons uri
+		   (or (xmlns->package uri)
+		       (find-package (normalize-symbol-case prefix))))
+	     mappings))
+     source)
+    mappings))
+
+(defun xml-name->symbol (uri lname)
+  (let ((normal (normalize-symbol-case lname))
+	(package (if uri (xmlns->package uri) *package*)))
+    (break "xn-s: (~A ~A) [~A] p=~A" uri lname normal package)
+    (let ((sym (find-symbol normal package)))
+      (break "found symbol: ~A" sym)
+      sym)))
+
+(defun find-xml-class (uri lname)
+  (let ((class
+	 (find-class (xml-name->symbol uri lname))))
+    (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 ((*xmlns-to-package* (cons (extend-xmlns-package-map source)
+				    *xmlns-to-package*)))
+      (let ((instance (make-instance (find-xml-class uri lname))))
+	(map-attributes (lambda (uri lname qname value defaultp)
+			  (declare (ignore qname defaultp))
+			  (break "MAP-ATTRIBUTES (~A ~A)=~A" uri lname value)
+			  (set-attribute-value instance
+					       (xml-name->symbol uri lname)
+					       value))
+			source)
+	(break "scanning children")
+	(consume source)
+	(loop
+	   :until (eq (let ((ev (peek source)))
+				(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))
+		    (break "subobject: (~A ~A) / ev ~A" uri lname key)
+		    (add-subobject instance
+				   (xml-name->symbol uri lname)
+				   (parse-and-make-instance-1 source))
+		    (consume source)))
+		 ((:characters)
+		  (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)))))
+	(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)
+
+(defclass xml-serializer ()
+  ())
+
+(defmethod attribute-name->slot-name ((object xml-serializer) attribute-name)
+  attribute-name)
+
+(defmethod attribute->slot-definition ((object xml-serializer) attribute-name)
+  (find (attribute-name->slot-name object attribute-name)
+	(c2mop:class-slots (class-of object))
+	:key #'c2mop:slot-definition-name))
+
+(defmethod set-attribute-value ((object xml-serializer) attribute-name xml-value)
+  (if-bind slot-definition (attribute->slot-definition object attribute-name)
+    (setf (slot-value object (c2mop:slot-definition-name slot-definition))
+	  (xml-value->lisp-value xml-value
+				 (c2mop:slot-definition-type slot-definition)))
+    (error "no matching slot for attribute ~A(=~S)" attribute-name xml-value)))
+
+(defmethod add-subobject ((object xml-serializer) tag-name subobject)
+  (cond-bind slot-definition
+    ((attribute->slot-definition object tag-name)
+     (setf (slot-value object (c2mop:slot-definition-name slot-definition))
+	   subobject))
+    ((when-bind plural (plural-name tag-name)
+       (attribute->slot-definition object plural))
+     (push subobject
+	   (slot-value object (c2mop:slot-definition-name slot-definition))))
+    ;; not found
+    (t (error "no slot found"))))
+
+(defun plural-name (symbol)
+  (find-symbol (format nil "~A~A" (symbol-name symbol) (normalize-symbol-case "s"))
+	       (symbol-package symbol)))
+
+(defmethod add-character-data ((object xml-serializer) character-data cdatap)
+  nil)
+
+(defmethod handle-processing-instruction ((object xml-serializer) target data)
+  nil)
+
+(defmethod handle-comment ((object xml-serializer) comment-data)
+  nil)
+
+(defmethod finished-parsing ((object xml-serializer))
+  object)
+
+(defclass quux (xml-serializer)
+  ((moo :initform nil)))
+
+(defclass blech (xml-serializer)
+  ((meh :initform nil)))
+
+(defclass foo (xml-serializer)
+  ((bar :initform nil)
+   (quux :initform nil)
+   (blechs :initform nil)))
+
hunk ./xmlisp.asd 9
-    :copyright "(c) 1996-2008, Agentsheets Inc."
-    :copyright "Portions (c) 2009 Clinton Ebadi"
hunk ./xmlisp.asd 13
-    :depends-on (:closer-mop))
+    :depends-on (:closer-mop :cxml :arnesi))