[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
Wed Sep 21 17:08:05 UTC 2005
Update of /project/cl-soap/cvsroot/cl-soap/src
In directory common-lisp.net:/tmp/cvs-serv31405/src
Modified Files:
lxml.lisp wsdl.lisp xsd.lisp
Log Message:
added more code to actually implement wsd-soap-call for document oriented soap calls with xsd type descriptions
Date: Wed Sep 21 19:08:03 2005
Author: scaekenberghe
Index: cl-soap/src/lxml.lisp
diff -u cl-soap/src/lxml.lisp:1.5 cl-soap/src/lxml.lisp:1.6
--- cl-soap/src/lxml.lisp:1.5 Fri Sep 16 09:51:15 2005
+++ cl-soap/src/lxml.lisp Wed Sep 21 19:08:03 2005
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: lxml.lisp,v 1.5 2005/09/16 07:51:15 scaekenberghe Exp $
+;;;; $Id: lxml.lisp,v 1.6 2005/09/21 17:08:03 scaekenberghe Exp $
;;;;
;;;; Some tools to manipulate lxml
;;;;
@@ -24,9 +24,17 @@
(defun lxml-get-attributes (lxml)
"Return the XML attributes plist of the lxml XML DOM"
- (cond ((or (symbolp lxml) (stringp lxml) (symbolp (first lxml))) '())
+ (cond ((or (symbolp lxml)
+ (stringp lxml)
+ (symbolp (first lxml))) '())
(t (rest (first lxml)))))
+(defun lxml-get-children (lxml)
+ "Return the XML children list of the lxml XML DOM"
+ (cond ((or (symbolp lxml)
+ (stringp lxml)) '())
+ (t (rest lxml))))
+
(defun lxml-find-tag (tag lxml)
"Find a specific tag in a lxml XML DOM list"
(find tag lxml :key #'lxml-get-tag))
@@ -39,5 +47,8 @@
(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))
;;;; eof
Index: cl-soap/src/wsdl.lisp
diff -u cl-soap/src/wsdl.lisp:1.9 cl-soap/src/wsdl.lisp:1.10
--- cl-soap/src/wsdl.lisp:1.9 Mon Sep 19 20:26:55 2005
+++ cl-soap/src/wsdl.lisp Wed Sep 21 19:08:03 2005
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: wsdl.lisp,v 1.9 2005/09/19 18:26:55 scaekenberghe Exp $
+;;;; $Id: wsdl.lisp,v 1.10 2005/09/21 17:08:03 scaekenberghe Exp $
;;;;
;;;; The basic WSDL protocol: we parse the generic and soap specific parts
;;;;
@@ -123,7 +123,7 @@
(loop :for element :in (rest lxml) :do
(if (eql (lxml-get-tag element) 'xsd:|schema|)
(push (lxml->schema-definition element) types)))
- types))
+ (nreverse types)))
(defun lxml->operation-element (lxml)
(let* ((attributes (lxml-get-attributes lxml))
@@ -303,9 +303,6 @@
;; Interpreting the WSDL model
-(defun find-item-named (item-name sequence)
- (find (actual-name item-name) sequence :test #'string-equal :key #'get-name))
-
(defmethod get-service-named ((wsdl-document-definitions wsdl-document-definitions) service-name)
(find-item-named service-name (get-services wsdl-document-definitions)))
@@ -327,6 +324,9 @@
(defmethod get-operation-named ((wsdl-port-type wsdl-port-type) operation-name)
(find-item-named operation-name (get-operations wsdl-port-type)))
+(defmethod get-part-named ((wsdl-message wsdl-message) part-name)
+ (find-item-named part-name (get-parts wsdl-message)))
+
(defun find-item-of-class (class-name sequence)
(let ((class (find-class class-name)))
(find-if #'(lambda (c) (eql c class)) sequence :key #'class-of)))
@@ -337,6 +337,13 @@
(defmethod get-extension-of-class ((wsdl-extensions-mixin wsdl-extensions-mixin) extension-type)
(find-item-of-class extension-type (get-extensions wsdl-extensions-mixin)))
+(defmethod get-extensions-of-class ((wsdl-extensions-mixin wsdl-extensions-mixin) extension-type)
+ (let ((class (find-class extension-type)))
+ (remove-if-not #'(lambda (c) (eql c class)) (get-extensions wsdl-extensions-mixin) :key #'class-of)))
+
+(defmethod get-element-named ((wsdl-document-definitions wsdl-document-definitions) element-name)
+ (find-item-named element-name (get-elements (first (get-types wsdl-document-definitions)))))
+
;; Describing WSDL
(defun describe-wsdl-soap (wsdl-document-definitions)
@@ -373,43 +380,148 @@
;; Using WSDL to make structured SOAP calls
-(defun bind-input-parts (input-message input)
+(defun get-name-binding (name bindings)
+ (second (member name bindings :test #'equal)))
+
+(defun bind-element (element bindings wsdl-document-definitions)
+ (let* ((element (if (stringp element)
+ (get-element-named wsdl-document-definitions element)
+ element))
+ (element-type (get-type-in-context element
+ (get-elements (first (get-types wsdl-document-definitions)))))
+ (namespace (s-xml:find-namespace (get-target-namespace wsdl-document-definitions))))
+ (cond ((and (stringp element-type) (xsd-primitive-type-name-p element-type))
+ `(,(intern (get-name element) (s-xml:get-package namespace))
+ ,(lisp->xsd-primitive (get-name-binding (get-name element) bindings)
+ (intern-xsd-type-name element-type))))
+ ((typep element-type 'xsd-complex-type)
+ (let ((members (get-members element-type))
+ (member-actual-bindings '()))
+ (loop :for member :in members :do
+ (push (bind-element member bindings wsdl-document-definitions)
+ member-actual-bindings))
+ `(,(intern (get-name element) (s-xml:get-package namespace))
+ ,@(nreverse member-actual-bindings))))
+ (t (error "Cannot bind element ~s of type ~s" element element-type)))))
+
+(defun bind-input-parts (input-message input wsdl-document-definitions)
(let ((actual-input-parameters '()))
(loop :for part :in (get-parts input-message) :do
- (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))
- ;; 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 ((part-element (get-element part))
+ (part-type (get-type part)))
+ (cond ((xsd-primitive-type-name-p part-type)
+ (let ((value (get-name-binding (get-name part) input)))
+ (if value
+ (push `((,(intern (get-name part) :keyword) ;; default namespace!
+ xsi::|type| ,part-type)
+ ,(lisp->xsd-primitive value (intern-xsd-type-name part-type)))
+ actual-input-parameters)
+ (error "No input binding found for ~a:~a" (get-name input-message) (get-name part)))))
+ (part-element
+ (push (bind-element part-element input wsdl-document-definitions)
+ actual-input-parameters))
+ (t (error "Cannot resolve input binding ~a:~a" (get-name input-message) (get-name part))))))
(nreverse actual-input-parameters)))
-(defun bind-headers (headers)
- (declare (ignore headers))
- nil)
+(defun bind-headers (soap-input-headers headers wsdl-document-definitions)
+ ;; default namespace!
+ (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 (first (get-types 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)))))
+ (nreverse actual-headers)))
+
+(defun resolve-element (element lxml wsdl-document-definitions)
+ (let* ((element (if (stringp element)
+ (get-element-named wsdl-document-definitions element)
+ element))
+ (element-type (get-type-in-context element
+ (get-elements (first (get-types wsdl-document-definitions)))))
+ (namespace (s-xml:find-namespace (get-target-namespace wsdl-document-definitions))))
+ (cond ((and (stringp element-type) (xsd-primitive-type-name-p element-type))
+ (let ((tag-name (intern (get-name element) (s-xml:get-package namespace))))
+ (if (eql (lxml-get-tag lxml) tag-name)
+ (xsd-primitive->lisp (second lxml) (intern-xsd-type-name element-type))
+ (error "Expected a <~a> element" tag-name))))
+ ((typep element-type 'xsd-complex-type)
+ (let ((tag-name (intern (get-name element) (s-xml:get-package namespace)))
+ (members (get-members element-type)))
+ (if (eql (lxml-get-tag lxml) tag-name)
+ (loop :for member :in members :collect
+ (let* ((sub-tag-name (intern (get-name member) (s-xml:get-package namespace)))
+ (sub-lxml (lxml-find-tag sub-tag-name (rest lxml))))
+ (resolve-element member sub-lxml wsdl-document-definitions)))
+ (error "Expected a <~a> element" tag-name))))
+ (t (error "Cannot bind element ~s of type ~s" element element-type)))))
-(defun bind-output-parts (result output-message output)
+(defun bind-output-parts (result output-message output wsdl-document-definitions)
+ ;; namespaces!
(declare (ignore output))
(let ((result-values '()))
(loop :for part :in (get-parts output-message) :do
- (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))))
+ (let ((part-type (get-type part))
+ (part-element (get-element part)))
+ (cond ((xsd-primitive-type-name-p part-type)
+ (let* ((tag-name (intern (get-name part) :keyword)) ;; default namespace!
+ (part-tag (lxml-find-tag tag-name (rest result)))
+ (part-value (second part-tag))) ;; part-tag might have a type attribute as well
+ (push (xsd-primitive->lisp part-value (intern-xsd-type-name part-type))
+ result-values)))
+ (part-element
+ (push (resolve-element part-element result wsdl-document-definitions)
+ result-values))
+ (t (error "Cannot resolve output binding ~a:~a" (get-name output-message) (get-name part))))))
+ ;; make the common case more handy
(if (= (length result-values) 1)
(first result-values)
(nreverse result-values))))
-(defun wsdl-soap-rpc-call (soap-end-point
+(defun wsdl-soap-document-call (wsdl-document-definitions
+ soap-end-point
+ soap-action
+ input-message
+ output-message
+ soap-input-body
+ soap-input-headers
+ soap-output-body
+ input
+ output
+ headers)
+ (let ((input-namespace-uri (or (get-namespace soap-input-body)
+ (get-target-namespace wsdl-document-definitions)))
+ (output-namespace-uri (or (get-namespace soap-output-body)
+ (get-target-namespace wsdl-document-definitions)))
+ namespace)
+ (if (equal input-namespace-uri output-namespace-uri)
+ (setf namespace (or (s-xml:find-namespace input-namespace-uri)
+ (s-xml:register-namespace input-namespace-uri "ns1" :ns1)))
+ (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)
+ ;; we assume there is only one parameter
+ (first (bind-input-parts input-message input wsdl-document-definitions))
+ :soap-action soap-action
+ :envelope-attributes `(,(intern (format nil "xmlns:~a" (s-xml:get-prefix namespace))
+ :keyword)
+ ,input-namespace-uri
+ :|xmlns|
+ ,input-namespace-uri))
+ ;; we assume there is only one result
+ (values (first (bind-output-parts result output-message output wsdl-document-definitions))
+ headers))))
+
+(defun wsdl-soap-rpc-call (wsdl-document-definitions
+ soap-end-point
soap-action
binding-operation
input-message
@@ -417,25 +529,36 @@
soap-input-body
soap-output-body
input
- output
- headers)
+ output)
(let ((input-namespace-uri (get-namespace soap-input-body))
(output-namespace-uri (get-namespace soap-output-body)))
(if (equal input-namespace-uri output-namespace-uri)
(s-xml:register-namespace input-namespace-uri "ns1" :ns1)
(error "The case where input and output namespaces differ is not yet supported"))
- (let* ((input-wrapper (intern (get-name binding-operation) :ns1))
- (result (soap-call soap-end-point
- (bind-headers headers)
- `((,input-wrapper
- soapenv:|encodingStyle| ,+soap-enc-ns-uri+
- :|xmlns:ns1| ,input-namespace-uri)
- ,@(bind-input-parts input-message input))
- :soap-action soap-action))
- (output-wrapper (intern (get-name output-message) :ns1)))
- (if (eql (lxml-get-tag result) output-wrapper)
- (bind-output-parts result output-message output)
- (error "Expected <~a> element" output-wrapper)))))
+ (let ((input-wrapper (intern (get-name binding-operation) :ns1)))
+ (multiple-value-bind (result headers)
+ (soap-call soap-end-point
+ '()
+ `((,input-wrapper
+ soapenv:|encodingStyle| ,+soap-enc-ns-uri+
+ :|xmlns:ns1| ,input-namespace-uri)
+ ,@(bind-input-parts input-message input wsdl-document-definitions))
+ :soap-action soap-action)
+ (let ((output-wrapper (intern (get-name output-message) :ns1)))
+ (if (eql (lxml-get-tag result) output-wrapper)
+ (values (bind-output-parts result output-message output wsdl-document-definitions)
+ headers)
+ (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)))
(defun wsdl-soap-call-internal (wsdl-document-definitions
port
@@ -453,6 +576,7 @@
(soap-action (get-soap-action soap-operation))
(binding-operation-input (get-operation-element binding-operation 'wsdl-input))
(soap-input-body (get-extension-of-class binding-operation-input 'wsdl-soap-body))
+ (soap-input-headers (wsdl-soap-input-headers wsdl-document-definitions binding-operation-input))
(binding-operation-output (get-operation-element binding-operation 'wsdl-output))
(soap-output-body (get-extension-of-class binding-operation-output 'wsdl-soap-body))
(port-type-operation (get-operation-named port-type operation-name))
@@ -461,22 +585,36 @@
(output-message (get-message-named wsdl-document-definitions
(get-message (get-operation-element port-type-operation 'wsdl-output)))))
(if (string-equal (get-transport soap-binding) "http://schemas.xmlsoap.org/soap/http")
- (if (and (string-equal (get-style soap-binding) "rpc")
- (string-equal (get-use soap-input-body) "encoded")
- (string-equal (get-use soap-output-body) "encoded")
- (string-equal (get-encoding-style soap-input-body) "http://schemas.xmlsoap.org/soap/encoding/")
- (string-equal (get-encoding-style soap-output-body) "http://schemas.xmlsoap.org/soap/encoding/"))
- (wsdl-soap-rpc-call soap-end-point
- soap-action
- binding-operation
- input-message
- output-message
- soap-input-body
- soap-output-body
- input
- output
- headers)
- (error "Only standard SOAP RPC style currently supported as binding"))
+ (cond ((and (string-equal (get-style soap-binding) "rpc")
+ (string-equal (get-use soap-input-body) "encoded")
+ (string-equal (get-use soap-output-body) "encoded")
+ (string-equal (get-encoding-style soap-input-body) "http://schemas.xmlsoap.org/soap/encoding/")
+ (string-equal (get-encoding-style soap-output-body) "http://schemas.xmlsoap.org/soap/encoding/"))
+ (wsdl-soap-rpc-call wsdl-document-definitions
+ soap-end-point
+ soap-action
+ binding-operation
+ input-message
+ output-message
+ soap-input-body
+ soap-output-body
+ input
+ output))
+ ((and (string-equal (get-style soap-binding) "document")
+ (string-equal (get-use soap-input-body) "literal")
+ (string-equal (get-use soap-output-body) "literal"))
+ (wsdl-soap-document-call wsdl-document-definitions
+ soap-end-point
+ soap-action
+ input-message
+ output-message
+ soap-input-body
+ soap-input-headers
+ soap-output-body
+ input
+ output
+ headers))
+ (t (error "Only standard SOAP RPC and Document style currently supported as binding")))
(error "Only standard SOAP HTTP transport currently supported as binding"))))
;; wsdl: either an instance of wsdl-document-definitions, a string url, a stream to parse, a pathname
Index: cl-soap/src/xsd.lisp
diff -u cl-soap/src/xsd.lisp:1.3 cl-soap/src/xsd.lisp:1.4
--- cl-soap/src/xsd.lisp:1.3 Mon Sep 19 18:27:04 2005
+++ cl-soap/src/xsd.lisp Wed Sep 21 19:08:03 2005
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: xsd.lisp,v 1.3 2005/09/19 16:27:04 scaekenberghe Exp $
+;;;; $Id: xsd.lisp,v 1.4 2005/09/21 17:08:03 scaekenberghe Exp $
;;;;
;;;; A partial implementation of the XML Schema Definition standard
;;;;
@@ -19,7 +19,10 @@
((target-namespace :accessor get-target-namespace :initarg :target-namespace :initform nil)
(elements :accessor get-elements :initarg :elements :initform nil)))
-(defclass xml-schema-element ()
+(defclass children-mixin ()
+ ((children :accessor get-children :initarg :children :initform nil)))
+
+(defclass xml-schema-element (children-mixin)
((name :accessor get-name :initarg :name :initform nil)
(type :accessor get-type :initarg :type :initform nil)
(min-occurs :accessor get-min-occurs :initarg :min-occurs :initform 0)
@@ -29,27 +32,38 @@
(print-unreadable-object (object out :type t :identity t)
(prin1 (or (get-name object) "anonymous") out)))
-(defclass xsd-schema-type ()
+(defclass xsd-type (children-mixin)
((name :accessor get-name :initarg :name :initform nil)))
-(defclass xsd-simple-type (xsd-schema-type)
+(defmethod print-object ((object xsd-type) out)
+ (print-unreadable-object (object out :type t :identity t)
+ (prin1 (or (get-name object) "anonymous") out)))
+
+(defclass xsd-simple-type (xsd-type)
())
-(defclass xsd-complex-type (xsd-schema-type)
- (children))
+(defclass xsd-complex-type (xsd-type)
+ ())
-(defclass xsd-compositor ()
+(defclass xsd-compositor (children-mixin)
())
-(defclass xsd-sequence (xml-compositor)
+(defclass xsd-sequence (xsd-compositor)
())
-(defclass xsd-choice (xml-compositor)
+(defclass xsd-choice (xsd-compositor)
())
-(defclass xsd-all (xml-compositor)
+(defclass xsd-all (xsd-compositor)
())
+(defclass xsd-restriction ()
+ ((base :accessor get-base :initarg :base :initform nil)))
+
+(defmethod print-object ((object xsd-restriction) out)
+ (print-unreadable-object (object out :type t :identity t)
+ (prin1 (or (get-base object) "unknown") out)))
+
;;; Parsing
(defun lxml->schema-element (lxml)
@@ -57,18 +71,50 @@
(xsd:|element|
(let* ((attributes (lxml-get-attributes lxml))
(name (getf attributes :|name|))
- (xml-schema-element (make-instance 'xml-schema-element :name name)))
+ (type (getf attributes :|type|))
+ (min-occurs (getf attributes :|minOccurs|))
+ (max-occurs (getf attributes :|maxOccurs|))
+ (xml-schema-element (make-instance 'xml-schema-element
+ :name name
+ :type type
+ :min-occurs (if min-occurs (parse-integer min-occurs) 0)
+ :max-occurs (if max-occurs
+ (if (equal max-occurs "unbounded")
+ :unbounded
+ (parse-integer max-occurs))
+ :unbounded))))
+ (loop :for child :in (lxml-get-children lxml) :do
+ (push (lxml->schema-element child)
+ (get-children xml-schema-element)))
xml-schema-element))
(xsd:|simpleType|
(let* ((attributes (lxml-get-attributes lxml))
(name (getf attributes :|name|))
- (xml-schema-element (make-instance 'xsd-simple-type :name name)))
- xml-schema-element))
+ (xsd-type (make-instance 'xsd-simple-type :name name)))
+ (loop :for child :in (lxml-get-children lxml) :do
+ (push (lxml->schema-element child)
+ (get-children xsd-type)))
+ xsd-type))
(xsd:|complexType|
(let* ((attributes (lxml-get-attributes lxml))
(name (getf attributes :|name|))
- (xml-schema-element (make-instance 'xsd-complex-type :name name)))
- xml-schema-element))))
+ (xsd-type (make-instance 'xsd-complex-type :name name)))
+ (loop :for child :in (lxml-get-children lxml) :do
+ (push (lxml->schema-element child)
+ (get-children xsd-type)))
+ xsd-type))
+ (xsd:|restriction|
+ (let* ((attributes (lxml-get-attributes lxml))
+ (base (getf attributes :|base|))
+ (xsd-restriction (make-instance 'xsd-restriction :base base)))
+ xsd-restriction))
+ (xsd:|sequence|
+ (let ((xsd-sequence (make-instance 'xsd-sequence)))
+ (loop :for child :in (lxml-get-children lxml) :do
+ (push (lxml->schema-element child)
+ (get-children xsd-sequence)))
+ (setf (get-children xsd-sequence) (nreverse (get-children xsd-sequence)))
+ xsd-sequence))))
(defun lxml->schema-definition (lxml)
(if (eql (lxml-get-tag lxml) 'xsd:|schema|)
@@ -97,6 +143,43 @@
;;; Interpreting the XSD model
+(defmethod get-type-in-context ((xsd-simple-type xsd-simple-type) elements)
+ "For now: return the base type of the restriction child of the simple-type, if any"
+ (declare (ignore elements))
+ (let ((first-child (first (get-children xsd-simple-type))))
+ (when (and first-child
+ (typep first-child 'xsd-restriction))
+ (get-base first-child))))
+
+(defmethod get-type-in-context ((xsd-complex-type xsd-complex-type) elements)
+ (declare (ignore elements))
+ xsd-complex-type)
+
+(defmethod get-type-in-context ((xml-schema-element xml-schema-element) elements)
+ "Resolve the type of element to the most primitive one, in the context of elements"
+ (let ((type (get-type xml-schema-element)))
+ (cond (type
+ (if (xsd-primitive-type-name-p type)
+ type
+ (get-type-in-context (find-item-named type elements) elements)))
+ (t
+ (let ((first-child (first (get-children xml-schema-element))))
+ (when first-child
+ (get-type-in-context first-child elements)))))))
+
+(defmethod get-element-type ((xml-schema-definition xml-schema-definition) element-name)
+ "Resolve the type of element to the most primitive one, in the context of elements"
+ (let ((element (find-item-named element-name (get-elements xml-schema-definition))))
+ (when element
+ (get-type-in-context element (get-elements xml-schema-definition)))))
+
+(defmethod get-members ((xsd-complex-type xsd-complex-type))
+ "Return the list of members of xsd-complex-type, provided it is a sequence"
+ (let ((first-child (first (get-children xsd-complex-type))))
+ (when (and first-child
+ (typep first-child 'xsd-sequence))
+ (get-children first-child))))
+
;;; Primitive Types/Values (types are keywords)
(defconstant +known-primitive-type-names+
@@ -122,6 +205,21 @@
(defvar *xsd-timezone* nil)
+(defun ut (&optional year month date (hours 0) (minutes 0) (seconds 0))
+ "Convenience function to create Common Lisp universal times"
+ (when (or (null year) (null month) (null date))
+ (multiple-value-bind (second minute hour current-date current-month current-year)
+ (if *xsd-timezone*
+ (decode-universal-time (get-universal-time) *xsd-timezone*)
+ (decode-universal-time (get-universal-time)))
+ (declare (ignore second minute hour))
+ (unless year (setf year current-year))
+ (unless month (setf month current-month))
+ (unless date (setf date current-date))))
+ (if *xsd-timezone*
+ (encode-universal-time seconds minutes hours date month year *xsd-timezone*)
+ (encode-universal-time seconds minutes hours date month year)))
+
(defun lisp->xsd-datetime (universal-time)
"1999-05-31T13:20:00.000-05:00"
(multiple-value-bind (second minute hour date month year day daylight-p timezone)
@@ -236,7 +334,7 @@
:positiveInteger :negativeInteger :nonPositiveInteger :nonNegativeInteger
:long :unsignedLong :int :unsignedInt :short :unsignedShort
:byte :decimal)
- (parse-integer value) 'integer)
+ (parse-integer value))
(:float
(coerce (read-from-string value) 'float))
(:double
More information about the Cl-soap-cvs
mailing list