Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv30878/src

Modified Files: wsdl.lisp xsd.lisp Log Message: describe-xsd has been rewritten using the new template system

Date: Sat Oct 1 10:48:49 2005 Author: scaekenberghe

Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.19 cl-soap/src/wsdl.lisp:1.20 --- cl-soap/src/wsdl.lisp:1.19 Fri Sep 30 19:12:17 2005 +++ cl-soap/src/wsdl.lisp Sat Oct 1 10:48:49 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.19 2005/09/30 17:12:17 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.20 2005/10/01 08:48:49 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -376,8 +376,7 @@ (cond ((get-type part) (format stream " of type: ~a~%" (get-type part))) ((get-element part) - (describe-xsd-element xml-schema-definition (get-element part) - :level 5 :stream stream)))) + (describe-xsd-element (get-element part) xml-schema-definition stream 5))))

(defun describe-wsdl-soap (wsdl-document-definitions &key (stream *standard-output*)) "Print a high-level description of the services/ports/operations in wsdl-document-definitions"

Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.21 cl-soap/src/xsd.lisp:1.22 --- cl-soap/src/xsd.lisp:1.21 Fri Sep 30 21:58:05 2005 +++ cl-soap/src/xsd.lisp Sat Oct 1 10:48:49 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.21 2005/09/30 19:58:05 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.22 2005/10/01 08:48:49 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -226,132 +226,6 @@ (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*)) - (loop :repeat n :do (write-char #\space stream) (write-char #\space stream))) - -(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 &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-element))) - (if (typep type 'xsd-complex-type) - (let ((members (get-members type xml-schema-definition))) - (loop :for member :in members :do - (let ((member-name (get-name member)) - (member-type (get-type member))) - (indent level stream) - (if (xsd-primitive-type-name-p member-type) - (format stream " <~a>~a</~a>~a~%" - 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) - (indent level stream) - (format stream " </~a>~a~%" member-name (multiplicity-suffix member))))))) - (if (xsd-primitive-type-name-p type) - (progn - (indent level stream) - (format stream " ~a~%" type)) - (error "unexpected type"))))) - -(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-element))) - (if (typep type 'xsd-complex-type) - (let ((members (get-members type xml-schema-definition))) - (loop :for member :in members :do - (let ((member-name (get-name member)) - (member-type (get-type member))) - (indent level stream) - (if (xsd-primitive-type-name-p member-type) - (format stream " Member ~s of primitive type ~s [~a]~@[ nillable~]~%" - member-name member-type (describe-multiplicity member) (get-nillable member)) - (progn - (format stream " Member ~s [~a]~@[ nillable~]~%" member-name - (describe-multiplicity member) (get-nillable member)) - (describe-xsd-type xml-schema-definition member-type - :level (1+ level) :stream stream)))))) - (if (xsd-primitive-type-name-p type) - (progn - (indent level stream) - (format stream " primitive type ~a~%" type)) - (error "unexpected type"))))) - -(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-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]~@[ nillable~]~%" - element-name element-type (describe-multiplicity element) (get-nillable element)) - (indent level stream) - (format stream " <~a>~a</~a>~a~%" - element-name element-type element-name (multiplicity-suffix element))) - (let ((members (get-members element-type xml-schema-definition))) - (indent level stream) - (format stream "Element ~s [~a]~@[ nillable~]~%" element-name - (describe-multiplicity element) (get-nillable element)) - (loop :for member :in members :do - (let ((member-name (get-name member)) - (member-type (get-type member))) - (indent level stream) - (if (xsd-primitive-type-name-p member-type) - (format stream " Member ~s of primitive type ~s [~a]~@[ nillable~]~%" - member-name member-type (describe-multiplicity member) (get-nillable member)) - (progn - (format stream " Member ~s [~a]~@[ nillable~]~%" member-name - (describe-multiplicity member) (get-nillable member)) - (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 - (let ((member-name (get-name member)) - (member-type (get-type member))) - (indent level stream) - (if (xsd-primitive-type-name-p member-type) - (format stream " <~a>~a</~a>~a~%" - 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) - (indent level stream) - (format stream " </~a>~a~%" member-name (multiplicity-suffix member)))))) - (indent level stream) - (format stream " </~a>~a~%" element-name (multiplicity-suffix element)))))) - -(defun describe-xsd (xml-schema-definition &key (stream *standard-output*)) - "Print a high-level description of the top-level elements in xml-schema-definition" - (format stream "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 - :level 1 :stream stream))) - (values)) - ;;; Template Generation (converting the XSD model to something simpler ;-)

;; an XSD element template looks like this: @@ -496,6 +370,61 @@ (defun resolve-element (element lxml xml-schema-definition namespace) (let ((template (generate-xsd-template element xml-schema-definition))) (resolve-xsd-template template (list lxml) namespace))) + +;;; Describing XSD (print the 'sexpr' format with multiplicity indicators using in input/output binding) + +(defun indent (n &optional (stream *standard-output*)) + (format stream "~&") + (loop :repeat n + :do (write-char #\space stream) (write-char #\space stream))) + +(defun describe-xsd-template-members (members &optional (stream *standard-output*) (level 0)) + (loop :for member :in members :do + (describe-xsd-template member stream (1+ level)))) + +(defun describe-xsd-template (template &optional (stream *standard-output*) (level 0)) + (destructuring-bind (multiplicity element-name &rest contents) + template + (cond ((null contents) + (indent level) + (format stream "(~s)" element-name)) + ((symbolp (first contents)) + (let ((primitive-type (first contents))) + (case multiplicity + ((1 ?) + (indent level) + (format stream "(~s ~s) ~a " element-name primitive-type multiplicity)) + ((+ *) + (indent level) + (format stream "(~s (~s) ~a )" element-name primitive-type multiplicity))))) + (t + (case multiplicity + ((1 ?) + (indent level) + (format stream "(~a" element-name) + (describe-xsd-template-members contents stream level) + (format stream ") ~a " multiplicity)) + ((+ *) + (indent level) + (format stream "(~a (" element-name) + (describe-xsd-template-members contents stream level) + (format stream ") ~a )" multiplicity))))))) + +(defun describe-xsd-element (element xml-schema-definition &optional (stream *standard-output*) (level 0)) + (let ((template (generate-xsd-template element xml-schema-definition))) + (describe-xsd-template template stream level)) + (format stream "~&") + (values)) + +(defun describe-xsd (xml-schema-definition &optional (stream *standard-output*)) + "Print a high-level description of the top-level elements in xml-schema-definition" + (format stream "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 element xml-schema-definition stream 1))) + (format stream "~&") + (values))

;;; Primitive Types/Values (types are identified :keywords)