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

Modified Files: wsdl.lisp xsd.lisp Log Message: removed old resolve/bind -element and replaced them by new-* versions

Date: Mon Sep 26 12:41:51 2005 Author: scaekenberghe

Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.15 cl-soap/src/wsdl.lisp:1.16 --- cl-soap/src/wsdl.lisp:1.15 Fri Sep 23 23:33:05 2005 +++ cl-soap/src/wsdl.lisp Mon Sep 26 12:41:50 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.15 2005/09/23 21:33:05 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.16 2005/09/26 10:41:50 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 (new-bind-element part-element - input - (get-xml-schema-definition wsdl-document-definitions) - namespace) + (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))) @@ -454,10 +454,10 @@ result-values))) (part-element (multiple-value-bind (value required) - (new-resolve-element part-element - result - (get-xml-schema-definition wsdl-document-definitions) - namespace) + (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))))))

Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.12 cl-soap/src/xsd.lisp:1.13 --- cl-soap/src/xsd.lisp:1.12 Mon Sep 26 10:43:56 2005 +++ cl-soap/src/xsd.lisp Mon Sep 26 12:41:50 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.12 2005/09/26 08:43:56 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.13 2005/09/26 10:41:50 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -209,44 +209,20 @@ (defun get-name-binding (name bindings) (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)) - (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 new-binding-primitive-value (name type bindings) +(defun 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))) +(defun bind-primitive (element type-name bindings namespace) + (let ((value (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) +(defun 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) @@ -258,11 +234,11 @@ (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))) + (let ((member-binding (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) + (bind-type member-type sub-bindings member xml-schema-definition namespace) (if bound (push `(,(intern member-name (s-xml:get-package namespace)) ,member-binding) @@ -271,15 +247,15 @@ (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))) + (let ((value (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) +(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) - (new-bind-primitive element element-type bindings namespace)) + (bind-primitive element element-type bindings namespace)) ((typep element-type 'xsd-complex-type) (let ((members (get-members element-type)) (members-actual-bindings '())) @@ -290,14 +266,14 @@ (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))) + (let ((member-binding (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) + (bind-type member-type sub-binding member + xml-schema-definition namespace) (when bound (incf count) (push `(,(intern member-name (s-xml:get-package namespace)) @@ -309,13 +285,13 @@ (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))) + (let ((member-binding (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) + (bind-type member-type sub-bindings member + xml-schema-definition namespace) (if bound (push `(,(intern member-name (s-xml:get-package namespace)) ,@member-binding) @@ -326,51 +302,22 @@ ,@(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))) - (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 (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) +(defun lxml-primitive-value (name type lxml namespace) (let ((tag-name (intern name (s-xml:get-package namespace)))) (if (eql (lxml-get-tag lxml) tag-name) (values (xsd-primitive->lisp (second lxml) (intern-xsd-type-name type)) t) (values nil nil))))

-(defun new-resolve-primitive (element type-name lxml namespace) +(defun resolve-primitive (element type-name lxml namespace) (multiple-value-bind (value present) - (new-lxml-primitive-value (get-name element) type-name lxml namespace) + (lxml-primitive-value (get-name element) type-name lxml namespace) (if present (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) +(defun 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) @@ -385,14 +332,14 @@ (loop :for item-lxml :in (lxml-find-tags sub-tag-name (lxml-get-children lxml)) :do (if (xsd-primitive-type-name-p member-type) (multiple-value-bind (member-value required) - (new-resolve-primitive member member-type item-lxml namespace) + (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) + (resolve-type member-type item-lxml member + xml-schema-definition namespace) (when required (incf count) (push member-name resolved-members) @@ -403,26 +350,26 @@ (let ((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) + (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) + (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) - (new-lxml-primitive-value (get-name super-element) type lxml namespace) + (lxml-primitive-value (get-name super-element) type lxml namespace) (error "unexpected type")))))

-(defun new-resolve-element (element lxml xml-schema-definition namespace) +(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) - (new-resolve-primitive element element-type lxml namespace)) + (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) @@ -439,14 +386,14 @@ (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) + (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) + (resolve-type member-type item-lxml member + xml-schema-definition namespace) (when required (incf count) (push member-name resolved-members) @@ -458,13 +405,13 @@ (let ((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) + (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) + (resolve-type member-type member-lxml member + xml-schema-definition namespace) (when required (push member-name resolved-members) (push member-value resolved-members))))))))