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

Modified Files: lxml.lisp wsdl.lisp xsd.lisp Log Message: basic integration of xsd primitive type handling in wsdl-soap-call

Date: Fri Sep 16 09:51:15 2005 Author: scaekenberghe

Index: cl-soap/src/lxml.lisp diff -u cl-soap/src/lxml.lisp:1.4 cl-soap/src/lxml.lisp:1.5 --- cl-soap/src/lxml.lisp:1.4 Thu Sep 15 15:32:32 2005 +++ cl-soap/src/lxml.lisp Fri Sep 16 09:51:15 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: lxml.lisp,v 1.4 2005/09/15 13:32:32 scaekenberghe Exp $ +;;;; $Id: lxml.lisp,v 1.5 2005/09/16 07:51:15 scaekenberghe Exp $ ;;;; ;;;; Some tools to manipulate lxml ;;;; @@ -13,6 +13,8 @@

(in-package :cl-soap)

+;;; external + (defun lxml-get-tag (lxml) "Return the XML tag symbol of the lxml XML DOM" (cond ((symbolp lxml) lxml) @@ -28,5 +30,14 @@ (defun lxml-find-tag (tag lxml) "Find a specific tag in a lxml XML DOM list" (find tag lxml :key #'lxml-get-tag)) + +;;; internal + +(defun actual-name (qname) + "For now we ignore prefixes ;-)" + (multiple-value-bind (prefix identifier) + (s-xml:split-identifier qname) + (declare (ignore prefix)) + identifier))

;;;; eof

Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.6 cl-soap/src/wsdl.lisp:1.7 --- cl-soap/src/wsdl.lisp:1.6 Thu Sep 15 15:37:34 2005 +++ cl-soap/src/wsdl.lisp Fri Sep 16 09:51:15 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.6 2005/09/15 13:37:34 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.7 2005/09/16 07:51:15 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -303,13 +303,6 @@

;; Interpreting the WSDL model

-(defun actual-name (qname) - "For now we ignore prefixes ;-)" - (multiple-value-bind (prefix identifier) - (s-xml:split-identifier qname) - (declare (ignore prefix)) - identifier)) - (defun find-item-named (item-name sequence) (find (actual-name item-name) sequence :test #'string-equal :key #'get-name))

@@ -436,12 +429,16 @@ (s-xml:register-namespace input-namespace-uri "ns1" :ns1) (error "The case where input and output namespaces differ is not yet supported")) (loop :for part :in (get-parts input-message) :do - (let* ((value (second (member (get-name part) input :test #'equal)))) + (let* ((value (second (member (get-name part) input :test #'equal))) + (part-type (get-type part))) (if value (push `((,(intern (get-name part) :keyword) xsi::|type| ,(get-type part)) - ,(princ-to-string value)) - actual-input-parameters) + ;; basic type conversions ;-) + ,(if (xsd-primitive-type-name-p part-type) + (lisp->xsd-primitive value (intern-xsd-type-name part-type)) + (princ-to-string value))) + actual-input-parameters) (error "No input binding found for ~a:~a" (get-name input-message) (get-name part))))) (let* ((input-wrapper (intern (get-name binding-operation) :ns1)) (result (soap-call soap-end-point @@ -456,10 +453,17 @@ (if (eql (lxml-get-tag result) output-wrapper) (progn (loop :for part :in (get-parts output-message) :do - (let ((part-element (lxml-find-tag (intern (get-name part) :keyword) (rest result)))) - ;; add type conversions ;-) - (push (rest part-element) result-values))) - (nreverse result-values)) + (let* ((part-element (lxml-find-tag (intern (get-name part) :keyword) (rest result))) + (part-value (second part-element)) + (part-type (get-type part))) ;; part-element might have a type attribute as well + ;; basic type conversions ;-) + (if (xsd-primitive-type-name-p part-type) + (push (xsd-primitive->lisp part-value (intern-xsd-type-name part-type)) + result-values) + (push part-value result-values)))) + (if (= (length result-values) 1) + (first result-values) + (nreverse result-values))) (error "Expected <~a> element" output-wrapper)))) (error "Only standard SOAP RPC style currently supported as binding")) (error "Only standard SOAP HTTP transport currently supported as binding"))))

Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.1 cl-soap/src/xsd.lisp:1.2 --- cl-soap/src/xsd.lisp:1.1 Thu Sep 15 15:37:34 2005 +++ cl-soap/src/xsd.lisp Fri Sep 16 09:51:15 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.1 2005/09/15 13:37:34 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.2 2005/09/16 07:51:15 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -97,14 +97,79 @@

;;; Interpreting the XSD model

-;;; Primitive Types/Values +;;; Primitive Types/Values (types are keywords) + +(defconstant +known-primitive-type-names+ + '("string" + "normalizedString" "token" + "Name" "QName" "NCName" "anyURI" + "integer" + "positiveInteger" "negativeInteger" "nonPositiveInteger" "nonNegativeInteger" + "long" "unsignedLong" "int" "unsignedInt" "short" "unsignedShort" + "byte" "decimal" + "float" "double" + "boolean" + "duration" "date" "time" "dateTime" + "base64Binary" "hexBinary")) + +(defun xsd-primitive-type-name-p (name) + (member (actual-name name) +known-primitive-type-names+ :test #'string-equal)) + +(defun intern-xsd-type-name (name) + (intern (string-upcase (actual-name name)) :keyword))

(defun xsd-primitive->lisp (value type) - (declare (ignore type)) - value) + "Convert the XSD string value to a Common Lisp value, interpreting it as type" + ;; more work needed here ;-) + (ecase type + ((:string :normalizedString :token) + value) + ((:Name :QName :NCName :anyURI) + value) + ((:integer + :positiveInteger :negativeInteger :nonPositiveInteger :nonNegativeInteger + :long :unsignedLong :int :unsignedInt :short :unsignedShort + :byte :decimal) + (parse-integer value) 'integer) + (:float + (coerce (read-from-string value) 'float)) + (:double + (coerce (read-from-string value) 'double)) + (:boolean + (cond ((string-equal value "true") t) + ((string-equal value "false") nil) + (t (= (parse-integer value) 1)))) + (:duration value) + (:date value) + (:time value) + (:dateTime value) + ((:base64Binary :hexBinary) + (error "~a not yet supported as primitive type" type))))

(defun lisp->xsd-primitive (value type) - (declare (ignore type)) - value) + "Convert the Common Lisp value to a XSD string value, interpreting it as type" + ;; more work needed here ;-) + (ecase type + ((:string :normalizedString :token) + value) + ((:Name :QName :NCName :anyURI) + value) + ((:integer + :positiveInteger :negativeInteger :nonPositiveInteger :nonNegativeInteger + :long :unsignedLong :int :unsignedInt :short :unsignedShort + :byte :decimal) + (princ-to-string value)) + (:float + (princ-to-string value)) + (:double + (princ-to-string value)) + (:boolean + (if value "true" "false")) + (:duration value) + (:date value) + (:time value) + (:dateTime value) + ((:base64Binary :hexBinary) + (error "~a not yet supported as primitive type" type))))

;;;; eof