[cl-soap-cvs] CVS update: cl-soap/src/namespaces.lisp cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp
Sven Van Caekenberghe
scaekenberghe at common-lisp.net
Fri Sep 23 08:06:46 UTC 2005
Update of /project/cl-soap/cvsroot/cl-soap/src
In directory common-lisp.net:/tmp/cvs-serv2275/src
Modified Files:
namespaces.lisp wsdl.lisp xsd.lisp
Log Message:
some code refactoring/cleanup
Date: Fri Sep 23 10:06:42 2005
Author: scaekenberghe
Index: cl-soap/src/namespaces.lisp
diff -u cl-soap/src/namespaces.lisp:1.6 cl-soap/src/namespaces.lisp:1.7
--- cl-soap/src/namespaces.lisp:1.6 Thu Sep 15 15:37:34 2005
+++ cl-soap/src/namespaces.lisp Fri Sep 23 10:06:36 2005
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: namespaces.lisp,v 1.6 2005/09/15 13:37:34 scaekenberghe Exp $
+;;;; $Id: namespaces.lisp,v 1.7 2005/09/23 08:06:36 scaekenberghe Exp $
;;;;
;;;; Definition of some standard XML namespaces commonly needed for SOAP
;;;;
@@ -43,7 +43,8 @@
(defconstant +xsi-ns-uri+ "http://www.w3.org/1999/XMLSchema-instance")
-;; http://www.w3.org/2000/10/XMLSchema-instance
+;; "http://www.w3.org/2000/10/XMLSchema-instance"
+;; "http://www.w3.org/2001/XMLSchema"
(defpackage :xsi
(:nicknames "xsi")
Index: cl-soap/src/wsdl.lisp
diff -u cl-soap/src/wsdl.lisp:1.12 cl-soap/src/wsdl.lisp:1.13
--- cl-soap/src/wsdl.lisp:1.12 Thu Sep 22 22:37:15 2005
+++ cl-soap/src/wsdl.lisp Fri Sep 23 10:06:36 2005
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: wsdl.lisp,v 1.12 2005/09/22 20:37:15 scaekenberghe Exp $
+;;;; $Id: wsdl.lisp,v 1.13 2005/09/23 08:06:36 scaekenberghe Exp $
;;;;
;;;; The basic WSDL protocol: we parse the generic and soap specific parts
;;;;
@@ -344,6 +344,11 @@
(defmethod get-element-named ((wsdl-document-definitions wsdl-document-definitions) element-name)
(get-element-named (first (get-types wsdl-document-definitions)) element-name))
+(defmethod get-xml-schema-definition ((wsdl-document-definitions wsdl-document-definitions))
+ (let ((xsd (first (get-types wsdl-document-definitions))))
+ (when (typep xsd 'xml-schema-definition)
+ xsd)))
+
;; Describing WSDL
(defun describe-wsdl-soap-part (part xml-schema-definition &key (stream *standard-output*) style)
@@ -382,10 +387,12 @@
(get-message output-element))))
(format stream " Input: ~a~%" (get-name input-message))
(loop :for part :in (get-parts input-message) :do
- (describe-wsdl-soap-part part xml-schema-definition :stream stream :style style))
+ (describe-wsdl-soap-part part xml-schema-definition
+ :stream stream :style style))
(format stream " Output: ~a~%" (get-name output-message))
(loop :for part :in (get-parts output-message) :do
- (describe-wsdl-soap-part part xml-schema-definition :stream stream :style style)))))))
+ (describe-wsdl-soap-part part xml-schema-definition
+ :stream stream :style style)))))))
(values))
;; Using WSDL to make structured SOAP calls
@@ -397,15 +404,14 @@
(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)))))
+ (element-type (get-type-in-context element (get-xml-schema-definition 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))
+ (cond ((xsd-primitive-type-name-p 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))
+ (if (is-optional-p element)
nil
(error "Cannot find binding for ~a" (get-name element))))))
((typep element-type 'xsd-complex-type)
@@ -433,7 +439,7 @@
xsi::|type| ,part-type)
,(lisp->xsd-primitive value (intern-xsd-type-name part-type)))
actual-input-parameters)
- (unless (zerop (get-min-occurs part-element))
+ (unless (is-optional-p 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)
@@ -447,7 +453,7 @@
(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))
+ (type (get-element-type (get-xml-schema-definition wsdl-document-definitions)
(get-name element))))
(if value
(push `(,(intern (get-name part) :keyword)
@@ -462,14 +468,13 @@
(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)))))
+ (element-type (get-type-in-context element (get-xml-schema-definition 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))
+ (cond ((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)
(values (xsd-primitive->lisp (second lxml) (intern-xsd-type-name element-type)) t)
- (if (zerop (get-min-occurs element))
+ (if (is-optional-p element)
(values nil nil)
(error "Expected a <~a> element" tag-name)))))
((typep element-type 'xsd-complex-type)
Index: cl-soap/src/xsd.lisp
diff -u cl-soap/src/xsd.lisp:1.6 cl-soap/src/xsd.lisp:1.7
--- cl-soap/src/xsd.lisp:1.6 Thu Sep 22 22:37:15 2005
+++ cl-soap/src/xsd.lisp Fri Sep 23 10:06:38 2005
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: xsd.lisp,v 1.6 2005/09/22 20:37:15 scaekenberghe Exp $
+;;;; $Id: xsd.lisp,v 1.7 2005/09/23 08:06:38 scaekenberghe Exp $
;;;;
;;;; A partial implementation of the XML Schema Definition standard
;;;;
@@ -155,6 +155,7 @@
(get-base first-child))))
(defmethod get-type-in-context ((xsd-complex-type xsd-complex-type) elements)
+ "A complex type cannot be reduced further"
(declare (ignore elements))
xsd-complex-type)
@@ -170,19 +171,36 @@
(when first-child
(get-type-in-context first-child elements)))))))
-(defmethod get-element-type ((xml-schema-definition xml-schema-definition) element-name)
+(defmethod get-element-type ((xml-schema-definition xml-schema-definition) element)
"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))))
+ (let ((element (if (stringp element)
+ (find-item-named element (get-elements xml-schema-definition))
+ element)))
(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"
+ "Return the list of members of xsd-complex-type, provided it is a sequence (for now)"
(let ((first-child (first (get-children xsd-complex-type))))
(when (and first-child
(typep first-child 'xsd-sequence))
(get-children first-child))))
+(defmethod get-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 :complex))))
+
+(defmethod is-optional-p ((xml-schema-element xml-schema-element))
+ (zerop (get-min-occurs xml-schema-element)))
+
+(defmethod is-plural-p ((xml-schema-element xml-schema-element))
+ (eql (get-max-occurs xml-schema-element) :unbounded))
+
;;; Describing XSD (with pre-rendering of XML)
(defun indent (n &optional (stream *standard-output*))
@@ -208,9 +226,9 @@
(defun pre-render-xsd-type (xml-schema-definition type-name &key (level 0) (stream *standard-output*))
(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)))
+ (type (get-element-type xml-schema-definition type-element)))
+ (if (typep type 'xsd-complex-type)
+ (let ((members (get-members type)))
(loop :for member :in members :do
(let ((member-name (get-name member))
(member-type (get-type member)))
@@ -220,7 +238,8 @@
member-name member-type member-name (multiplicity-suffix member))
(progn
(format stream " <~a>~%" member-name)
- (pre-render-xsd-type xml-schema-definition member-type :level (1+ level) :stream stream)
+ (pre-render-xsd-type xml-schema-definition member-type
+ :level (1+ level) :stream stream)
(indent level stream)
(format stream " </~a>~a~%" member-name (multiplicity-suffix member)))))))
(if (xsd-primitive-type-name-p type)
@@ -231,9 +250,9 @@
(defun describe-xsd-type (xml-schema-definition type-name &key (level 0) (stream *standard-output*))
(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)))
+ (type (get-element-type xml-schema-definition type-element)))
+ (if (typep type 'xsd-complex-type)
+ (let ((members (get-members type)))
(loop :for member :in members :do
(let ((member-name (get-name member))
(member-type (get-type member)))
@@ -243,7 +262,8 @@
member-name member-type (describe-multiplicity member))
(progn
(format stream " Member ~s [~a]~%" member-name (describe-multiplicity member))
- (describe-xsd-type xml-schema-definition member-type :level (1+ level) :stream stream))))))
+ (describe-xsd-type xml-schema-definition member-type
+ :level (1+ level) :stream stream))))))
(if (xsd-primitive-type-name-p type)
(progn
(indent level stream)
@@ -253,15 +273,16 @@
(defun describe-xsd-element (xml-schema-definition element &key (level 0) (stream *standard-output*))
(unless (typep element 'xml-schema-element)
(setf element (get-element-named xml-schema-definition element)))
- (let* ((element-name (get-name element))
- (element-type (get-element-type xml-schema-definition element-name)))
+ (let* ((element-type (get-element-type xml-schema-definition element))
+ (element-name (get-name element)))
(if (xsd-primitive-type-name-p element-type)
(progn
(indent level stream)
(format stream "Element ~s of primitive type ~s [~a]~%"
element-name element-type (describe-multiplicity element))
(indent level stream)
- (format stream " <~a>~a</~a>~a~%" element-name element-type element-name (multiplicity-suffix element)))
+ (format stream " <~a>~a</~a>~a~%"
+ element-name element-type element-name (multiplicity-suffix element)))
(let ((members (get-members element-type)))
(indent level stream)
(format stream "Element ~s [~a]~%" element-name (describe-multiplicity element))
@@ -274,7 +295,8 @@
member-name member-type (describe-multiplicity member))
(progn
(format stream " Member ~s [~a]~%" member-name (describe-multiplicity member))
- (describe-xsd-type xml-schema-definition member-type :level (1+ level) :stream stream)))))
+ (describe-xsd-type xml-schema-definition member-type
+ :level (1+ level) :stream stream)))))
(indent level stream)
(format stream " <~a>~%" element-name)
(loop :for member :in members :do
@@ -298,7 +320,8 @@
(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 :level 1 :stream stream)))
+ (describe-xsd-element xml-schema-definition element
+ :level 1 :stream stream)))
(values))
;;; Primitive Types/Values (types are keywords)
More information about the Cl-soap-cvs
mailing list