Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv30515/src
Modified Files: development.lisp wsdl.lisp xsd.lisp Log Message: first version of xsd bind-element/resolve-element based on the new concept of 'xsd templates' - so far input/output symmetry has been reached and initial testing looks good; awaits further/more/deeper testing and some more cleanup/integration
Date: Fri Sep 30 19:12:18 2005 Author: scaekenberghe
Index: cl-soap/src/development.lisp diff -u cl-soap/src/development.lisp:1.1 cl-soap/src/development.lisp:1.2 --- cl-soap/src/development.lisp:1.1 Mon Sep 5 10:35:55 2005 +++ cl-soap/src/development.lisp Fri Sep 30 19:12:17 2005 @@ -1,6 +1,6 @@ ;;;; -*- Mode: LISP -*- ;;;; -;;;; $Id: development.lisp,v 1.1 2005/09/05 08:35:55 scaekenberghe Exp $ +;;;; $Id: development.lisp,v 1.2 2005/09/30 17:12:17 scaekenberghe Exp $ ;;;; ;;;; Development scratch pad ;;;; @@ -22,5 +22,307 @@ (:documentation "Package for symbols in the Google AdWords API XML Namespace"))
(defparameter *google-adwords-ns* (s-xml:register-namespace +google-adwords-ns-uri+ "google" :google)) + +;;; Older Manual Google AdWords Calls + +(export + '(;; headers + "email" "password" "useragent" "token" "clientEmail" + ;; info service + "getUsageQuotaThisMonth" "getUsageQuotaThisMonthResponse" "getUsageQuotaThisMonthReturn" + "getCampaigns" "getCampaign" "getBillingAddress" + ;; optionally add more exports, but this is not really needed for wsdl-soap-call's + )) + +(defun get-usage-quota-this-month () + (multiple-value-bind (result headers) + (soap-call (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/InfoService") + `((google:|email| ,*google-adwords-email*) + (google:|password| ,*google-adwords-password*) + (google:|useragent| ,*google-adwords-user-agent*) + (google:|token| ,*google-adwords-token*)) + `(google:|getUsageQuotaThisMonth|) + :envelope-attributes `(:|xmlns| ,+google-adwords-ns-uri+)) + (if (eql (lxml-get-tag result) 'google:|getUsageQuotaThisMonthResponse|) + (let ((contents (lxml-find-tag 'google:|getUsageQuotaThisMonthReturn| (rest result)))) + (if contents + (values (parse-integer (second contents)) headers) + (error "Expected a <getUsageQuotaThisMonthReturn> element"))) + (error "Expected a <getUsageQuotaThisMonthResponse> element")))) + +(defun get-method-cost (service method &optional (date (ut))) + (multiple-value-bind (result headers) + (soap-call (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/InfoService") + `((google:|email| ,*google-adwords-email*) + (google:|password| ,*google-adwords-password*) + (google:|useragent| ,*google-adwords-user-agent*) + (google:|token| ,*google-adwords-token*)) + `(google:|getMethodCost| + (google:|service| ,service) + (google:|method| ,method) + (google:|date| ,(lisp->xsd-date date))) + :envelope-attributes `(:|xmlns| ,+google-adwords-ns-uri+)) + (if (eql (lxml-get-tag result) 'google:|getMethodCostResponse|) + (let ((contents (lxml-find-tag 'google:|getMethodCostReturn| (rest result)))) + (if contents + (values (parse-integer (second contents)) headers) + (error "Expected a <getMethodCostReturn> element"))) + (error "Expected a <getMethodCostResponse> element")))) + +(defun get-billing-address (client-email) + (multiple-value-bind (result headers) + (soap-call (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/AccountService") + `((google:|email| ,*google-adwords-email*) + (google:|password| ,*google-adwords-password*) + (google:|useragent| ,*google-adwords-user-agent*) + (google:|token| ,*google-adwords-token*) + (google:|clientEmail| ,client-email)) + `(google:|getBillingAddress|) + :envelope-attributes `(:|xmlns| ,+google-adwords-ns-uri+)) + (if (eql (lxml-get-tag result) 'google:|getBillingAddressResponse|) + (values (rest result) headers) + (error "Expected a <getBillingAddressResponse> element")))) + +(defun get-all-adwords-campaigns (client-email) + (multiple-value-bind (result headers) + (soap-call (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/CampaignService") + `((google:|email| ,*google-adwords-email*) + (google:|password| ,*google-adwords-password*) + (google:|useragent| ,*google-adwords-user-agent*) + (google:|token| ,*google-adwords-token*) + (google:|clientEmail| ,client-email)) + `(google:|getAllAdWordsCampaigns| + (google:|dummy| "1")) + :envelope-attributes `(:|xmlns| ,+google-adwords-ns-uri+)) + (values result headers))) + +(defun estimate-keyword-list (keywords) + "((<text> <type> <max-cpc>)*) where type is Broad|Phrase|Exact" + (multiple-value-bind (result headers) + (soap-call (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/TrafficEstimatorService") + `((google:|email| ,*google-adwords-email*) + (google:|password| ,*google-adwords-password*) + (google:|useragent| ,*google-adwords-user-agent*) + (google:|token| ,*google-adwords-token*)) + `(google::|estimateKeywordList| + ,@(mapcar #'(lambda (keyword) + (destructuring-bind (text type max-cpc) + keyword + `(google::|keywordRequest| + (google::|text| ,text) + (google::|type| ,type) + (google::|maxCpc| ,max-cpc)))) + keywords)) + :envelope-attributes `(:|xmlns| ,+google-adwords-ns-uri+)) + (values result headers))) + +(defun get-campaign (id client-email) + (multiple-value-bind (result headers) + (soap-call (make-soap-end-point "https://adwords.google.com:443/api/adwords/v2/CampaignService") + `((google:|email| ,*google-adwords-email*) + (google:|password| ,*google-adwords-password*) + (google:|useragent| ,*google-adwords-user-agent*) + (google:|token| ,*google-adwords-token*) + (google:|clientEmail| ,client-email)) + `(google:|getCampaign| + (google:|id| ,(princ-to-string id))) + :envelope-attributes `(:|xmlns| ,+google-adwords-ns-uri+)) + (values result headers))) + +;; Moved code + +(defun binding-primitive-value (name type bindings) + (let ((value (get-name-binding name bindings))) + (when value + (lisp->xsd-primitive value (intern-xsd-type-name type))))) + +(defun bind-primitive (element type-name bindings namespace) + (let ((value (binding-primitive-value (get-name element) type-name bindings))) + (if value + `(,(intern (get-name element) (s-xml:get-package namespace)) ,value) + (if (is-optional-p element) + nil + (error "Cannot find binding for ~a" (get-name element)))))) + +(defun bind-type (type-spec bindings super-element xml-schema-definition namespace) + (let* ((type-element (if (stringp type-spec) (get-element-named xml-schema-definition type-spec) type-spec)) + (type (get-element-type xml-schema-definition type-element))) + (if (typep type 'xsd-complex-type) + (let ((members (get-members type xml-schema-definition)) + (members-actual-bindings '())) + (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)))) + (if (is-plural-p member) + (let ((count 0)) + (loop :for sub-binding :in (get-name-binding member-name bindings) :do + (if (xsd-primitive-type-name-p member-type) + (let ((member-binding (bind-primitive member member-type + sub-binding namespace))) + (when member-binding + (incf count) + (push member-binding members-actual-bindings))) + (multiple-value-bind (member-binding bound) + (bind-type member-type sub-binding member + xml-schema-definition namespace) + (when bound + (incf count) + (push `(,sub-tag-name ,@member-binding) members-actual-bindings))))) + (if (zerop count) + (unless (or (is-optional-p member) (get-nillable member)) + (error "Required element <~a> not found" member-name)))) + (let ((sub-binding (get-name-binding member-name bindings))) + (cond ((xsd-primitive-type-name-p member-type) + (let ((member-binding (bind-primitive member member-type + bindings namespace))) + (when member-binding + (push member-binding members-actual-bindings)))) + (t + (multiple-value-bind (member-binding bound) + (bind-type member-type sub-binding member + xml-schema-definition namespace) + (if bound + (push `(,sub-tag-name ,@member-binding) members-actual-bindings) + (unless (or (is-optional-p member) (get-nillable member)) + (error "Required member ~a not bound" member-name)))))))))) + (values (nreverse members-actual-bindings) t)) + (if (xsd-primitive-type-name-p type) + (let ((value (binding-primitive-value (get-name super-element) type bindings))) + (if value (values (list value) t) (values nil nil))) + (error "Unexpected type"))))) + +(defun bind-element (element bindings xml-schema-definition namespace) + (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) + (element-type (get-element-type xml-schema-definition element))) + (cond ((xsd-primitive-type-name-p element-type) + (bind-primitive element element-type bindings namespace)) + ((typep element-type 'xsd-complex-type) + (let ((sub-bindings (get-name-binding (get-name element) bindings)) + (tag-name (intern (get-name element) (s-xml:get-package namespace)))) + (if sub-bindings + (multiple-value-bind (members-binding bound) + (bind-type element-type sub-bindings element xml-schema-definition namespace) + (when bound + `(,tag-name ,@members-binding))) + (if (or (is-optional-p element) (null (get-members element-type xml-schema-definition))) + tag-name + (error "Element ~a not bound" (get-name element)))))) + (t (error "Cannot bind element ~s of type ~s" element element-type))))) + +(defun lxml-primitive-value (name type lxml namespace) + (let ((tag-name (intern name (s-xml:get-package namespace)))) + (if (eql (lxml-get-tag lxml) tag-name) + (values (xsd-primitive->lisp (first (lxml-get-children lxml)) (intern-xsd-type-name type)) t) + (values nil nil)))) + +(defun resolve-primitive (element type-name lxml namespace) + (multiple-value-bind (value present) + (lxml-primitive-value (get-name element) type-name lxml namespace) + (if present + (values value t) + (if (is-optional-p element) + (values nil nil) + (error "Expected a <~a> element" (get-name element)))))) + +(defun resolve-type (type-name lxml super-element xml-schema-definition namespace) + (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)) + (resolved-members '())) + (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)))) + (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) + (resolve-primitive member member-type item-lxml namespace) + (when required + (incf count) + (push (list member-name member-value) resolved-members))) + (multiple-value-bind (member-value required) + (resolve-type member-type item-lxml member + xml-schema-definition namespace) + (when required + (incf count) + (push (list member-name 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) + (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) + (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) + (lxml-primitive-value (get-name super-element) type lxml namespace) + (error "Unexpected type"))))) + +(defun resolve-element (element lxml xml-schema-definition namespace) + (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) + (element-type (get-element-type xml-schema-definition element))) + (cond ((xsd-primitive-type-name-p element-type) + (resolve-primitive element element-type lxml namespace)) + ((typep element-type 'xsd-complex-type) + (let ((tag-name (intern (get-name element) (s-xml:get-package namespace)))) + (if (eql (lxml-get-tag lxml) tag-name) + (let ((sub-lxml (lxml-get-children lxml)) + (members (get-members element-type xml-schema-definition)) + (resolved-members '())) + (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)))) + (if (is-plural-p member) + (let ((count 0)) + (loop :for item-lxml :in sub-lxml :do + (if (eql (lxml-get-tag item-lxml) sub-tag-name) + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (resolve-primitive member member-type item-lxml namespace) + (when required + (incf count) + (push (list member-name member-value) resolved-members))) + (multiple-value-bind (member-value required) + (resolve-type member-type item-lxml member + xml-schema-definition namespace) + (when required + (incf count) + (push (list member-name member-value) resolved-members)))) + (error "Expected a <~a> element" sub-tag-name))) + (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 sub-lxml))) + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (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) + (resolve-type member-type member-lxml member + xml-schema-definition namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members)))))))) + (values (list (get-name element) (nreverse resolved-members)) t)) + (if (is-optional-p element) + (values nil nil) + (error "Expected a <~a> element" tag-name))))) + (t (error "Cannot resolve element ~s of type ~s" element element-type)))))
;;;; eof
Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.18 cl-soap/src/wsdl.lisp:1.19 --- cl-soap/src/wsdl.lisp:1.18 Mon Sep 26 13:14:55 2005 +++ cl-soap/src/wsdl.lisp Fri Sep 30 19:12:17 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.18 2005/09/26 11:14:55 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.19 2005/09/30 17:12:17 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -465,13 +465,11 @@ (push (xsd-primitive->lisp part-value (intern-xsd-type-name part-type)) result-values))) (part-element - (multiple-value-bind (value required) - (resolve-element part-element - result - (get-xml-schema-definition wsdl-document-definitions) - namespace) - (when required - (push value result-values)))) + (let ((part-value (resolve-element part-element + result + (get-xml-schema-definition wsdl-document-definitions) + namespace))) + (push part-value result-values))) (t (error "Cannot resolve output binding ~a:~a" (get-name output-message) (get-name part)))))) ;; make the common case more handy (if (= (length result-values) 1)
Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.18 cl-soap/src/xsd.lisp:1.19 --- cl-soap/src/xsd.lisp:1.18 Wed Sep 28 11:00:51 2005 +++ cl-soap/src/xsd.lisp Fri Sep 30 19:12:17 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.18 2005/09/28 09:00:51 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.19 2005/09/30 17:12:17 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -191,22 +191,24 @@ (when element (get-type-in-context element (get-elements xml-schema-definition)))))
-(defmethod get-members ((xsd-complex-type xsd-complex-type)) +(defmethod get-members ((xsd-complex-type xsd-complex-type) (xml-schema-definition xml-schema-definition)) "Return the list of members of xsd-complex-type, provided it is a sequence or a complex-content (for now)" (let ((first-child (first (get-children xsd-complex-type)))) (cond ((and first-child (typep first-child 'xsd-sequence)) (get-children first-child)) ((and first-child (typep first-child 'xsd-complex-content)) - (get-members first-child))))) + (get-members first-child xml-schema-definition)))))
-(defmethod get-members ((xsd-complex-content xsd-complex-content)) +(defmethod get-members ((xsd-complex-content xsd-complex-content) (xml-schema-definition xml-schema-definition)) "Return the list of members of xsd-complex-content, provided it is a base type sequence extension (for now)" (let ((first-child (first (get-children xsd-complex-content)))) (when (and first-child (typep first-child 'xsd-extension)) - (let ((base-members (get-members (get-base first-child))) - (first-child (first (get-children first-child)))) + (let* ((base-type-name (get-base first-child)) + (base-type-element (get-element-named xml-schema-definition base-type-name)) + (base-members (get-members base-type-element xml-schema-definition)) + (first-child (first (get-children first-child)))) (if (and first-child (typep first-child 'xsd-sequence)) - (append base-members (get-members first-child)) + (append base-members (get-children first-child)) base-members)))))
(defmethod get-multiplicity ((xml-schema-element xml-schema-element)) @@ -224,219 +226,6 @@ (defmethod is-plural-p ((xml-schema-element xml-schema-element)) (eql (get-max-occurs xml-schema-element) :unbounded))
-;;; Binding and Resolving elements to and from actual data - -(defun get-name-binding (name bindings) - (second (member (actual-name name) bindings :test #'equal))) - -(defun binding-primitive-value (name type bindings) - (let ((value (get-name-binding name bindings))) - (when value - (lisp->xsd-primitive value (intern-xsd-type-name type))))) - -(defun bind-primitive (element type-name bindings namespace) - (let ((value (binding-primitive-value (get-name element) type-name bindings))) - (if value - `(,(intern (get-name element) (s-xml:get-package namespace)) ,value) - (if (is-optional-p element) - nil - (error "Cannot find binding for ~a" (get-name element)))))) - -(defun bind-type (type-name bindings super-element xml-schema-definition namespace) - (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)) - (members-actual-bindings '())) - (loop :for member :in members :do - (let ((member-name (get-name member)) - (member-type (get-type member)) - (sub-bindings (or (get-name-binding (get-name type-element) bindings) - bindings))) - (if (xsd-primitive-type-name-p member-type) - (let ((member-binding (bind-primitive member member-type sub-bindings namespace))) - (when member-binding - (push member-binding members-actual-bindings))) - (multiple-value-bind (member-binding bound) - (bind-type member-type sub-bindings member xml-schema-definition namespace) - (if bound - (push `(,(intern member-name (s-xml:get-package namespace)) - ,member-binding) - members-actual-bindings) - (unless (is-optional-p member) - (error "Required member ~a not bound" member-name))))))) - (values (nreverse members-actual-bindings) t)) - (if (xsd-primitive-type-name-p type) - (let ((value (binding-primitive-value (get-name super-element) type bindings))) - (if value (values value t) (values nil nil))) - (error "unexpected type"))))) - -(defun bind-element (element bindings xml-schema-definition namespace) - (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) - (element-type (get-element-type xml-schema-definition element))) - (cond ((xsd-primitive-type-name-p element-type) - (bind-primitive element element-type bindings namespace)) - ((typep element-type 'xsd-complex-type) - (let ((members (get-members element-type)) - (members-actual-bindings '())) - (loop :for member :in members :do - (let* ((member-name (get-name member)) - (member-type (get-type member))) - (if (is-plural-p member) - (let ((count 0)) - (loop :for sub-binding :in bindings :do - (if (xsd-primitive-type-name-p member-type) - (let ((member-binding (bind-primitive member member-type - sub-binding namespace))) - (when member-binding - (incf count) - (push member-binding members-actual-bindings))) - (multiple-value-bind (member-binding bound) - (bind-type member-type sub-binding member - xml-schema-definition namespace) - (when bound - (incf count) - (push `(,(intern member-name (s-xml:get-package namespace)) - ,@member-binding) - members-actual-bindings))))) - (if (zerop count) - (unless (is-optional-p member) - (error "Required member ~a not bound" member-name)))) - (let ((sub-bindings (or (get-name-binding member-type bindings) - bindings))) - (if (xsd-primitive-type-name-p member-type) - (let ((member-binding (bind-primitive member member-type - bindings namespace))) - (when member-binding - (push member-binding members-actual-bindings))) - (multiple-value-bind (member-binding bound) - (bind-type member-type sub-bindings member - xml-schema-definition namespace) - (if bound - (push `(,(intern member-name (s-xml:get-package namespace)) - ,@member-binding) - members-actual-bindings) - (unless (is-optional-p member) - (error "Required member ~a not bound" member-name))))))))) - `(,(intern (get-name element) (s-xml:get-package namespace)) - ,@(nreverse members-actual-bindings)))) - (t (error "Cannot bind element ~s of type ~s" element element-type))))) - -(defun lxml-primitive-value (name type lxml namespace) - (let ((tag-name (intern name (s-xml:get-package namespace)))) - (if (eql (lxml-get-tag lxml) tag-name) - (values (xsd-primitive->lisp (first (lxml-get-children lxml)) (intern-xsd-type-name type)) t) - (values nil nil)))) - -(defun resolve-primitive (element type-name lxml namespace) - (multiple-value-bind (value present) - (lxml-primitive-value (get-name element) type-name lxml namespace) - (if present - (values value t) - (if (is-optional-p element) - (values nil nil) - (error "Expected a <~a> element" (get-name element)))))) - -(defun resolve-type (type-name lxml super-element xml-schema-definition namespace) - (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)) - (resolved-members '())) - (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)))) - (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) - (resolve-primitive member member-type item-lxml namespace) - (when required - (incf count) - (push (list member-name member-value) resolved-members))) - (multiple-value-bind (member-value required) - (resolve-type member-type item-lxml member - xml-schema-definition namespace) - (when required - (incf count) - (push (list member-name 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) - (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) - (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) - (lxml-primitive-value (get-name super-element) type lxml namespace) - (error "unexpected type"))))) - -(defun resolve-element (element lxml xml-schema-definition namespace) - (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) - (element-type (get-element-type xml-schema-definition element))) - (cond ((xsd-primitive-type-name-p element-type) - (resolve-primitive element element-type lxml namespace)) - ((typep element-type 'xsd-complex-type) - (let ((tag-name (intern (get-name element) (s-xml:get-package namespace)))) - (if (eql (lxml-get-tag lxml) tag-name) - (let ((sub-lxml (lxml-get-children lxml)) - (members (get-members element-type)) - (resolved-members '())) - (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)))) - (if (is-plural-p member) - (let ((count 0)) - (loop :for item-lxml :in sub-lxml :do - (if (eql (lxml-get-tag item-lxml) sub-tag-name) - (if (xsd-primitive-type-name-p member-type) - (multiple-value-bind (member-value required) - (resolve-primitive member member-type item-lxml namespace) - (when required - (incf count) - (push (list member-name member-value) resolved-members))) - (multiple-value-bind (member-value required) - (resolve-type member-type item-lxml member - xml-schema-definition namespace) - (when required - (incf count) - (push (list member-name member-value) resolved-members)))) - (error "Expected a <~a> element" sub-tag-name))) - (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 sub-lxml))) - (if (xsd-primitive-type-name-p member-type) - (multiple-value-bind (member-value required) - (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) - (resolve-type member-type member-lxml member - xml-schema-definition namespace) - (when required - (push member-name resolved-members) - (push member-value resolved-members)))))))) - (values (list (get-name element) (nreverse resolved-members)) t)) - (if (is-optional-p element) - (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)
(defun indent (n &optional (stream *standard-output*)) @@ -464,7 +253,7 @@ (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))) + (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))) @@ -488,7 +277,7 @@ (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))) + (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))) @@ -520,7 +309,7 @@ (indent level stream) (format stream " <~a>~a</~a>~a~%" element-name element-type element-name (multiplicity-suffix element))) - (let ((members (get-members element-type))) + (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)) @@ -563,7 +352,147 @@ :level 1 :stream stream))) (values))
-;;; Primitive Types/Values (types are keywords) +;;; Template Generation (converting the XSD model to something simpler ;-) + +;; an XSD element template looks like this: +;; ELT = ( <multiplicity> "element-name" [ :primitive | ELT* ] ) +;; where <multiplicity> is 1, ?, + or * and :primitive is a XSD primitive type keyword +;; all element types are resolved into primitives or sequences of sub elements + +(defun get-xsd-template-multiplicity (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)) (if (get-nillable xml-schema-element) '? 1)) + ((and (eql min-occurs 1) (eql max-occurs :unbounded)) (if (get-nillable xml-schema-element) '* '+)) + ((and (zerop min-occurs) (eql max-occurs :unbounded)) '*) + (t :complex)))) + +(defun generate-xsd-template (xml-schema-element xml-schema-definition) + (when (stringp xml-schema-element) + (setf xml-schema-element (or (get-element-named xml-schema-definition xml-schema-element) + (error "Cannot find element named ~s" xml-schema-element)))) + (let ((multiplicity (get-xsd-template-multiplicity xml-schema-element)) + (type (get-element-type xml-schema-definition xml-schema-element)) + (element-name (get-name xml-schema-element))) + (unless (xsd-primitive-type-name-p type) + ;; make sure simple types are resolved to their base primitive type + (setf type (get-element-type xml-schema-definition type))) + (if (xsd-primitive-type-name-p type) + (let ((primitive-type-name (intern-xsd-type-name type))) + `(,multiplicity ,element-name ,primitive-type-name)) + (let ((members (loop :for member :in (get-members type xml-schema-definition) + :collect (generate-xsd-template member xml-schema-definition)))) + `(,multiplicity ,element-name ,@members))))) + +(defun generate-xsd-templates (xml-schema-definition) + (loop :for element :in (get-elements xml-schema-definition) + :when (typep element 'xml-schema-element) + :collect (generate-xsd-template element xml-schema-definition))) + +;;; Binding Templates (combining a template with an s-expr to generate an lxml list of tags) + +(defun get-name-binding (name bindings) + (let ((name-binding (member (actual-name name) bindings :test #'equal))) + (if name-binding + (values (second name-binding) t) + (values nil nil)))) + +(defun bind-xsd-template-primitive (tag primitive-type value) + (let ((primitive-value (lisp->xsd-primitive value primitive-type))) + `(,tag ,primitive-value))) + +(defun bind-xsd-template-members (tag members bindings namespace) + (let ((bound-members '())) + (loop :for member :in members :do + (let ((member-binding (bind-xsd-template member bindings namespace))) + (when member-binding + (push member-binding bound-members)))) + `(,tag ,@(reduce #'append (nreverse bound-members))))) + +(defun bind-xsd-template (template bindings namespace) + (destructuring-bind (multiplicity element-name &rest contents) + template + (let ((tag (intern element-name (s-xml:get-package namespace)))) + (multiple-value-bind (value boundp) + (get-name-binding element-name bindings) + (cond ((null contents) `(,tag)) + ((symbolp (first contents)) + (let ((primitive-type (first contents))) + (case multiplicity + ((1 ?) (if boundp + `(,(bind-xsd-template-primitive tag primitive-type value)) + (when (eql multiplicity 1) + (error "Required element ~s not bound" element-name)))) + ((+ *) (if (and boundp value) + (loop :for elt-value :in value + :collect (bind-xsd-template-primitive tag primitive-type elt-value)) + (when (eql multiplicity +) + (error "Required repeating element ~s not bound correctly" element-name))))))) + (t + (case multiplicity + ((1 ?) (if boundp + `(,(bind-xsd-template-members tag contents value namespace)) + (when (eql multiplicity 1) + (error "Required element ~s not bound" element-name)))) + ((+ *) (if (and boundp value) + (loop :for elt-value :in value + :collect (bind-xsd-template-members tag contents elt-value namespace)) + (when (eql multiplicity +) + (error "Required repeating element ~s not bound correctly" element-name))))))))))) + +(defun bind-element (element bindings xml-schema-definition namespace) + (let ((template (generate-xsd-template element xml-schema-definition))) + (reduce #'append (bind-xsd-template template bindings namespace)))) + +;;; Resolving Templates (combining a template with an lxml list to generate an s-expr) + +(defun resolve-xsd-template-primitive (element-name primitive-type string) + (let ((value (xsd-primitive->lisp string primitive-type))) + `(,element-name ,value))) + +(defun resolve-xsd-template-members (members lxml namespace) + (let ((resolved-members '())) + (loop :for member :in members :do + (let ((member-binding (resolve-xsd-template member lxml namespace))) + (when member-binding + (push member-binding resolved-members)))) + (reduce #'append (nreverse resolved-members)))) + +(defun resolve-xsd-template (template lxml namespace) + (destructuring-bind (multiplicity element-name &rest contents) + template + (let* ((tag (intern element-name (s-xml:get-package namespace))) + (children (lxml-find-tags tag lxml))) + (if (symbolp (first contents)) + (let ((primitive-type (first contents))) + (case multiplicity + ((1 ?) (if children + (resolve-xsd-template-primitive element-name primitive-type (second (first children))) + (when (eql multiplicity 1) + (error "Required element ~s not bound" element-name)))) + ((+ *) (if children + (loop :for child :in children + :collect (resolve-xsd-template-primitive element-name primitive-type (second child))) + (when (eql multiplicity +) + (error "Required repeating element ~s not bound correctly" element-name)))))) + (case multiplicity + ((1 ?) (if children + `(,element-name ,@(resolve-xsd-template-members contents (first children) namespace)) + (when (eql multiplicity 1) + (error "Required element ~s not bound" element-name)))) + ((+ *) (if children + `(,element-name + ,@(loop :for child :in children + :collect (resolve-xsd-template-members contents child namespace))) + (when (eql multiplicity +) + (error "Required repeating element ~s not bound correctly" element-name))))))))) + +(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))) + +;;; Primitive Types/Values (types are identified :keywords)
(defconstant +known-primitive-type-names+ '("string"