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)