[cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp
Sven Van Caekenberghe
scaekenberghe at common-lisp.net
Fri Sep 23 21:33:07 UTC 2005
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))
+ , at 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))
+ , at 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)
More information about the Cl-soap-cvs
mailing list