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

Modified Files: xsd.lisp Log Message: various bugfixes

Date: Fri Sep 30 21:58:05 2005 Author: scaekenberghe

Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.20 cl-soap/src/xsd.lisp:1.21 --- cl-soap/src/xsd.lisp:1.20 Fri Sep 30 21:21:43 2005 +++ cl-soap/src/xsd.lisp Fri Sep 30 21:58:05 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.20 2005/09/30 19:21:43 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.21 2005/09/30 19:58:05 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -358,6 +358,7 @@ ;; ELT = ( <multiplicity> "element-name" [ :primitive | ELT* ] ) ;; where <multiplicity> is 1, ?, + or * and :primitive is a XSD primitive type keyword ;; 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) (with-slots (min-occurs max-occurs) @@ -464,29 +465,33 @@ template (let* ((tag (intern element-name (s-xml:get-package namespace))) (children (lxml-find-tags tag lxml))) - (if (symbolp (first contents)) - (let ((primitive-type (first contents))) - (case multiplicity - ((1 ?) (if children - (resolve-xsd-template-primitive element-name primitive-type (second (first children))) - (when (eql multiplicity 1) - (error "Required element ~s not bound" element-name)))) - ((+ *) (if children - (loop :for child :in children - :collect (resolve-xsd-template-primitive element-name primitive-type (second child))) - (when (eql multiplicity +) - (error "Required repeating element ~s not bound correctly" element-name)))))) - (case multiplicity - ((1 ?) (if children - `(,element-name ,(resolve-xsd-template-members contents (first children) namespace)) - (when (eql multiplicity 1) - (error "Required element ~s not bound" element-name)))) - ((+ *) (if children - `(,element-name - ,(loop :for child :in children - :collect (resolve-xsd-template-members contents child namespace))) - (when (eql multiplicity +) - (error "Required repeating element ~s not bound correctly" element-name))))))))) + (cond ((null contents) `(,element-name)) + ((symbolp (first contents)) + (let ((primitive-type (first contents))) + (case multiplicity + ((1 ?) (if children + (resolve-xsd-template-primitive element-name primitive-type + (lxml-get-contents (first children))) + (when (eql multiplicity 1) + (error "Required element ~s not bound" element-name)))) + ((+ *) (if children + (loop :for child :in children + :collect (resolve-xsd-template-primitive element-name primitive-type + (lxml-get-contents child))) + (when (eql multiplicity +) + (error "Required repeating element ~s not bound correctly" element-name))))))) + (t + (case multiplicity + ((1 ?) (if children + `(,element-name ,(resolve-xsd-template-members contents (first children) namespace)) + (when (eql multiplicity 1) + (error "Required element ~s not bound" element-name)))) + ((+ *) (if children + `(,element-name + ,(loop :for child :in children + :collect (resolve-xsd-template-members contents child namespace))) + (when (eql multiplicity +) + (error "Required repeating element ~s not bound correctly" element-name))))))))))

(defun resolve-element (element lxml xml-schema-definition namespace) (let ((template (generate-xsd-template element xml-schema-definition)))