[cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp

[Sven Van Caekenberghe]

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

Modified Files:
	wsdl.lisp 
Log Message:
renamed bind-header to bind-input-headers
now using bind-element in bind-input-headers

Date: Mon Sep 26 12:52:45 2005
Author: scaekenberghe

Index: cl-soap/src/wsdl.lisp
diff -u cl-soap/src/wsdl.lisp:1.16 cl-soap/src/wsdl.lisp:1.17
--- cl-soap/src/wsdl.lisp:1.16	Mon Sep 26 12:41:50 2005
+++ cl-soap/src/wsdl.lisp	Mon Sep 26 12:52:45 2005
@@ -1,6 +1,6 @@
 ;;;; -*- mode: lisp -*-
 ;;;;
-;;;; $Id: wsdl.lisp,v 1.16 2005/09/26 10:41:50 scaekenberghe Exp $
+;;;; $Id: wsdl.lisp,v 1.17 2005/09/26 10:52:45 scaekenberghe Exp $
 ;;;;
 ;;;; The basic WSDL protocol: we parse the generic and soap specific parts
 ;;;;
@@ -421,25 +421,18 @@
                   (t (error "Cannot resolve input binding ~a:~a" (get-name input-message) (get-name part))))))
     (nreverse actual-input-parameters)))
 
-(defun bind-headers (soap-input-headers headers wsdl-document-definitions)
-  ;; default namespace!
+(defun bind-input-headers (soap-input-headers headers wsdl-document-definitions)
   (let ((actual-headers '()))
     (loop :for part :in soap-input-headers :do
-          (let* ((value (get-name-binding (get-name part) headers))
-                 (element (get-element-named wsdl-document-definitions (get-element part)))
-                 (type (get-element-type (get-xml-schema-definition wsdl-document-definitions)
-                                         (get-name element))))
-            (if value
-                (push `(,(intern (get-name part) :keyword)
-                        ,(if (xsd-primitive-type-name-p type)
-                             (lisp->xsd-primitive value (intern-xsd-type-name type))
-                           (error "Non-primitive header type ~a not allowed" type)))
-                      actual-headers)
-              (error "No input header binding found for ~a" (get-name part)))))
+          (let* ((element (get-element part))
+                 (namespace (s-xml:find-namespace (get-target-namespace wsdl-document-definitions)))
+                 (xml-schema-definition (get-xml-schema-definition wsdl-document-definitions))
+                 (binding (bind-element element headers xml-schema-definition namespace)))
+            (when binding
+              (push binding actual-headers))))
     (nreverse actual-headers)))
 
 (defun bind-output-parts (result output-message output wsdl-document-definitions)
-  ;; namespaces!
   (declare (ignore output))
   (let ((namespace (s-xml:find-namespace (get-target-namespace wsdl-document-definitions)))
         (result-values '()))
@@ -488,7 +481,7 @@
       (error "The case where input and output namespaces differ is not yet supported"))
     (multiple-value-bind (result headers)
         (soap-call soap-end-point
-                   (bind-headers soap-input-headers headers wsdl-document-definitions)
+                   (bind-input-headers soap-input-headers headers wsdl-document-definitions)
                    ;; we assume there is only one parameter
                    (first (bind-input-parts input-message input wsdl-document-definitions))
                    :soap-action soap-action
@@ -532,14 +525,12 @@
             (error "Expected <~a> element" output-wrapper)))))))
 
 (defun wsdl-soap-input-headers (wsdl-document-definitions binding-operation-input)
-  (let ((soap-input-headers (get-extensions-of-class binding-operation-input 'wsdl-soap-header))
-        (parts '()))
-    (loop :for soap-input-header :in soap-input-headers :do
-          (let* ((part-name (get-part soap-input-header))
-                 (header-message (get-message-named wsdl-document-definitions (get-message soap-input-header))))
-            (push (get-part-named header-message part-name)
-                  parts)))
-    (nreverse parts)))
+  (let ((soap-input-headers (get-extensions-of-class binding-operation-input 'wsdl-soap-header)))
+    (loop :for soap-input-header :in soap-input-headers 
+          :collect (let* ((part-name (get-part soap-input-header))
+                          (message-name (get-message soap-input-header))
+                          (header-message (get-message-named wsdl-document-definitions message-name)))
+                     (get-part-named header-message part-name)))))
 
 (defun wsdl-soap-call-internal (wsdl-document-definitions
                                 port