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"))))