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)