[cl-soap-cvs] CVS update: cl-soap/src/development.lisp cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp
Sven Van Caekenberghe
scaekenberghe at common-lisp.net
Fri Sep 30 17:12:21 UTC 2005
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 , at 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 , at 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 , at 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))
- , at 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))
- , at 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 , at 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"
More information about the Cl-soap-cvs
mailing list