Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv4304/src Modified Files: wsdl.lisp xsd.lisp Log Message: moved bind-element & resolve-element from wsdl.lisp to xsd.lisp preparing for refactoring/rewriting Date: Fri Sep 23 10:39:14 2005 Author: scaekenberghe Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.13 cl-soap/src/wsdl.lisp:1.14 --- cl-soap/src/wsdl.lisp:1.13 Fri Sep 23 10:06:36 2005 +++ cl-soap/src/wsdl.lisp Fri Sep 23 10:39:13 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.13 2005/09/23 08:06:36 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.14 2005/09/23 08:39:13 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -397,38 +397,9 @@ ;; Using WSDL to make structured SOAP calls -(defun get-name-binding (name bindings) - (second (member name bindings :test #'equal))) - -(defun bind-element (element bindings wsdl-document-definitions) - (let* ((element (if (stringp element) - (get-element-named wsdl-document-definitions element) - element)) - (element-type (get-type-in-context element (get-xml-schema-definition wsdl-document-definitions))) - (namespace (s-xml:find-namespace (get-target-namespace wsdl-document-definitions)))) - (cond ((xsd-primitive-type-name-p element-type) - (let ((value (get-name-binding (get-name element) bindings))) - (if value - `(,(intern (get-name element) (s-xml:get-package namespace)) - ,(lisp->xsd-primitive value (intern-xsd-type-name element-type))) - (if (is-optional-p element) - nil - (error "Cannot find binding for ~a" (get-name element)))))) - ((typep element-type 'xsd-complex-type) - (let ((members (get-members element-type)) - (member-actual-bindings '())) - (loop :for member :in members :do - (let* ((sub-bindings (or (get-name-binding (get-name element-type) bindings) - bindings)) - (member-binding (bind-element member sub-bindings wsdl-document-definitions))) - (if member-binding - (push member-binding member-actual-bindings)))) - `(,(intern (get-name element) (s-xml:get-package namespace)) - ,@(nreverse member-actual-bindings)))) - (t (error "Cannot bind element ~s of type ~s" element element-type))))) - (defun bind-input-parts (input-message input wsdl-document-definitions) - (let ((actual-input-parameters '())) + (let ((namespace (s-xml:find-namespace (get-target-namespace wsdl-document-definitions))) + (actual-input-parameters '())) (loop :for part :in (get-parts input-message) :do (let ((part-element (get-element part)) (part-type (get-type part))) @@ -442,7 +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 wsdl-document-definitions) + (push (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))) @@ -464,42 +438,11 @@ (error "No input header binding found for ~a" (get-name part))))) (nreverse actual-headers))) -(defun resolve-element (element lxml wsdl-document-definitions) - (let* ((element (if (stringp element) - (get-element-named wsdl-document-definitions element) - element)) - (element-type (get-type-in-context element (get-xml-schema-definition wsdl-document-definitions))) - (namespace (s-xml:find-namespace (get-target-namespace wsdl-document-definitions)))) - (cond ((xsd-primitive-type-name-p element-type) - (let ((tag-name (intern (get-name element) (s-xml:get-package namespace)))) - (if (eql (lxml-get-tag lxml) tag-name) - (values (xsd-primitive->lisp (second lxml) (intern-xsd-type-name element-type)) t) - (if (is-optional-p element) - (values nil nil) - (error "Expected a <~a> element" tag-name))))) - ((typep element-type 'xsd-complex-type) - (let ((tag-name (intern (get-name element) (s-xml:get-package namespace))) - (members (get-members element-type))) - (if (eql (lxml-get-tag lxml) tag-name) - (let ((resolved-members '())) - (loop :for member :in members :do - (let* ((sub-tag-name (intern (get-name member) (s-xml:get-package namespace))) - (sub-lxml (lxml-find-tag sub-tag-name (rest lxml)))) - (multiple-value-bind (value required) - (resolve-element member sub-lxml wsdl-document-definitions) - (when required - (push (get-name element) resolved-members) - (push value resolved-members))))) - (values (nreverse resolved-members) t)) - (if (zerop (get-min-occurs element)) - (values nil nil) - (error "Expected a <~a> element" tag-name))))) - (t (error "Cannot bind element ~s of type ~s" element element-type))))) - (defun bind-output-parts (result output-message output wsdl-document-definitions) ;; namespaces! (declare (ignore output)) - (let ((result-values '())) + (let ((namespace (s-xml:find-namespace (get-target-namespace wsdl-document-definitions))) + (result-values '())) (loop :for part :in (get-parts output-message) :do (let ((part-type (get-type part)) (part-element (get-element part))) @@ -510,7 +453,10 @@ (push (xsd-primitive->lisp part-value (intern-xsd-type-name part-type)) result-values))) (part-element - (push (resolve-element part-element result wsdl-document-definitions) + (push (resolve-element part-element + result + (get-xml-schema-definition wsdl-document-definitions) + namespace) result-values)) (t (error "Cannot resolve output binding ~a:~a" (get-name output-message) (get-name part)))))) ;; make the common case more handy Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.7 cl-soap/src/xsd.lisp:1.8 --- cl-soap/src/xsd.lisp:1.7 Fri Sep 23 10:06:38 2005 +++ cl-soap/src/xsd.lisp Fri Sep 23 10:39:13 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.7 2005/09/23 08:06:38 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.8 2005/09/23 08:39:13 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -200,6 +200,64 @@ (defmethod is-plural-p ((xml-schema-element xml-schema-element)) (eql (get-max-occurs xml-schema-element) :unbounded)) + +;;; Binding and Resolving elements to and from actual data + +(defun get-name-binding (name bindings) + (second (member name bindings :test #'string-equal))) + +(defun 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) + (let ((value (get-name-binding (get-name element) bindings))) + (if value + `(,(intern (get-name element) (s-xml:get-package namespace)) + ,(lisp->xsd-primitive value (intern-xsd-type-name element-type))) + (if (is-optional-p element) + nil + (error "Cannot find binding for ~a" (get-name element)))))) + ((typep element-type 'xsd-complex-type) + (let ((members (get-members element-type)) + (member-actual-bindings '())) + (loop :for member :in members :do + (let* ((sub-bindings (or (get-name-binding (get-name element-type) bindings) + bindings)) + (member-binding (bind-element member sub-bindings xml-schema-definition namespace))) + (if member-binding + (push member-binding member-actual-bindings)))) + `(,(intern (get-name element) (s-xml:get-package namespace)) + ,@(nreverse member-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))) + (cond ((xsd-primitive-type-name-p element-type) + (let ((tag-name (intern (get-name element) (s-xml:get-package namespace)))) + (if (eql (lxml-get-tag lxml) tag-name) + (values (xsd-primitive->lisp (second lxml) (intern-xsd-type-name element-type)) t) + (if (is-optional-p element) + (values nil nil) + (error "Expected a <~a> element" tag-name))))) + ((typep element-type 'xsd-complex-type) + (let ((tag-name (intern (get-name element) (s-xml:get-package namespace))) + (members (get-members element-type))) + (if (eql (lxml-get-tag lxml) tag-name) + (let ((resolved-members '())) + (loop :for member :in members :do + (let* ((sub-tag-name (intern (get-name member) (s-xml:get-package namespace))) + (sub-lxml (lxml-find-tag sub-tag-name (rest lxml)))) + (multiple-value-bind (value required) + (resolve-element member sub-lxml xml-schema-definition namespace) + (when required + (push (get-name element) resolved-members) + (push value resolved-members))))) + (values (nreverse resolved-members) t)) + (if (zerop (get-min-occurs element)) + (values nil nil) + (error "Expected a <~a> element" tag-name))))) + (t (error "Cannot bind element ~s of type ~s" element element-type))))) ;;; Describing XSD (with pre-rendering of XML)