[cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp
Sven Van Caekenberghe
scaekenberghe at common-lisp.net
Thu Sep 22 15:30:02 UTC 2005
Update of /project/cl-soap/cvsroot/cl-soap/src
In directory common-lisp.net:/tmp/cvs-serv26088/src
Modified Files:
wsdl.lisp xsd.lisp
Log Message:
more work on xsd type handling in wsdl-soap-call
more specifically type element multiplicity
added some simple experimental wsdl caching
Date: Thu Sep 22 17:30:00 2005
Author: scaekenberghe
Index: cl-soap/src/wsdl.lisp
diff -u cl-soap/src/wsdl.lisp:1.10 cl-soap/src/wsdl.lisp:1.11
--- cl-soap/src/wsdl.lisp:1.10 Wed Sep 21 19:08:03 2005
+++ cl-soap/src/wsdl.lisp Thu Sep 22 17:29:59 2005
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: wsdl.lisp,v 1.10 2005/09/21 17:08:03 scaekenberghe Exp $
+;;;; $Id: wsdl.lisp,v 1.11 2005/09/22 15:29:59 scaekenberghe Exp $
;;;;
;;;; The basic WSDL protocol: we parse the generic and soap specific parts
;;;;
@@ -342,7 +342,7 @@
(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)))))
+ (get-element-named (first (get-types wsdl-document-definitions)) element-name))
;; Describing WSDL
@@ -391,15 +391,22 @@
(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))))
+ (let ((value (get-name-binding (get-name element) bindings)))
+ (if value
+ `(,(intern (get-name element) (s-xml:get-package namespace))
+ ,(lisp->xsd-primitive value (intern-xsd-type-name element-type)))
+ (if (zerop (get-min-occurs element))
+ nil
+ (error "Cannot find binding for ~a" (get-name element))))))
((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))
+ (let* ((sub-bindings (or (get-name-binding (get-name element-type) bindings)
+ bindings))
+ (member-binding (bind-element member sub-bindings wsdl-document-definitions)))
+ (if member-binding
+ (push member-binding 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)))))
@@ -416,7 +423,8 @@
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)))))
+ (unless (zerop (get-min-occurs part-element))
+ (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))
@@ -450,17 +458,27 @@
(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))))
+ (values (xsd-primitive->lisp (second lxml) (intern-xsd-type-name element-type)) t)
+ (if (zerop (get-min-occurs element))
+ (values nil nil)
+ (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))))
+ (let ((resolved-members '()))
+ (loop :for member :in members :do
+ (let* ((sub-tag-name (intern (get-name member) (s-xml:get-package namespace)))
+ (sub-lxml (lxml-find-tag sub-tag-name (rest lxml))))
+ (multiple-value-bind (value required)
+ (resolve-element member sub-lxml wsdl-document-definitions)
+ (when required
+ (push (get-name element) resolved-members)
+ (push value resolved-members)))))
+ (values (nreverse resolved-members) t))
+ (if (zerop (get-min-occurs element))
+ (values nil nil)
+ (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 wsdl-document-definitions)
@@ -517,7 +535,7 @@
:|xmlns|
,input-namespace-uri))
;; we assume there is only one result
- (values (first (bind-output-parts result output-message output wsdl-document-definitions))
+ (values (bind-output-parts result output-message output wsdl-document-definitions)
headers))))
(defun wsdl-soap-rpc-call (wsdl-document-definitions
Index: cl-soap/src/xsd.lisp
diff -u cl-soap/src/xsd.lisp:1.4 cl-soap/src/xsd.lisp:1.5
--- cl-soap/src/xsd.lisp:1.4 Wed Sep 21 19:08:03 2005
+++ cl-soap/src/xsd.lisp Thu Sep 22 17:30:00 2005
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: xsd.lisp,v 1.4 2005/09/21 17:08:03 scaekenberghe Exp $
+;;;; $Id: xsd.lisp,v 1.5 2005/09/22 15:30:00 scaekenberghe Exp $
;;;;
;;;; A partial implementation of the XML Schema Definition standard
;;;;
@@ -25,8 +25,8 @@
(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)
- (max-occurs :accessor get-max-occurs :initarg :max-occurs :initform :unbounded)))
+ (min-occurs :accessor get-min-occurs :initarg :min-occurs :initform 1)
+ (max-occurs :accessor get-max-occurs :initarg :max-occurs :initform 1)))
(defmethod print-object ((object xml-schema-element) out)
(print-unreadable-object (object out :type t :identity t)
@@ -143,6 +143,9 @@
;;; Interpreting the XSD model
+(defmethod get-element-named ((xml-schema-definition xml-schema-definition) element-name)
+ (find-item-named element-name (get-elements xml-schema-definition)))
+
(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))
@@ -180,6 +183,122 @@
(typep first-child 'xsd-sequence))
(get-children first-child))))
+;;; Describing XSD (with pre-rendering of XML)
+
+(defun indent (n)
+ (loop :repeat n :do (write-char #\space) (write-char #\space)))
+
+(defmethod describe-multiplicity ((xml-schema-element xml-schema-element))
+ (with-slots (min-occurs max-occurs)
+ xml-schema-element
+ (cond ((and (zerop min-occurs) (eql max-occurs 1)) "optional")
+ ((and (eql min-occurs 1) (eql max-occurs 1)) "required")
+ ((and (eql min-occurs 1) (eql max-occurs :unbounded)) "one or more")
+ ((and (zerop min-occurs) (eql max-occurs :unbounded)) "zero or more")
+ (t (format nil "min:~d-max:~d" min-occurs max-occurs)))))
+
+(defmethod multiplicity-suffix ((xml-schema-element xml-schema-element))
+ (with-slots (min-occurs max-occurs)
+ xml-schema-element
+ (cond ((and (zerop min-occurs) (eql max-occurs 1)) "?")
+ ((and (eql min-occurs 1) (eql max-occurs 1)) "")
+ ((and (eql min-occurs 1) (eql max-occurs :unbounded)) "+")
+ ((and (zerop min-occurs) (eql max-occurs :unbounded)) "*")
+ (t (format nil "~d:~d" min-occurs max-occurs)))))
+
+(defun pre-render-xsd-type (xml-schema-definition type-name level)
+ (let* ((type-element (get-element-named xml-schema-definition type-name))
+ (type (get-element-type xml-schema-definition type-name)))
+ (if (typep type-element 'xsd-complex-type)
+ (let ((members (get-members type-element)))
+ (loop :for member :in members :do
+ (let ((member-name (get-name member))
+ (member-type (get-type member)))
+ (indent level)
+ (if (xsd-primitive-type-name-p member-type)
+ (format t " <~a>~a</~a>~a~%"
+ member-name member-type member-name (multiplicity-suffix member))
+ (progn
+ (format t " <~a>~%" member-name)
+ (pre-render-xsd-type xml-schema-definition member-type (1+ level))
+ (indent level)
+ (format t " </~a>~a~%" member-name (multiplicity-suffix member)))))))
+ (if (xsd-primitive-type-name-p type)
+ (progn
+ (indent level)
+ (format t " ~a~%" type))
+ (error "unexpected type")))))
+
+(defun describe-xsd-type (xml-schema-definition type-name level)
+ (let* ((type-element (get-element-named xml-schema-definition type-name))
+ (type (get-element-type xml-schema-definition type-name)))
+ (if (typep type-element 'xsd-complex-type)
+ (let ((members (get-members type-element)))
+ (loop :for member :in members :do
+ (let ((member-name (get-name member))
+ (member-type (get-type member)))
+ (indent level)
+ (if (xsd-primitive-type-name-p member-type)
+ (format t " Member ~s of primitive type ~s [~a]~%"
+ member-name member-type (describe-multiplicity member))
+ (progn
+ (format t " Member ~s [~a]~%" member-name (describe-multiplicity member))
+ (describe-xsd-type xml-schema-definition member-type (1+ level)))))))
+ (if (xsd-primitive-type-name-p type)
+ (progn
+ (indent level)
+ (format t " primitive type ~a~%" type))
+ (error "unexpected type")))))
+
+(defun describe-xsd-element (xml-schema-definition element level)
+ (let* ((element-name (get-name element))
+ (element-type (get-element-type xml-schema-definition element-name)))
+ (if (xsd-primitive-type-name-p element-type)
+ (progn
+ (indent level)
+ (format t "Element ~s of primitive type ~s [~a]~%"
+ element-name element-type (describe-multiplicity element))
+ (indent level)
+ (format t " <~a>~a</~a>~a~%" element-name element-type element-name (multiplicity-suffix element)))
+ (let ((members (get-members element-type)))
+ (indent level)
+ (format t "Element ~s [~a]~%" element-name (describe-multiplicity element))
+ (loop :for member :in members :do
+ (let ((member-name (get-name member))
+ (member-type (get-type member)))
+ (indent level)
+ (if (xsd-primitive-type-name-p member-type)
+ (format t " Member ~s of primitive type ~s [~a]~%"
+ member-name member-type (describe-multiplicity member))
+ (progn
+ (format t " Member ~s [~a]~%" member-name (describe-multiplicity member))
+ (describe-xsd-type xml-schema-definition member-type (1+ level))))))
+ (indent level)
+ (format t " <~a>~%" element-name)
+ (loop :for member :in members :do
+ (let ((member-name (get-name member))
+ (member-type (get-type member)))
+ (indent level)
+ (if (xsd-primitive-type-name-p member-type)
+ (format t " <~a>~a</~a>~a~%"
+ member-name member-type member-name (multiplicity-suffix member))
+ (progn
+ (format t " <~a>~%" member-name)
+ (pre-render-xsd-type xml-schema-definition member-type (1+ level))
+ (indent level)
+ (format t " </~a>~a~%" member-name (multiplicity-suffix member))))))
+ (indent level)
+ (format t " </~a>~a~%" element-name (multiplicity-suffix element))))))
+
+(defun describe-xsd (xml-schema-definition)
+ "Print a high-level description of the top-level elements in xml-schema-definition"
+ (format t "XML Schema Definition with target-namespace URI ~s~%"
+ (get-target-namespace xml-schema-definition))
+ (loop :for element :in (get-elements xml-schema-definition) :do
+ (when (typep element 'xml-schema-element)
+ (describe-xsd-element xml-schema-definition element 1)))
+ (values))
+
;;; Primitive Types/Values (types are keywords)
(defconstant +known-primitive-type-names+
@@ -196,7 +315,8 @@
"base64Binary" "hexBinary"))
(defun xsd-primitive-type-name-p (name)
- (member (actual-name name) +known-primitive-type-names+ :test #'string-equal))
+ (and (stringp 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))
More information about the Cl-soap-cvs
mailing list