[cl-soap-cvs] CVS update: cl-soap/src/xsd.lisp

[Sven Van Caekenberghe]

Update of /project/cl-soap/cvsroot/cl-soap/src
In directory common-lisp.net:/tmp/cvs-serv27824/src

Modified Files:
	xsd.lisp 
Log Message:
added a solution to the 'subtype' problem: using a special purpose member called xsi:|type| to indicate a concrete subtype for abstract types

Date: Thu Oct  6 13:09:39 2005
Author: scaekenberghe

Index: cl-soap/src/xsd.lisp
diff -u cl-soap/src/xsd.lisp:1.25 cl-soap/src/xsd.lisp:1.26
--- cl-soap/src/xsd.lisp:1.25	Wed Oct  5 15:24:38 2005
+++ cl-soap/src/xsd.lisp	Thu Oct  6 13:09:39 2005
@@ -1,6 +1,6 @@
 ;;;; -*- mode: lisp -*-
 ;;;;
-;;;; $Id: xsd.lisp,v 1.25 2005/10/05 13:24:38 scaekenberghe Exp $
+;;;; $Id: xsd.lisp,v 1.26 2005/10/06 11:09:39 scaekenberghe Exp $
 ;;;;
 ;;;; A partial implementation of the XML Schema Definition standard
 ;;;;
@@ -237,7 +237,10 @@
 ;; all element types are resolved into primitives or sequences of sub elements
 ;; elements without contents are also possible
 
-(defun get-xsd-template-multiplicity (xml-schema-element)
+(defmethod get-xsd-template-multiplicity ((xsd-type xsd-type))
+  :xsd-type)
+
+(defmethod get-xsd-template-multiplicity ((xml-schema-element xml-schema-element))
   (with-slots (min-occurs max-occurs)
       xml-schema-element
     (cond ((and (zerop min-occurs) (eql max-occurs 1)) '?)
@@ -280,15 +283,26 @@
   (let ((primitive-value (lisp->xsd-primitive value primitive-type)))
     `(,tag ,primitive-value)))
 
-(defun bind-xsd-template-members (tag members bindings namespace)
-  (let ((bound-members '()))
-    (loop :for member :in members :do
-          (let ((member-binding (bind-xsd-template member bindings namespace)))
-            (when member-binding 
-              (push member-binding bound-members))))
-    `(,tag ,@(reduce #'append (nreverse bound-members)))))
+(defun bind-xsd-template-members (tag members bindings schema namespace)
+  (let ((xsi-type (get-name-binding 'xsi::|type| bindings))
+        (bound-members '()))
+    (cond (xsi-type
+           (let ((type-template (generate-xsd-template xsi-type schema)))
+             (if (eql (first type-template) :xsd-type)
+                 (loop :for member :in (rest (rest type-template)) :do
+                       (let ((member-binding (bind-xsd-template member bindings schema namespace)))
+                         (when member-binding 
+                           (push member-binding bound-members))))
+               (error "Could not resolve explicit (sub)type ~s" xsi-type))
+             `((,tag xsi::|type| ,xsi-type) ,@(reduce #'append (nreverse bound-members)))))
+          (t
+           (loop :for member :in members :do
+                 (let ((member-binding (bind-xsd-template member bindings schema namespace)))
+                   (when member-binding 
+                     (push member-binding bound-members))))
+           `(,tag ,@(reduce #'append (nreverse bound-members)))))))
 
-(defun bind-xsd-template (template bindings namespace)
+(defun bind-xsd-template (template bindings schema namespace)
   (destructuring-bind (multiplicity element-name &rest contents)
       template
     (let ((tag (intern element-name (s-xml:get-package namespace))))
@@ -310,18 +324,18 @@
               (t
                (case multiplicity
                  ((1 ?) (if boundp
-                            `(,(bind-xsd-template-members tag contents value namespace))
+                            `(,(bind-xsd-template-members tag contents value schema namespace))
                           (when (eql multiplicity 1)
                             (error "Required element ~s not bound" element-name))))
                  ((+ *) (if (and boundp value)
                             (loop :for elt-value :in value
-                                  :collect (bind-xsd-template-members tag contents elt-value namespace))
+                                  :collect (bind-xsd-template-members tag contents elt-value schema namespace))
                           (when (eql multiplicity +)
                             (error "Required repeating element ~s not bound correctly" element-name)))))))))))
                 
 (defun bind-element (element bindings xml-schema-definition namespace)
   (let ((template (generate-xsd-template element xml-schema-definition)))
-    (reduce #'append (bind-xsd-template template bindings namespace))))
+    (reduce #'append (bind-xsd-template template bindings xml-schema-definition namespace))))
                   
 ;;; Resolving Templates (combining a template with an lxml list to generate an s-expr)