- cl-soap-cvs@common-lisp.net - mailman3.common-lisp.net

[cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp
by scaekenberghe＠common-lisp.net 01 Oct '05

01 Oct '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv30878/src Modified Files: wsdl.lisp xsd.lisp Log Message: describe-xsd has been rewritten using the new template system Date: Sat Oct 1 10:48:49 2005 Author: scaekenberghe Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.19 cl-soap/src/wsdl.lisp:1.20 --- cl-soap/src/wsdl.lisp:1.19 Fri Sep 30 19:12:17 2005 +++ cl-soap/src/wsdl.lisp Sat Oct 1 10:48:49 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.19 2005/09/30 17:12:17 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.20 2005/10/01 08:48:49 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -376,8 +376,7 @@ (cond ((get-type part) (format stream " of type: ~a~%" (get-type part))) ((get-element part) - (describe-xsd-element xml-schema-definition (get-element part) - :level 5 :stream stream)))) + (describe-xsd-element (get-element part) xml-schema-definition stream 5)))) (defun describe-wsdl-soap (wsdl-document-definitions &key (stream *standard-output*)) "Print a high-level description of the services/ports/operations in wsdl-document-definitions" Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.21 cl-soap/src/xsd.lisp:1.22 --- cl-soap/src/xsd.lisp:1.21 Fri Sep 30 21:58:05 2005 +++ cl-soap/src/xsd.lisp Sat Oct 1 10:48:49 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.21 2005/09/30 19:58:05 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.22 2005/10/01 08:48:49 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -226,132 +226,6 @@ (defmethod is-plural-p ((xml-schema-element xml-schema-element)) (eql (get-max-occurs xml-schema-element) :unbounded)) -;;; Describing XSD (with pre-rendering of XML) - -(defun indent (n &optional (stream *standard-output*)) - (loop :repeat n :do (write-char #\space stream) (write-char #\space stream))) - -(defmethod describe-multiplicity ((xml-schema-element xml-schema-element)) - (with-slots (min-occurs max-occurs) - xml-schema-element - (cond ((and (zerop min-occurs) (eql max-occurs 1)) "optional") - ((and (eql min-occurs 1) (eql max-occurs 1)) "required") - ((and (eql min-occurs 1) (eql max-occurs :unbounded)) "one or more") - ((and (zerop min-occurs) (eql max-occurs :unbounded)) "zero or more") - (t (format nil "min:~d-max:~d" min-occurs max-occurs))))) - -(defmethod multiplicity-suffix ((xml-schema-element 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)) "") - ((and (eql min-occurs 1) (eql max-occurs :unbounded)) "+") - ((and (zerop min-occurs) (eql max-occurs :unbounded)) "*") - (t (format nil "~d:~d" min-occurs max-occurs))))) - -(defun pre-render-xsd-type (xml-schema-definition type-name &key (level 0) (stream *standard-output*)) - (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))) - (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 " <~a>~a</~a>~a~%" - member-name member-type member-name (multiplicity-suffix member)) - (progn - (format stream " <~a>~%" member-name) - (pre-render-xsd-type xml-schema-definition member-type - :level (1+ level) :stream stream) - (indent level stream) - (format stream " </~a>~a~%" member-name (multiplicity-suffix member))))))) - (if (xsd-primitive-type-name-p type) - (progn - (indent level stream) - (format stream " ~a~%" type)) - (error "unexpected type"))))) - -(defun describe-xsd-type (xml-schema-definition type-name &key (level 0) (stream *standard-output*)) - (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))) - (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]~@[ nillable~]~%" - member-name member-type (describe-multiplicity member) (get-nillable member)) - (progn - (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) - (progn - (indent level stream) - (format stream " primitive type ~a~%" type)) - (error "unexpected type"))))) - -(defun describe-xsd-element (xml-schema-definition element &key (level 0) (stream *standard-output*)) - (unless (typep element 'xml-schema-element) - (setf element (get-element-named xml-schema-definition element))) - (let* ((element-type (get-element-type xml-schema-definition element)) - (element-name (get-name element))) - (if (xsd-primitive-type-name-p element-type) - (progn - (indent level stream) - (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 xml-schema-definition))) - (indent level stream) - (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]~@[ nillable~]~%" - member-name member-type (describe-multiplicity member) (get-nillable member)) - (progn - (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) - (format stream " <~a>~%" element-name) - (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 " <~a>~a</~a>~a~%" - member-name member-type member-name (multiplicity-suffix member)) - (progn - (format stream " <~a>~%" member-name) - (pre-render-xsd-type xml-schema-definition member-type :level (1+ level) :stream stream) - (indent level stream) - (format stream " </~a>~a~%" member-name (multiplicity-suffix member)))))) - (indent level stream) - (format stream " </~a>~a~%" element-name (multiplicity-suffix element)))))) - -(defun describe-xsd (xml-schema-definition &key (stream *standard-output*)) - "Print a high-level description of the top-level elements in xml-schema-definition" - (format stream "XML Schema Definition with target-namespace URI ~s~%" - (get-target-namespace xml-schema-definition)) - (loop :for element :in (get-elements xml-schema-definition) :do - (when (typep element 'xml-schema-element) - (describe-xsd-element xml-schema-definition element - :level 1 :stream stream))) - (values)) - ;;; Template Generation (converting the XSD model to something simpler ;-) ;; an XSD element template looks like this: @@ -496,6 +370,61 @@ (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))) + +;;; Describing XSD (print the 'sexpr' format with multiplicity indicators using in input/output binding) + +(defun indent (n &optional (stream *standard-output*)) + (format stream "~&") + (loop :repeat n + :do (write-char #\space stream) (write-char #\space stream))) + +(defun describe-xsd-template-members (members &optional (stream *standard-output*) (level 0)) + (loop :for member :in members :do + (describe-xsd-template member stream (1+ level)))) + +(defun describe-xsd-template (template &optional (stream *standard-output*) (level 0)) + (destructuring-bind (multiplicity element-name &rest contents) + template + (cond ((null contents) + (indent level) + (format stream "(~s)" element-name)) + ((symbolp (first contents)) + (let ((primitive-type (first contents))) + (case multiplicity + ((1 ?) + (indent level) + (format stream "(~s ~s) ~a " element-name primitive-type multiplicity)) + ((+ *) + (indent level) + (format stream "(~s (~s) ~a )" element-name primitive-type multiplicity))))) + (t + (case multiplicity + ((1 ?) + (indent level) + (format stream "(~a" element-name) + (describe-xsd-template-members contents stream level) + (format stream ") ~a " multiplicity)) + ((+ *) + (indent level) + (format stream "(~a (" element-name) + (describe-xsd-template-members contents stream level) + (format stream ") ~a )" multiplicity))))))) + +(defun describe-xsd-element (element xml-schema-definition &optional (stream *standard-output*) (level 0)) + (let ((template (generate-xsd-template element xml-schema-definition))) + (describe-xsd-template template stream level)) + (format stream "~&") + (values)) + +(defun describe-xsd (xml-schema-definition &optional (stream *standard-output*)) + "Print a high-level description of the top-level elements in xml-schema-definition" + (format stream "XML Schema Definition with target-namespace URI ~s~%" + (get-target-namespace xml-schema-definition)) + (loop :for element :in (get-elements xml-schema-definition) :do + (when (typep element 'xml-schema-element) + (describe-xsd-element element xml-schema-definition stream 1))) + (format stream "~&") + (values)) ;;; Primitive Types/Values (types are identified :keywords)

1 0

[cl-soap-cvs] CVS update: cl-soap/test/development.lisp
by scaekenberghe＠common-lisp.net 30 Sep '05

30 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv9408/test Added Files: development.lisp Log Message: moved from src to test Date: Fri Sep 30 21:59:26 2005 Author: scaekenberghe

1 0

[cl-soap-cvs] CVS update: cl-soap/src/development.lisp
by scaekenberghe＠common-lisp.net 30 Sep '05

30 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv9408/src Removed Files: development.lisp Log Message: moved from src to test Date: Fri Sep 30 21:59:26 2005 Author: scaekenberghe

1 0

[cl-soap-cvs] CVS update: cl-soap/src/xsd.lisp
by scaekenberghe＠common-lisp.net 30 Sep '05

30 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv9383/src Modified Files: xsd.lisp Log Message: various bugfixes Date: Fri Sep 30 21:58:05 2005 Author: scaekenberghe Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.20 cl-soap/src/xsd.lisp:1.21 --- cl-soap/src/xsd.lisp:1.20 Fri Sep 30 21:21:43 2005 +++ cl-soap/src/xsd.lisp Fri Sep 30 21:58:05 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.20 2005/09/30 19:21:43 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.21 2005/09/30 19:58:05 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -358,6 +358,7 @@ ;; 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 +;; elements without contents are also possible (defun get-xsd-template-multiplicity (xml-schema-element) (with-slots (min-occurs max-occurs) @@ -464,29 +465,33 @@ 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))))))))) + (cond ((null contents) `(,element-name)) + ((symbolp (first contents)) + (let ((primitive-type (first contents))) + (case multiplicity + ((1 ?) (if children + (resolve-xsd-template-primitive element-name primitive-type + (lxml-get-contents (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 + (lxml-get-contents child))) + (when (eql multiplicity +) + (error "Required repeating element ~s not bound correctly" element-name))))))) + (t + (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)))

1 0

[cl-soap-cvs] CVS update: cl-soap/test/test-xsd.lisp
by scaekenberghe＠common-lisp.net 30 Sep '05

30 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv9362/test Modified Files: test-xsd.lisp Log Message: removed some obsolete tests Date: Fri Sep 30 21:57:20 2005 Author: scaekenberghe Index: cl-soap/test/test-xsd.lisp diff -u cl-soap/test/test-xsd.lisp:1.2 cl-soap/test/test-xsd.lisp:1.3 --- cl-soap/test/test-xsd.lisp:1.2 Fri Sep 30 19:12:20 2005 +++ cl-soap/test/test-xsd.lisp Fri Sep 30 21:57:20 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-xsd.lisp,v 1.2 2005/09/30 17:12:20 scaekenberghe Exp $ +;;;; $Id: test-xsd.lisp,v 1.3 2005/09/30 19:57:20 scaekenberghe Exp $ ;;;; ;;;; Some (internal) test on the implementatin of the XML Schema Definition ;;;; @@ -113,34 +113,6 @@ *google-adwords-ns*))) (let ((schema (get-xml-schema-definition - (wsdl-cache-get "https://adwords.google.com:443/api/adwords/v2/CampaignService?wsdl"))) - (binding '("id" - 5631435 - "name" - "Campaign #1" - "status" - "Active" - "startDate" - 3335857874 - "endDate" - 3502857599 - "dailyBudget" - 1000000 - "optInSearchNetwork" - T - "optInContentNetwork" - T - "languageTargeting" - (("languages" "en") ("languages" "nl")) - "geoTargeting" - (("countries" "BE") ("countries" "NL"))))) - (pprint (bind-type "Campaign" - binding - nil - schema - *google-adwords-ns*))) - -(let ((schema (get-xml-schema-definition (wsdl-cache-get"https://adwords.google.com:443/api/adwords/v2/TrafficEstimatorService?wsdl"))) (binding `("estimateKeywordList" ("keywordRequests" @@ -153,15 +125,6 @@ binding schema *google-adwords-ns*))) - -(let ((schema (get-xml-schema-definition - (wsdl-cache-get"https://adwords.google.com:443/api/adwords/v2/TrafficEstimatorService?wsdl"))) - (binding '("text" "flowers" "type" "Broad" "maxCpc" 50000))) - (pprint (bind-type "KeywordRequest" - binding - nil - schema - *google-adwords-ns*))) (defun test-1 () (let* ((schema (get-xml-schema-definition

1 0

[cl-soap-cvs] CVS update: cl-soap/src/soap.lisp
by scaekenberghe＠common-lisp.net 30 Sep '05

30 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv9341/src Modified Files: soap.lisp Log Message: better fault parsing Date: Fri Sep 30 21:56:50 2005 Author: scaekenberghe Index: cl-soap/src/soap.lisp diff -u cl-soap/src/soap.lisp:1.7 cl-soap/src/soap.lisp:1.8 --- cl-soap/src/soap.lisp:1.7 Mon Sep 26 13:15:32 2005 +++ cl-soap/src/soap.lisp Fri Sep 30 21:56:49 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: soap.lisp,v 1.7 2005/09/26 11:15:32 scaekenberghe Exp $ +;;;; $Id: soap.lisp,v 1.8 2005/09/30 19:56:49 scaekenberghe Exp $ ;;;; ;;;; The basic SOAP protocol ;;;; @@ -35,10 +35,10 @@ (:documentation "Thrown by CL-SOAP when a standard SOAP Fault is read")) (defun lxml->standard-soap-fault (xml) - (let ((code (second (lxml-find-tag :|faultcode| (rest xml)))) - (string (second (lxml-find-tag :|faultstring| (rest xml)))) - (actor (second (lxml-find-tag :|faultactor| (rest xml)))) - (detail (second (lxml-find-tag :|detail| (rest xml))))) + (let ((code (lxml-get-contents (lxml-find-tag :|faultcode| (rest xml)))) + (string (lxml-get-contents (lxml-find-tag :|faultstring| (rest xml)))) + (actor (lxml-get-contents (lxml-find-tag :|faultactor| (rest xml)))) + (detail (lxml-get-contents (lxml-find-tag :|detail| (rest xml))))) (make-condition 'standard-soap-fault :code code :string string

1 0

[cl-soap-cvs] CVS update: cl-soap/src/lxml.lisp
by scaekenberghe＠common-lisp.net 30 Sep '05

30 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv9321/src Modified Files: lxml.lisp Log Message: added lxml-get-content as proper way to access lxml content (1st child) Date: Fri Sep 30 21:56:01 2005 Author: scaekenberghe Index: cl-soap/src/lxml.lisp diff -u cl-soap/src/lxml.lisp:1.7 cl-soap/src/lxml.lisp:1.8 --- cl-soap/src/lxml.lisp:1.7 Sun Sep 25 14:44:18 2005 +++ cl-soap/src/lxml.lisp Fri Sep 30 21:56:00 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: lxml.lisp,v 1.7 2005/09/25 12:44:18 scaekenberghe Exp $ +;;;; $Id: lxml.lisp,v 1.8 2005/09/30 19:56:00 scaekenberghe Exp $ ;;;; ;;;; Some tools to manipulate lxml ;;;; @@ -34,6 +34,10 @@ (cond ((or (symbolp lxml) (stringp lxml)) '()) (t (rest lxml)))) + +(defun lxml-get-contents (lxml) + "Return the contents (first child) of the lxml XML DOM" + (first (lxml-get-children lxml))) (defun lxml-find-tag (tag lxml) "Find a specific tag in a lxml XML DOM list"

1 0

[cl-soap-cvs] CVS update: cl-soap/src/xsd.lisp
by scaekenberghe＠common-lisp.net 30 Sep '05

30 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv7292/src Modified Files: xsd.lisp Log Message: fixed repeating submember representation in sexpr in resolve-xsd-template and friends Date: Fri Sep 30 21:21:43 2005 Author: scaekenberghe Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.19 cl-soap/src/xsd.lisp:1.20 --- cl-soap/src/xsd.lisp:1.19 Fri Sep 30 19:12:17 2005 +++ cl-soap/src/xsd.lisp Fri Sep 30 21:21:43 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.19 2005/09/30 17:12:17 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.20 2005/09/30 19:21:43 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -478,13 +478,13 @@ (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)) + `(,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))) + ,(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)))))))))

1 0

[cl-soap-cvs] CVS update: cl-soap/test/test-google-adwords.lisp cl-soap/test/test-xsd.lisp
by scaekenberghe＠common-lisp.net 30 Sep '05

30 Sep '05

1 0

[cl-soap-cvs] CVS update: cl-soap/src/development.lisp cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp
by scaekenberghe＠common-lisp.net 30 Sep '05

30 Sep '05

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"

1 0