[cl-soap-cvs] CVS update: cl-soap/test/development.lisp
Sven Van Caekenberghe
scaekenberghe at common-lisp.net
Sat Oct 1 08:48:51 UTC 2005
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
More information about the Cl-soap-cvs
mailing list