[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 08:39:17 UTC 2005
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)
More information about the Cl-soap-cvs
mailing list