[cl-soap-cvs] CVS update: cl-soap/src/lxml.lisp cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp
Sven Van Caekenberghe
scaekenberghe at common-lisp.net
Fri Sep 16 07:51:16 UTC 2005
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
More information about the Cl-soap-cvs
mailing list