Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv30878/test
Modified Files: development.lisp Log Message: describe-xsd has been rewritten using the new template system
Date: Sat Oct 1 10:48:50 2005 Author: scaekenberghe
Index: cl-soap/test/development.lisp diff -u cl-soap/test/development.lisp:1.1 cl-soap/test/development.lisp:1.2 --- cl-soap/test/development.lisp:1.1 Fri Sep 30 21:59:26 2005 +++ cl-soap/test/development.lisp Sat Oct 1 10:48:50 2005 @@ -1,6 +1,6 @@ ;;;; -*- Mode: LISP -*- ;;;; -;;;; $Id: development.lisp,v 1.1 2005/09/30 19:59:26 scaekenberghe Exp $ +;;;; $Id: development.lisp,v 1.2 2005/10/01 08:48:50 scaekenberghe Exp $ ;;;; ;;;; Development scratch pad ;;;; @@ -324,5 +324,128 @@ (values nil nil) (error "Expected a <~a> element" tag-name))))) (t (error "Cannot resolve element ~s of type ~s" element element-type))))) + +;;; Describing XSD (with pre-rendering of XML) + +(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))
;;;; eof