Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv26091/src
Modified Files: wsdl.lisp xsd.lisp Log Message: added new, better structured new-bind-element & new-resolve-element functions to xsd to bind wsdl-soap-call document-style input/output binding
Date: Fri Sep 23 23:33:05 2005 Author: scaekenberghe
Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.14 cl-soap/src/wsdl.lisp:1.15 --- cl-soap/src/wsdl.lisp:1.14 Fri Sep 23 10:39:13 2005 +++ cl-soap/src/wsdl.lisp Fri Sep 23 23:33:05 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.14 2005/09/23 08:39:13 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.15 2005/09/23 21:33:05 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -413,10 +413,10 @@ (unless (is-optional-p part-element) (error "No input binding found for ~a:~a" (get-name input-message) (get-name part)))))) (part-element - (push (bind-element part-element - input - (get-xml-schema-definition wsdl-document-definitions) - namespace) + (push (new-bind-element part-element + input + (get-xml-schema-definition wsdl-document-definitions) + namespace) actual-input-parameters)) (t (error "Cannot resolve input binding ~a:~a" (get-name input-message) (get-name part)))))) (nreverse actual-input-parameters))) @@ -453,11 +453,13 @@ (push (xsd-primitive->lisp part-value (intern-xsd-type-name part-type)) result-values))) (part-element - (push (resolve-element part-element - result - (get-xml-schema-definition wsdl-document-definitions) - namespace) - result-values)) + (multiple-value-bind (value required) + (new-resolve-element part-element + result + (get-xml-schema-definition wsdl-document-definitions) + namespace) + (when required + (push value result-values)))) (t (error "Cannot resolve output binding ~a:~a" (get-name output-message) (get-name part)))))) ;; make the common case more handy (if (= (length result-values) 1)
Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.9 cl-soap/src/xsd.lisp:1.10 --- cl-soap/src/xsd.lisp:1.9 Fri Sep 23 10:41:51 2005 +++ cl-soap/src/xsd.lisp Fri Sep 23 23:33:05 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.9 2005/09/23 08:41:51 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.10 2005/09/23 21:33:05 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -204,7 +204,7 @@ ;;; Binding and Resolving elements to and from actual data
(defun get-name-binding (name bindings) - (second (member name bindings :test #'equal))) + (second (member (actual-name name) bindings :test #'equal)))
(defun bind-element (element bindings xml-schema-definition namespace) (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) @@ -230,6 +230,99 @@ ,@(nreverse member-actual-bindings)))) (t (error "Cannot bind element ~s of type ~s" element element-type)))))
+(defun new-binding-primitive-value (name type bindings) + (let ((value (get-name-binding name bindings))) + (when value + (lisp->xsd-primitive value (intern-xsd-type-name type))))) + +(defun new-bind-primitive (element type-name bindings namespace) + (let ((value (new-binding-primitive-value (get-name element) type-name bindings))) + (if value + `(,(intern (get-name element) (s-xml:get-package namespace)) ,value) + (if (is-optional-p element) + nil + (error "Cannot find binding for ~a" (get-name element)))))) + +(defun new-bind-type (type-name bindings super-element xml-schema-definition namespace) + (let* ((type-element (get-element-named xml-schema-definition type-name)) + (type (get-element-type xml-schema-definition type-element))) + (if (typep type 'xsd-complex-type) + (let ((members (get-members type)) + (members-actual-bindings '())) + (loop :for member :in members :do + (let ((member-name (get-name member)) + (member-type (get-type member)) + (sub-bindings (or (get-name-binding (get-name type-element) bindings) + bindings))) + (if (xsd-primitive-type-name-p member-type) + (let ((member-binding (new-bind-primitive member member-type sub-bindings namespace))) + (when member-binding + (push member-binding members-actual-bindings))) + (multiple-value-bind (member-binding bound) + (new-bind-type member-type sub-bindings member xml-schema-definition namespace) + (if bound + (push `(,(intern member-name (s-xml:get-package namespace)) + ,member-binding) + members-actual-bindings) + (unless (is-optional-p member) + (error "Required member ~a not bound" member-name))))))) + (values (nreverse members-actual-bindings) t)) + (if (xsd-primitive-type-name-p type) + (let ((value (new-binding-primitive-value (get-name super-element) type bindings))) + (if value (values value t) (values nil nil))) + (error "unexpected type"))))) + +(defun new-bind-element (element bindings xml-schema-definition namespace) + (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) + (element-type (get-element-type xml-schema-definition element))) + (cond ((xsd-primitive-type-name-p element-type) + (new-bind-primitive element element-type bindings namespace)) + ((typep element-type 'xsd-complex-type) + (let ((members (get-members element-type)) + (members-actual-bindings '())) + (loop :for member :in members :do + (let* ((member-name (get-name member)) + (member-type (get-type member))) + (if (is-plural-p member) + (let ((count 0)) + (loop :for sub-binding :in bindings :do + (if (xsd-primitive-type-name-p member-type) + (let ((member-binding (new-bind-primitive member member-type + sub-binding namespace))) + (when member-binding + (incf count) + (push member-binding members-actual-bindings))) + (multiple-value-bind (member-binding bound) + (new-bind-type member-type sub-binding member + xml-schema-definition namespace) + (when bound + (incf count) + (push `(,(intern member-name (s-xml:get-package namespace)) + ,@member-binding) + members-actual-bindings))))) + (if (zerop count) + (unless (is-optional-p member) + (error "Required member ~a not bound" member-name)))) + (let ((sub-bindings (or (get-name-binding member-type bindings) + bindings))) + (if (xsd-primitive-type-name-p member-type) + (let ((member-binding (new-bind-primitive member member-type + bindings namespace))) + (when member-binding + (push member-binding members-actual-bindings))) + (multiple-value-bind (member-binding bound) + (new-bind-type member-type sub-bindings member + xml-schema-definition namespace) + (if bound + (push `(,(intern member-name (s-xml:get-package namespace)) + ,@member-binding) + members-actual-bindings) + (unless (is-optional-p member) + (error "Required member ~a not bound" member-name))))))))) + `(,(intern (get-name element) (s-xml:get-package namespace)) + ,@(nreverse members-actual-bindings)))) + (t (error "Cannot bind element ~s of type ~s" element element-type))))) + (defun resolve-element (element lxml xml-schema-definition namespace) (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) (element-type (get-element-type xml-schema-definition element))) @@ -254,10 +347,109 @@ (push (get-name element) resolved-members) (push value resolved-members))))) (values (nreverse resolved-members) t)) - (if (zerop (get-min-occurs element)) + (if (is-optional-p element) (values nil nil) (error "Expected a <~a> element" tag-name))))) (t (error "Cannot bind element ~s of type ~s" element element-type))))) + +(defun new-lxml-primitive-value (name type lxml namespace) + (let ((tag-name (intern name (s-xml:get-package namespace)))) + (when (eql (lxml-get-tag lxml) tag-name) + (xsd-primitive->lisp (second lxml) (intern-xsd-type-name type))))) + +(defun new-resolve-primitive (element type-name lxml namespace) + (let ((value (new-lxml-primitive-value (get-name element) type-name lxml namespace))) + (if value + (values value t) + (if (is-optional-p element) + (values nil nil) + (error "Expected a <~a> element" (get-name element)))))) + +(defun new-resolve-type (type-name lxml super-element xml-schema-definition namespace) + (let* ((type-element (get-element-named xml-schema-definition type-name)) + (type (get-element-type xml-schema-definition type-element))) + (if (typep type 'xsd-complex-type) + (let ((members (get-members type)) + (resolved-members '())) + (loop :for member :in members :do + (let* ((member-name (get-name member)) + (member-type (get-type member)) + (sub-tag-name (intern member-name (s-xml:get-package namespace))) + (member-lxml (lxml-find-tag sub-tag-name lxml))) + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (new-resolve-primitive member member-type member-lxml namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members))) + (multiple-value-bind (member-value required) + (new-resolve-type member-type member-lxml member + xml-schema-definition namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members)))))) + (values (nreverse resolved-members) t)) + (if (xsd-primitive-type-name-p type) + (let ((value (new-lxml-primitive-value (get-name super-element) type lxml namespace))) + (if value (values value t) (values nil nil))) + (error "unexpected type"))))) + +(defun new-resolve-element (element lxml xml-schema-definition namespace) + (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) + (element-type (get-element-type xml-schema-definition element))) + (cond ((xsd-primitive-type-name-p element-type) + (new-resolve-primitive element element-type lxml namespace)) + ((typep element-type 'xsd-complex-type) + (let ((tag-name (intern (get-name element) (s-xml:get-package namespace)))) + (if (eql (lxml-get-tag lxml) tag-name) + (let ((sub-lxml (lxml-get-children lxml)) + (members (get-members element-type)) + (resolved-members '())) + (loop :for member :in members :do + (let* ((member-name (get-name member)) + (member-type (get-type member))) + (if (is-plural-p member) + (let ((count 0)) + (loop :for item-lxml :in sub-lxml :do + (let ((sub-tag-name (intern member-name (s-xml:get-package namespace)))) + (if (eql (lxml-get-tag item-lxml) sub-tag-name) + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (new-resolve-primitive member member-type item-lxml namespace) + (when required + (incf count) + (push member-name resolved-members) + (push member-value resolved-members))) + (multiple-value-bind (member-value required) + (new-resolve-type member-type item-lxml member + xml-schema-definition namespace) + (when required + (incf count) + (push member-name resolved-members) + (push member-value resolved-members)))) + (error "Expected a <~a> element" sub-tag-name)))) + (if (zerop count) + (unless (is-optional-p member) + (error "Required element <~a> not found" member-name)))) + (let* ((sub-tag-name (intern member-name (s-xml:get-package namespace))) + (member-lxml (lxml-find-tag sub-tag-name sub-lxml))) + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (new-resolve-primitive member member-type member-lxml namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members))) + (multiple-value-bind (member-value required) + (new-resolve-type member-type member-lxml member + xml-schema-definition namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members)))))))) + (values (list (get-name element) (nreverse resolved-members)) t)) + (if (is-optional-p element) + (values nil nil) + (error "Expected a <~a> element" tag-name))))) + (t (error "Cannot resolve element ~s of type ~s" element element-type)))))
;;; Describing XSD (with pre-rendering of XML)