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)