[cl-soap-cvs] CVS update: cl-soap/src/lxml.lisp cl-soap/src/xsd.lisp
Sven Van Caekenberghe
scaekenberghe at common-lisp.net
Sun Sep 25 12:44:19 UTC 2005
Update of /project/cl-soap/cvsroot/cl-soap/src
In directory common-lisp.net:/tmp/cvs-serv26172/src
Modified Files:
lxml.lisp xsd.lisp
Log Message:
added 'plural' member handling to new-resolve-type
added nillable element attribute to use as optional indication in sequences
Date: Sun Sep 25 14:44:18 2005
Author: scaekenberghe
Index: cl-soap/src/lxml.lisp
diff -u cl-soap/src/lxml.lisp:1.6 cl-soap/src/lxml.lisp:1.7
--- cl-soap/src/lxml.lisp:1.6 Wed Sep 21 19:08:03 2005
+++ cl-soap/src/lxml.lisp Sun Sep 25 14:44:18 2005
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: lxml.lisp,v 1.6 2005/09/21 17:08:03 scaekenberghe Exp $
+;;;; $Id: lxml.lisp,v 1.7 2005/09/25 12:44:18 scaekenberghe Exp $
;;;;
;;;; Some tools to manipulate lxml
;;;;
@@ -38,6 +38,10 @@
(defun lxml-find-tag (tag lxml)
"Find a specific tag in a lxml XML DOM list"
(find tag lxml :key #'lxml-get-tag))
+
+(defun lxml-find-tags (tag lxml)
+ "Find all elements of a specific tag in a lxml XML DOM list"
+ (remove-if-not #'(lambda (x) (eql (lxml-get-tag x) tag)) lxml))
;;; internal
Index: cl-soap/src/xsd.lisp
diff -u cl-soap/src/xsd.lisp:1.10 cl-soap/src/xsd.lisp:1.11
--- cl-soap/src/xsd.lisp:1.10 Fri Sep 23 23:33:05 2005
+++ cl-soap/src/xsd.lisp Sun Sep 25 14:44:18 2005
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: xsd.lisp,v 1.10 2005/09/23 21:33:05 scaekenberghe Exp $
+;;;; $Id: xsd.lisp,v 1.11 2005/09/25 12:44:18 scaekenberghe Exp $
;;;;
;;;; A partial implementation of the XML Schema Definition standard
;;;;
@@ -26,7 +26,8 @@
((name :accessor get-name :initarg :name :initform nil)
(type :accessor get-type :initarg :type :initform nil)
(min-occurs :accessor get-min-occurs :initarg :min-occurs :initform 1)
- (max-occurs :accessor get-max-occurs :initarg :max-occurs :initform 1)))
+ (max-occurs :accessor get-max-occurs :initarg :max-occurs :initform 1)
+ (nillable :accessor get-nillable :initarg :nillable :initform nil)))
(defmethod print-object ((object xml-schema-element) out)
(print-unreadable-object (object out :type t :identity t)
@@ -74,6 +75,7 @@
(type (getf attributes :|type|))
(min-occurs (getf attributes :|minOccurs|))
(max-occurs (getf attributes :|maxOccurs|))
+ (nillable (getf attributes :|nillable|))
(xml-schema-element (make-instance 'xml-schema-element
:name name
:type type
@@ -82,7 +84,8 @@
(if (equal max-occurs "unbounded")
:unbounded
(parse-integer max-occurs))
- 1))))
+ 1)
+ :nillable (equal nillable "true"))))
(loop :for child :in (lxml-get-children lxml) :do
(push (lxml->schema-element child)
(get-children xml-schema-element)))
@@ -374,20 +377,40 @@
(loop :for member :in members :do
(let* ((member-name (get-name member))
(member-type (get-type member))
- (sub-tag-name (intern member-name (s-xml:get-package namespace)))
- (member-lxml (lxml-find-tag sub-tag-name lxml)))
- (if (xsd-primitive-type-name-p member-type)
- (multiple-value-bind (member-value required)
- (new-resolve-primitive member member-type member-lxml namespace)
- (when required
- (push member-name resolved-members)
- (push member-value resolved-members)))
- (multiple-value-bind (member-value required)
- (new-resolve-type member-type member-lxml member
- xml-schema-definition namespace)
- (when required
- (push member-name resolved-members)
- (push member-value resolved-members))))))
+ (sub-tag-name (intern member-name (s-xml:get-package namespace))))
+ (if (is-plural-p member)
+ (let ((count 0))
+ (loop :for item-lxml :in (lxml-find-tags sub-tag-name (lxml-get-children lxml)) :do
+ (if (xsd-primitive-type-name-p member-type)
+ (multiple-value-bind (member-value required)
+ (new-resolve-primitive member member-type item-lxml namespace)
+ (when required
+ (incf count)
+ (push member-name resolved-members)
+ (push member-value resolved-members)))
+ (multiple-value-bind (member-value required)
+ (new-resolve-type member-type item-lxml member
+ xml-schema-definition namespace)
+ (when required
+ (incf count)
+ (push member-name resolved-members)
+ (push member-value resolved-members)))))
+ (if (zerop count)
+ (unless (or (is-optional-p member) (get-nillable member))
+ (error "Required element <~a> not found" member-name))))
+ (let ((member-lxml (lxml-find-tag sub-tag-name lxml)))
+ (if (xsd-primitive-type-name-p member-type)
+ (multiple-value-bind (member-value required)
+ (new-resolve-primitive member member-type member-lxml namespace)
+ (when required
+ (push member-name resolved-members)
+ (push member-value resolved-members)))
+ (multiple-value-bind (member-value required)
+ (new-resolve-type member-type member-lxml member
+ xml-schema-definition namespace)
+ (when required
+ (push member-name resolved-members)
+ (push member-value resolved-members))))))))
(values (nreverse resolved-members) t))
(if (xsd-primitive-type-name-p type)
(let ((value (new-lxml-primitive-value (get-name super-element) type lxml namespace)))
@@ -407,32 +430,31 @@
(resolved-members '()))
(loop :for member :in members :do
(let* ((member-name (get-name member))
- (member-type (get-type member)))
+ (member-type (get-type member))
+ (sub-tag-name (intern member-name (s-xml:get-package namespace))))
(if (is-plural-p member)
(let ((count 0))
(loop :for item-lxml :in sub-lxml :do
- (let ((sub-tag-name (intern member-name (s-xml:get-package namespace))))
- (if (eql (lxml-get-tag item-lxml) sub-tag-name)
- (if (xsd-primitive-type-name-p member-type)
- (multiple-value-bind (member-value required)
- (new-resolve-primitive member member-type item-lxml namespace)
- (when required
- (incf count)
- (push member-name resolved-members)
- (push member-value resolved-members)))
+ (if (eql (lxml-get-tag item-lxml) sub-tag-name)
+ (if (xsd-primitive-type-name-p member-type)
(multiple-value-bind (member-value required)
- (new-resolve-type member-type item-lxml member
- xml-schema-definition namespace)
+ (new-resolve-primitive member member-type item-lxml namespace)
(when required
(incf count)
(push member-name resolved-members)
- (push member-value resolved-members))))
- (error "Expected a <~a> element" sub-tag-name))))
+ (push member-value resolved-members)))
+ (multiple-value-bind (member-value required)
+ (new-resolve-type member-type item-lxml member
+ xml-schema-definition namespace)
+ (when required
+ (incf count)
+ (push member-name resolved-members)
+ (push member-value resolved-members))))
+ (error "Expected a <~a> element" sub-tag-name)))
(if (zerop count)
- (unless (is-optional-p member)
+ (unless (or (is-optional-p member) (get-nillable member))
(error "Required element <~a> not found" member-name))))
- (let* ((sub-tag-name (intern member-name (s-xml:get-package namespace)))
- (member-lxml (lxml-find-tag sub-tag-name sub-lxml)))
+ (let ((member-lxml (lxml-find-tag sub-tag-name sub-lxml)))
(if (xsd-primitive-type-name-p member-type)
(multiple-value-bind (member-value required)
(new-resolve-primitive member member-type member-lxml namespace)
@@ -508,10 +530,11 @@
(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]~%"
- member-name member-type (describe-multiplicity member))
+ (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]~%" member-name (describe-multiplicity member))
+ (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)
@@ -528,23 +551,25 @@
(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))
+ (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)))
(indent level stream)
- (format stream "Element ~s [~a]~%" element-name (describe-multiplicity element))
+ (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]~%"
- member-name member-type (describe-multiplicity member))
+ (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]~%" member-name (describe-multiplicity member))
+ (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)
More information about the Cl-soap-cvs
mailing list