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