Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv24844/src

Modified Files: xsd.lisp Log Message: some refactoring Date: Tue Sep 27 20:22:54 2005 Author: scaekenberghe

Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.16 cl-soap/src/xsd.lisp:1.17 --- cl-soap/src/xsd.lisp:1.16 Tue Sep 27 18:25:17 2005 +++ cl-soap/src/xsd.lisp Tue Sep 27 20:22:53 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.16 2005/09/27 16:25:17 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.17 2005/09/27 18:22:53 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -73,71 +73,60 @@

;;; Parsing

+(defun handle-lxml-schema-elements (children-mixin lxml) + (loop :for child :in (lxml-get-children lxml) + :do (push (lxml->schema-element child) + (get-children children-mixin))) + (setf (get-children children-mixin) (nreverse (get-children children-mixin)))) + (defun lxml->schema-element (lxml) - (case (lxml-get-tag lxml) - (xsd:|element| - (let* ((attributes (lxml-get-attributes lxml)) - (name (getf attributes :|name|)) - (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 - :min-occurs (if min-occurs (parse-integer min-occurs) 1) - :max-occurs (if max-occurs - (if (equal max-occurs "unbounded") - :unbounded - (parse-integer max-occurs)) - 1) - :nillable (equal nillable "true")))) - (loop :for child :in (lxml-get-children lxml) :do - (push (lxml->schema-element child) - (get-children xml-schema-element))) - xml-schema-element)) - (xsd:|simpleType| - (let* ((attributes (lxml-get-attributes lxml)) - (name (getf attributes :|name|)) - (xsd-type (make-instance 'xsd-simple-type :name name))) - (loop :for child :in (lxml-get-children lxml) :do - (push (lxml->schema-element child) - (get-children xsd-type))) - xsd-type)) - (xsd:|complexType| - (let* ((attributes (lxml-get-attributes lxml)) - (name (getf attributes :|name|)) - (xsd-type (make-instance 'xsd-complex-type :name name))) - (loop :for child :in (lxml-get-children lxml) :do - (push (lxml->schema-element child) - (get-children xsd-type))) - xsd-type)) - (xsd:|complexContent| - (let* ((xsd-complex-content (make-instance 'xsd-complex-content))) - (loop :for child :in (lxml-get-children lxml) :do - (push (lxml->schema-element child) - (get-children xsd-complex-content))) - xsd-complex-content)) - (xsd:|restriction| - (let* ((attributes (lxml-get-attributes lxml)) - (base (getf attributes :|base|)) - (xsd-restriction (make-instance 'xsd-restriction :base base))) - xsd-restriction)) - (xsd:|extension| - (let* ((attributes (lxml-get-attributes lxml)) - (base (getf attributes :|base|)) - (xsd-extension (make-instance 'xsd-extension :base base))) - (loop :for child :in (lxml-get-children lxml) :do - (push (lxml->schema-element child) - (get-children xsd-extension))) - xsd-extension)) - (xsd:|sequence| - (let ((xsd-sequence (make-instance 'xsd-sequence))) - (loop :for child :in (lxml-get-children lxml) :do - (push (lxml->schema-element child) - (get-children xsd-sequence))) - (setf (get-children xsd-sequence) (nreverse (get-children xsd-sequence))) - xsd-sequence)))) + (let ((attributes (lxml-get-attributes lxml))) + (case (lxml-get-tag lxml) + (xsd:|element| + (let* ((name (getf attributes :|name|)) + (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 + :min-occurs (if min-occurs (parse-integer min-occurs) 1) + :max-occurs (if max-occurs + (if (equal max-occurs "unbounded") + :unbounded + (parse-integer max-occurs)) + 1) + :nillable (equal nillable "true")))) + (handle-lxml-schema-elements xml-schema-element lxml) + xml-schema-element)) + (xsd:|simpleType| + (let* ((name (getf attributes :|name|)) + (xsd-type (make-instance 'xsd-simple-type :name name))) + (handle-lxml-schema-elements xsd-type lxml) + xsd-type)) + (xsd:|complexType| + (let* ((name (getf attributes :|name|)) + (xsd-type (make-instance 'xsd-complex-type :name name))) + (handle-lxml-schema-elements xsd-type lxml) + xsd-type)) + (xsd:|complexContent| + (let ((xsd-complex-content (make-instance 'xsd-complex-content))) + (handle-lxml-schema-elements xsd-complex-content lxml) + xsd-complex-content)) + (xsd:|restriction| + (let* ((base (getf attributes :|base|)) + (xsd-restriction (make-instance 'xsd-restriction :base base))) + xsd-restriction)) + (xsd:|extension| + (let* ((base (getf attributes :|base|)) + (xsd-extension (make-instance 'xsd-extension :base base))) + (handle-lxml-schema-elements xsd-extension lxml) + xsd-extension)) + (xsd:|sequence| + (let ((xsd-sequence (make-instance 'xsd-sequence))) + (handle-lxml-schema-elements xsd-sequence lxml) + xsd-sequence)))))

(defun lxml->schema-definition (lxml) (if (eql (lxml-get-tag lxml) 'xsd:|schema|)