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

[Sven Van Caekenberghe]

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

Modified Files:
	soap.lisp 
Log Message:
added return header parsing to soap-call

Date: Mon Sep 19 18:56:13 2005
Author: scaekenberghe

Index: cl-soap/src/soap.lisp
diff -u cl-soap/src/soap.lisp:1.5 cl-soap/src/soap.lisp:1.6
--- cl-soap/src/soap.lisp:1.5	Mon Sep 12 16:28:39 2005
+++ cl-soap/src/soap.lisp	Mon Sep 19 18:56:13 2005
@@ -1,6 +1,6 @@
 ;;;; -*- mode: lisp -*-
 ;;;;
-;;;; $Id: soap.lisp,v 1.5 2005/09/12 14:28:39 scaekenberghe Exp $
+;;;; $Id: soap.lisp,v 1.6 2005/09/19 16:56:13 scaekenberghe Exp $
 ;;;;
 ;;;; The basic SOAP protocol
 ;;;;
@@ -115,14 +115,16 @@
     (when *debug-stream*
       (setf *last-soap-result-xml* result-soap-envelope))
     (if (eql (lxml-get-tag result-soap-envelope) 'soapenv:|Envelope|)
-        ;; we ignore returned headers for now
-        ;; only the first child of the body is returned, unless it is a fault
-        (let ((body (lxml-find-tag 'soapenv:|Body| (rest result-soap-envelope))))
+        (let ((headers (lxml-find-tag 'soapenv:|Header| (rest result-soap-envelope)))
+              (body (lxml-find-tag 'soapenv:|Body| (rest result-soap-envelope))))
+          ;; simply return header key/value pairs as an alist
+          (setf headers (mapcar #'(lambda (x) (cons (lxml-get-tag x) (second x))) (rest headers)))
+          ;; only the first child of the body is returned, unless it is a fault
           (if body
               (let ((fault (lxml-find-tag 'soapenv:|Fault| (rest body))))
                 (if fault
                     (error (lxml->standard-soap-fault fault))
-                  (second body)))
+                  (values (second body) headers)))
             (error "No body found in SOAP Envelope")))
       (error "No SOAP Envelope found"))))