cl-soap-cvs September 2005

cl-soap-cvs@common-lisp.net

1 participants
80 discussions

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

26 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap In directory common-lisp.net:/tmp/cvs-serv24509 Modified Files: cl-soap.asd Log Message: some code cleanup, more exports Date: Mon Sep 26 13:17:42 2005 Author: scaekenberghe Index: cl-soap/cl-soap.asd diff -u cl-soap/cl-soap.asd:1.3 cl-soap/cl-soap.asd:1.4 --- cl-soap/cl-soap.asd:1.3 Thu Sep 22 21:58:50 2005 +++ cl-soap/cl-soap.asd Mon Sep 26 13:17:41 2005 @@ -1,6 +1,6 @@ ;;;; -*- Mode: LISP -*- ;;;; -;;;; $Id: cl-soap.asd,v 1.3 2005/09/22 19:58:50 scaekenberghe Exp $ +;;;; $Id: cl-soap.asd,v 1.4 2005/09/26 11:17:41 scaekenberghe Exp $ ;;;; ;;;; The CL-SOAP ASDF system definition ;;;; @@ -19,7 +19,7 @@ :maintainer "Sven Van Caekenberghe <svc(a)mac.com>" :licence "Lesser Lisp General Public License (LLGPL)" :description "Common Lisp SOAP Package" - :long-description "CL-SOAP is an implementation of the SOAP 1.1 and WSDL 1.1 procotols" + :long-description "CL-SOAP is an implementation of the SOAP 1.1, WSDL 1.1 and XML Schema Definition procotols" :components ((:module

1 0

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

26 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv23840/src Modified Files: soap.lisp Log Message: added report-soap-call debugging tool Date: Mon Sep 26 13:15:33 2005 Author: scaekenberghe Index: cl-soap/src/soap.lisp diff -u cl-soap/src/soap.lisp:1.6 cl-soap/src/soap.lisp:1.7 --- cl-soap/src/soap.lisp:1.6 Mon Sep 19 18:56:13 2005 +++ cl-soap/src/soap.lisp Mon Sep 26 13:15:32 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: soap.lisp,v 1.6 2005/09/19 16:56:13 scaekenberghe Exp $ +;;;; $Id: soap.lisp,v 1.7 2005/09/26 11:15:32 scaekenberghe Exp $ ;;;; ;;;; The basic SOAP protocol ;;;; @@ -84,6 +84,12 @@ (defvar *last-soap-result-xml* nil "When *debug-stream* is non-nil, will contain the last SOAP result's parsed XML") + +(defun report-soap-call () + (format t "~&;; CL-SOAP last call and result envelopes:~%") + (pprint *last-soap-call-xml*) + (terpri) + (pprint *last-soap-result-xml*)) (defun soap-call (server-end-point header

1 0

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

26 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/test In directory common-lisp.net:/tmp/cvs-serv23484/test Modified Files: test-google-adwords.lisp Log Message: incorporated wsdl caching to main code Date: Mon Sep 26 13:14:56 2005 Author: scaekenberghe Index: cl-soap/test/test-google-adwords.lisp diff -u cl-soap/test/test-google-adwords.lisp:1.8 cl-soap/test/test-google-adwords.lisp:1.9 --- cl-soap/test/test-google-adwords.lisp:1.8 Fri Sep 23 23:33:06 2005 +++ cl-soap/test/test-google-adwords.lisp Mon Sep 26 13:14:56 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: test-google-adwords.lisp,v 1.8 2005/09/23 21:33:06 scaekenberghe Exp $ +;;;; $Id: test-google-adwords.lisp,v 1.9 2005/09/26 11:14:56 scaekenberghe Exp $ ;;;; ;;;; Some test on the Google AdWords API (not publically available) ;;;; @@ -58,14 +58,6 @@ (defun parse-all-wsdl () (mapcar #'parse-wsdl-url *google-adwords-api-wsdl-urls*)) - -(defvar *wsdl-cache* (make-hash-table :test #'equal)) - -(defun wsdl-cache-get (url) - (let ((cached (gethash url *wsdl-cache*))) - (if cached - cached - (setf (gethash url *wsdl-cache*) (parse-wsdl-url url))))) ;;; some test calls

1 0

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

26 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv23484/src Modified Files: wsdl.lisp Log Message: incorporated wsdl caching to main code Date: Mon Sep 26 13:14:55 2005 Author: scaekenberghe Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.17 cl-soap/src/wsdl.lisp:1.18 --- cl-soap/src/wsdl.lisp:1.17 Mon Sep 26 12:52:45 2005 +++ cl-soap/src/wsdl.lisp Mon Sep 26 13:14:55 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.17 2005/09/26 10:52:45 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.18 2005/09/26 11:14:55 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -300,6 +300,25 @@ (let ((buffer (do-http-request url))) (with-input-from-string (in buffer) (parse-wsdl in)))) + +;; A simple caching mechanism for WSDL's by URL + +(defvar *wsdl-cache* (make-hash-table :test #'equal)) + +(defun wsdl-cache-get (url) + "Access a possibly cached WSDL url, downloading and parsing it if necessary" + (let ((cached (gethash url *wsdl-cache*))) + (if cached + cached + (setf (gethash url *wsdl-cache*) (parse-wsdl-url url))))) + +(defun wsdl-cache-clear (url) + "Clear the WSDL caching of url" + (remhash url *wsdl-cache*)) + +(defun wsdl-cache-clear-all () + "Clear the whole WSDL cache" + (clrhash *wsdl-cache*)) ;; Interpreting the WSDL model

1 0

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

26 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv23437/src Modified Files: http-client.lisp Log Message: some code reformatting Date: Mon Sep 26 13:08:42 2005 Author: scaekenberghe Index: cl-soap/src/http-client.lisp diff -u cl-soap/src/http-client.lisp:1.5 cl-soap/src/http-client.lisp:1.6 --- cl-soap/src/http-client.lisp:1.5 Thu Sep 15 15:30:44 2005 +++ cl-soap/src/http-client.lisp Mon Sep 26 13:08:42 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: http-client.lisp,v 1.5 2005/09/15 13:30:44 scaekenberghe Exp $ +;;;; $Id: http-client.lisp,v 1.6 2005/09/26 11:08:42 scaekenberghe Exp $ ;;;; ;;;; A basic HTTP client, somewhat API compatible with portableaserve's do-http-request ;;;; Copied from another project (basic authorization support removed) @@ -58,7 +58,8 @@ (defun response-read-headers (stream) (loop :for line = (read-line stream nil) - :until (or (zerop (length line)) + :until (or (null line) + (zerop (length line)) (char= (elt line 0) #\return) (char= (elt line 0) #\linefeed)) :collect (let ((colon (position #\: line))) @@ -80,7 +81,8 @@ (return) (let ((total-chunk-size 0)) (loop (let ((size (read-sequence buffer stream - :end (min (length buffer) (- chunk-size total-chunk-size))))) + :end (min (length buffer) + (- chunk-size total-chunk-size))))) (incf total-chunk-size size) (write-sequence buffer out :end size) (when (= total-chunk-size chunk-size) @@ -93,8 +95,10 @@ (total-size 0)) (with-output-to-string (out) (loop - (let ((size (read-sequence buffer stream :end (when length - (min (length buffer) (- length total-size)))))) + (let ((size (read-sequence buffer stream + :end (when length + (min (length buffer) + (- length total-size)))))) (incf total-size size) (write-sequence buffer out :end size) (when (or (and length (= total-size length)) @@ -106,9 +110,11 @@ (defmethod get-http-server-state ((http-client-state http-client-state) scheme-host-port) (with-slots (data) http-client-state - (let ((server-state (find scheme-host-port data :key #'get-scheme-host-port :test #'string-equal))) + (let ((server-state (find scheme-host-port data + :key #'get-scheme-host-port :test #'string-equal))) (unless server-state - (push (setf server-state (make-instance 'http-server-state :scheme-host-port scheme-host-port)) + (push (setf server-state (make-instance 'http-server-state + :scheme-host-port scheme-host-port)) data)) server-state))) @@ -130,15 +136,19 @@ #+clisp (when (eql scheme :http) (socket:socket-connect port host)) #+cmu (when (eql scheme :http) - (sys:make-fd-stream (ext:connect-to-inet-socket host port) :input t :output t :buffering :none)) + (sys:make-fd-stream (ext:connect-to-inet-socket host port) + :input t :output t :buffering :none)) #+sbcl (when (eql scheme :http) - (let ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream :protocol :tcp))) (sb-bsd-sockets:socket-connect socket (car (sb-bsd-sockets:host-ent-addresses (sb-bsd-sockets:get-host-by-name host))) port) - (sb-bsd-sockets:socket-make-stream socket :element-type 'character :input t :output t :buffering :none)))) + (sb-bsd-sockets:socket-make-stream socket + :element-type 'character + :input t :output t :buffering :none)))) (defun get-open-connection (scheme host port state &key force-new) (if state @@ -149,7 +159,8 @@ (values connection :keep-alive) (progn (when connection (ignore-errors (close connection))) - (values (setf (get-socket server-state) (open-socket-stream scheme host port)) :new)))) + (values (setf (get-socket server-state) (open-socket-stream scheme host port)) + :new)))) (values (open-socket-stream scheme host port) :new))) ;; high level HTTP protocol @@ -180,7 +191,9 @@ "Write an HTTP request, full header and body, to stream" (format-http-request-line stream "~a ~a~@[?~a~] HTTP/1.1" - method (if (puri:uri-path uri) (puri:uri-path uri) "/") (puri:uri-query uri)) + method (if (puri:uri-path uri) + (puri:uri-path uri) "/") + (puri:uri-query uri)) (format-http-request-line stream "Host: ~a:~d" (puri:uri-host uri) (puri:uri-port uri)) (format-http-request-line stream "User-Agent: ~a" *http-client-agent*) (format-http-request-line stream "Accept: ~a" *http-client-accept*) @@ -231,7 +244,8 @@ (flet ((execute-request-response () (values-list `(,@(multiple-value-list (do-one-request-response connection uri method - :content content :content-type content-type + :content content + :content-type content-type :headers headers)) ,keep-alive)))) (unwind-protect

1 0

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

26 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv22402/src Modified Files: wsdl.lisp Log Message: renamed bind-header to bind-input-headers now using bind-element in bind-input-headers Date: Mon Sep 26 12:52:45 2005 Author: scaekenberghe Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.16 cl-soap/src/wsdl.lisp:1.17 --- cl-soap/src/wsdl.lisp:1.16 Mon Sep 26 12:41:50 2005 +++ cl-soap/src/wsdl.lisp Mon Sep 26 12:52:45 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.16 2005/09/26 10:41:50 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.17 2005/09/26 10:52:45 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -421,25 +421,18 @@ (t (error "Cannot resolve input binding ~a:~a" (get-name input-message) (get-name part)))))) (nreverse actual-input-parameters))) -(defun bind-headers (soap-input-headers headers wsdl-document-definitions) - ;; default namespace! +(defun bind-input-headers (soap-input-headers headers wsdl-document-definitions) (let ((actual-headers '())) (loop :for part :in soap-input-headers :do - (let* ((value (get-name-binding (get-name part) headers)) - (element (get-element-named wsdl-document-definitions (get-element part))) - (type (get-element-type (get-xml-schema-definition wsdl-document-definitions) - (get-name element)))) - (if value - (push `(,(intern (get-name part) :keyword) - ,(if (xsd-primitive-type-name-p type) - (lisp->xsd-primitive value (intern-xsd-type-name type)) - (error "Non-primitive header type ~a not allowed" type))) - actual-headers) - (error "No input header binding found for ~a" (get-name part))))) + (let* ((element (get-element part)) + (namespace (s-xml:find-namespace (get-target-namespace wsdl-document-definitions))) + (xml-schema-definition (get-xml-schema-definition wsdl-document-definitions)) + (binding (bind-element element headers xml-schema-definition namespace))) + (when binding + (push binding actual-headers)))) (nreverse actual-headers))) (defun bind-output-parts (result output-message output wsdl-document-definitions) - ;; namespaces! (declare (ignore output)) (let ((namespace (s-xml:find-namespace (get-target-namespace wsdl-document-definitions))) (result-values '())) @@ -488,7 +481,7 @@ (error "The case where input and output namespaces differ is not yet supported")) (multiple-value-bind (result headers) (soap-call soap-end-point - (bind-headers soap-input-headers headers wsdl-document-definitions) + (bind-input-headers soap-input-headers headers wsdl-document-definitions) ;; we assume there is only one parameter (first (bind-input-parts input-message input wsdl-document-definitions)) :soap-action soap-action @@ -532,14 +525,12 @@ (error "Expected <~a> element" output-wrapper))))))) (defun wsdl-soap-input-headers (wsdl-document-definitions binding-operation-input) - (let ((soap-input-headers (get-extensions-of-class binding-operation-input 'wsdl-soap-header)) - (parts '())) - (loop :for soap-input-header :in soap-input-headers :do - (let* ((part-name (get-part soap-input-header)) - (header-message (get-message-named wsdl-document-definitions (get-message soap-input-header)))) - (push (get-part-named header-message part-name) - parts))) - (nreverse parts))) + (let ((soap-input-headers (get-extensions-of-class binding-operation-input 'wsdl-soap-header))) + (loop :for soap-input-header :in soap-input-headers + :collect (let* ((part-name (get-part soap-input-header)) + (message-name (get-message soap-input-header)) + (header-message (get-message-named wsdl-document-definitions message-name))) + (get-part-named header-message part-name))))) (defun wsdl-soap-call-internal (wsdl-document-definitions port

1 0

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

26 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv21363/src Modified Files: wsdl.lisp xsd.lisp Log Message: removed old resolve/bind -element and replaced them by new-* versions Date: Mon Sep 26 12:41:51 2005 Author: scaekenberghe Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.15 cl-soap/src/wsdl.lisp:1.16 --- cl-soap/src/wsdl.lisp:1.15 Fri Sep 23 23:33:05 2005 +++ cl-soap/src/wsdl.lisp Mon Sep 26 12:41:50 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.15 2005/09/23 21:33:05 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.16 2005/09/26 10:41:50 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -413,10 +413,10 @@ (unless (is-optional-p part-element) (error "No input binding found for ~a:~a" (get-name input-message) (get-name part)))))) (part-element - (push (new-bind-element part-element - input - (get-xml-schema-definition wsdl-document-definitions) - namespace) + (push (bind-element part-element + input + (get-xml-schema-definition wsdl-document-definitions) + namespace) actual-input-parameters)) (t (error "Cannot resolve input binding ~a:~a" (get-name input-message) (get-name part)))))) (nreverse actual-input-parameters))) @@ -454,10 +454,10 @@ result-values))) (part-element (multiple-value-bind (value required) - (new-resolve-element part-element - result - (get-xml-schema-definition wsdl-document-definitions) - namespace) + (resolve-element part-element + result + (get-xml-schema-definition wsdl-document-definitions) + namespace) (when required (push value result-values)))) (t (error "Cannot resolve output binding ~a:~a" (get-name output-message) (get-name part)))))) Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.12 cl-soap/src/xsd.lisp:1.13 --- cl-soap/src/xsd.lisp:1.12 Mon Sep 26 10:43:56 2005 +++ cl-soap/src/xsd.lisp Mon Sep 26 12:41:50 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.12 2005/09/26 08:43:56 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.13 2005/09/26 10:41:50 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -209,44 +209,20 @@ (defun get-name-binding (name bindings) (second (member (actual-name name) bindings :test #'equal))) -(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) - (let ((value (get-name-binding (get-name element) bindings))) - (if value - `(,(intern (get-name element) (s-xml:get-package namespace)) - ,(lisp->xsd-primitive value (intern-xsd-type-name element-type))) - (if (is-optional-p element) - nil - (error "Cannot find binding for ~a" (get-name element)))))) - ((typep element-type 'xsd-complex-type) - (let ((members (get-members element-type)) - (member-actual-bindings '())) - (loop :for member :in members :do - (let* ((sub-bindings (or (get-name-binding (get-name element-type) bindings) - bindings)) - (member-binding (bind-element member sub-bindings xml-schema-definition namespace))) - (if member-binding - (push member-binding member-actual-bindings)))) - `(,(intern (get-name element) (s-xml:get-package namespace)) - ,@(nreverse member-actual-bindings)))) - (t (error "Cannot bind element ~s of type ~s" element element-type))))) - -(defun new-binding-primitive-value (name type bindings) +(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 new-bind-primitive (element type-name bindings namespace) - (let ((value (new-binding-primitive-value (get-name element) type-name bindings))) +(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 new-bind-type (type-name bindings super-element xml-schema-definition namespace) +(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) @@ -258,11 +234,11 @@ (sub-bindings (or (get-name-binding (get-name type-element) bindings) bindings))) (if (xsd-primitive-type-name-p member-type) - (let ((member-binding (new-bind-primitive member member-type sub-bindings namespace))) + (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) - (new-bind-type member-type sub-bindings member xml-schema-definition namespace) + (bind-type member-type sub-bindings member xml-schema-definition namespace) (if bound (push `(,(intern member-name (s-xml:get-package namespace)) ,member-binding) @@ -271,15 +247,15 @@ (error "Required member ~a not bound" member-name))))))) (values (nreverse members-actual-bindings) t)) (if (xsd-primitive-type-name-p type) - (let ((value (new-binding-primitive-value (get-name super-element) type bindings))) + (let ((value (binding-primitive-value (get-name super-element) type bindings))) (if value (values value t) (values nil nil))) (error "unexpected type"))))) -(defun new-bind-element (element bindings xml-schema-definition namespace) +(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) - (new-bind-primitive element element-type bindings namespace)) + (bind-primitive element element-type bindings namespace)) ((typep element-type 'xsd-complex-type) (let ((members (get-members element-type)) (members-actual-bindings '())) @@ -290,14 +266,14 @@ (let ((count 0)) (loop :for sub-binding :in bindings :do (if (xsd-primitive-type-name-p member-type) - (let ((member-binding (new-bind-primitive member member-type - sub-binding namespace))) + (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) - (new-bind-type member-type sub-binding member - xml-schema-definition namespace) + (bind-type member-type sub-binding member + xml-schema-definition namespace) (when bound (incf count) (push `(,(intern member-name (s-xml:get-package namespace)) @@ -309,13 +285,13 @@ (let ((sub-bindings (or (get-name-binding member-type bindings) bindings))) (if (xsd-primitive-type-name-p member-type) - (let ((member-binding (new-bind-primitive member member-type - bindings namespace))) + (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) - (new-bind-type member-type sub-bindings member - xml-schema-definition namespace) + (bind-type member-type sub-bindings member + xml-schema-definition namespace) (if bound (push `(,(intern member-name (s-xml:get-package namespace)) ,@member-binding) @@ -326,51 +302,22 @@ ,@(nreverse members-actual-bindings)))) (t (error "Cannot bind element ~s of type ~s" element element-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) - (let ((tag-name (intern (get-name element) (s-xml:get-package namespace)))) - (if (eql (lxml-get-tag lxml) tag-name) - (values (xsd-primitive->lisp (second lxml) (intern-xsd-type-name element-type)) t) - (if (is-optional-p element) - (values nil nil) - (error "Expected a <~a> element" tag-name))))) - ((typep element-type 'xsd-complex-type) - (let ((tag-name (intern (get-name element) (s-xml:get-package namespace))) - (members (get-members element-type))) - (if (eql (lxml-get-tag lxml) tag-name) - (let ((resolved-members '())) - (loop :for member :in members :do - (let* ((sub-tag-name (intern (get-name member) (s-xml:get-package namespace))) - (sub-lxml (lxml-find-tag sub-tag-name (rest lxml)))) - (multiple-value-bind (value required) - (resolve-element member sub-lxml xml-schema-definition namespace) - (when required - (push (get-name element) resolved-members) - (push value resolved-members))))) - (values (nreverse resolved-members) t)) - (if (is-optional-p element) - (values nil nil) - (error "Expected a <~a> element" tag-name))))) - (t (error "Cannot bind element ~s of type ~s" element element-type))))) - -(defun new-lxml-primitive-value (name type lxml namespace) +(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 (second lxml) (intern-xsd-type-name type)) t) (values nil nil)))) -(defun new-resolve-primitive (element type-name lxml namespace) +(defun resolve-primitive (element type-name lxml namespace) (multiple-value-bind (value present) - (new-lxml-primitive-value (get-name element) type-name lxml namespace) + (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 new-resolve-type (type-name lxml super-element xml-schema-definition namespace) +(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) @@ -385,14 +332,14 @@ (loop :for item-lxml :in (lxml-find-tags sub-tag-name (lxml-get-children lxml)) :do (if (xsd-primitive-type-name-p member-type) (multiple-value-bind (member-value required) - (new-resolve-primitive member member-type item-lxml namespace) + (resolve-primitive member member-type item-lxml namespace) (when required (incf count) (push member-name resolved-members) (push member-value resolved-members))) (multiple-value-bind (member-value required) - (new-resolve-type member-type item-lxml member - xml-schema-definition namespace) + (resolve-type member-type item-lxml member + xml-schema-definition namespace) (when required (incf count) (push member-name resolved-members) @@ -403,26 +350,26 @@ (let ((member-lxml (lxml-find-tag sub-tag-name lxml))) (if (xsd-primitive-type-name-p member-type) (multiple-value-bind (member-value required) - (new-resolve-primitive member member-type member-lxml namespace) + (resolve-primitive member member-type member-lxml namespace) (when required (push member-name resolved-members) (push member-value resolved-members))) (multiple-value-bind (member-value required) - (new-resolve-type member-type member-lxml member - xml-schema-definition namespace) + (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) - (new-lxml-primitive-value (get-name super-element) type lxml namespace) + (lxml-primitive-value (get-name super-element) type lxml namespace) (error "unexpected type"))))) -(defun new-resolve-element (element lxml xml-schema-definition namespace) +(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) - (new-resolve-primitive element element-type lxml namespace)) + (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) @@ -439,14 +386,14 @@ (if (eql (lxml-get-tag item-lxml) sub-tag-name) (if (xsd-primitive-type-name-p member-type) (multiple-value-bind (member-value required) - (new-resolve-primitive member member-type item-lxml namespace) + (resolve-primitive member member-type item-lxml namespace) (when required (incf count) (push member-name resolved-members) (push member-value resolved-members))) (multiple-value-bind (member-value required) - (new-resolve-type member-type item-lxml member - xml-schema-definition namespace) + (resolve-type member-type item-lxml member + xml-schema-definition namespace) (when required (incf count) (push member-name resolved-members) @@ -458,13 +405,13 @@ (let ((member-lxml (lxml-find-tag sub-tag-name sub-lxml))) (if (xsd-primitive-type-name-p member-type) (multiple-value-bind (member-value required) - (new-resolve-primitive member member-type member-lxml namespace) + (resolve-primitive member member-type member-lxml namespace) (when required (push member-name resolved-members) (push member-value resolved-members))) (multiple-value-bind (member-value required) - (new-resolve-type member-type member-lxml member - xml-schema-definition namespace) + (resolve-type member-type member-lxml member + xml-schema-definition namespace) (when required (push member-name resolved-members) (push member-value resolved-members))))))))

1 0

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

26 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv12562/src Modified Files: xsd.lisp Log Message: fixed xsd primitive handling of false boolean Date: Mon Sep 26 10:43:57 2005 Author: scaekenberghe Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.11 cl-soap/src/xsd.lisp:1.12 --- cl-soap/src/xsd.lisp:1.11 Sun Sep 25 14:44:18 2005 +++ cl-soap/src/xsd.lisp Mon Sep 26 10:43:56 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.11 2005/09/25 12:44:18 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.12 2005/09/26 08:43:56 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -357,12 +357,14 @@ (defun new-lxml-primitive-value (name type lxml namespace) (let ((tag-name (intern name (s-xml:get-package namespace)))) - (when (eql (lxml-get-tag lxml) tag-name) - (xsd-primitive->lisp (second lxml) (intern-xsd-type-name type))))) + (if (eql (lxml-get-tag lxml) tag-name) + (values (xsd-primitive->lisp (second lxml) (intern-xsd-type-name type)) t) + (values nil nil)))) (defun new-resolve-primitive (element type-name lxml namespace) - (let ((value (new-lxml-primitive-value (get-name element) type-name lxml namespace))) - (if value + (multiple-value-bind (value present) + (new-lxml-primitive-value (get-name element) type-name lxml namespace) + (if present (values value t) (if (is-optional-p element) (values nil nil) @@ -413,8 +415,7 @@ (push member-value resolved-members)))))))) (values (nreverse resolved-members) t)) (if (xsd-primitive-type-name-p type) - (let ((value (new-lxml-primitive-value (get-name super-element) type lxml namespace))) - (if value (values value t) (values nil nil))) + (new-lxml-primitive-value (get-name super-element) type lxml namespace) (error "unexpected type"))))) (defun new-resolve-element (element lxml xml-schema-definition namespace)

1 0

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

25 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv26172/src Modified Files: lxml.lisp xsd.lisp Log Message: added 'plural' member handling to new-resolve-type added nillable element attribute to use as optional indication in sequences Date: Sun Sep 25 14:44:18 2005 Author: scaekenberghe Index: cl-soap/src/lxml.lisp diff -u cl-soap/src/lxml.lisp:1.6 cl-soap/src/lxml.lisp:1.7 --- cl-soap/src/lxml.lisp:1.6 Wed Sep 21 19:08:03 2005 +++ cl-soap/src/lxml.lisp Sun Sep 25 14:44:18 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: lxml.lisp,v 1.6 2005/09/21 17:08:03 scaekenberghe Exp $ +;;;; $Id: lxml.lisp,v 1.7 2005/09/25 12:44:18 scaekenberghe Exp $ ;;;; ;;;; Some tools to manipulate lxml ;;;; @@ -38,6 +38,10 @@ (defun lxml-find-tag (tag lxml) "Find a specific tag in a lxml XML DOM list" (find tag lxml :key #'lxml-get-tag)) + +(defun lxml-find-tags (tag lxml) + "Find all elements of a specific tag in a lxml XML DOM list" + (remove-if-not #'(lambda (x) (eql (lxml-get-tag x) tag)) lxml)) ;;; internal Index: cl-soap/src/xsd.lisp diff -u cl-soap/src/xsd.lisp:1.10 cl-soap/src/xsd.lisp:1.11 --- cl-soap/src/xsd.lisp:1.10 Fri Sep 23 23:33:05 2005 +++ cl-soap/src/xsd.lisp Sun Sep 25 14:44:18 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.10 2005/09/23 21:33:05 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.11 2005/09/25 12:44:18 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -26,7 +26,8 @@ ((name :accessor get-name :initarg :name :initform nil) (type :accessor get-type :initarg :type :initform nil) (min-occurs :accessor get-min-occurs :initarg :min-occurs :initform 1) - (max-occurs :accessor get-max-occurs :initarg :max-occurs :initform 1))) + (max-occurs :accessor get-max-occurs :initarg :max-occurs :initform 1) + (nillable :accessor get-nillable :initarg :nillable :initform nil))) (defmethod print-object ((object xml-schema-element) out) (print-unreadable-object (object out :type t :identity t) @@ -74,6 +75,7 @@ (type (getf attributes :|type|)) (min-occurs (getf attributes :|minOccurs|)) (max-occurs (getf attributes :|maxOccurs|)) + (nillable (getf attributes :|nillable|)) (xml-schema-element (make-instance 'xml-schema-element :name name :type type @@ -82,7 +84,8 @@ (if (equal max-occurs "unbounded") :unbounded (parse-integer max-occurs)) - 1)))) + 1) + :nillable (equal nillable "true")))) (loop :for child :in (lxml-get-children lxml) :do (push (lxml->schema-element child) (get-children xml-schema-element))) @@ -374,20 +377,40 @@ (loop :for member :in members :do (let* ((member-name (get-name member)) (member-type (get-type member)) - (sub-tag-name (intern member-name (s-xml:get-package namespace))) - (member-lxml (lxml-find-tag sub-tag-name lxml))) - (if (xsd-primitive-type-name-p member-type) - (multiple-value-bind (member-value required) - (new-resolve-primitive member member-type member-lxml namespace) - (when required - (push member-name resolved-members) - (push member-value resolved-members))) - (multiple-value-bind (member-value required) - (new-resolve-type member-type member-lxml member - xml-schema-definition namespace) - (when required - (push member-name resolved-members) - (push member-value resolved-members)))))) + (sub-tag-name (intern member-name (s-xml:get-package namespace)))) + (if (is-plural-p member) + (let ((count 0)) + (loop :for item-lxml :in (lxml-find-tags sub-tag-name (lxml-get-children lxml)) :do + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (new-resolve-primitive member member-type item-lxml namespace) + (when required + (incf count) + (push member-name resolved-members) + (push member-value resolved-members))) + (multiple-value-bind (member-value required) + (new-resolve-type member-type item-lxml member + xml-schema-definition namespace) + (when required + (incf count) + (push member-name resolved-members) + (push member-value resolved-members))))) + (if (zerop count) + (unless (or (is-optional-p member) (get-nillable member)) + (error "Required element <~a> not found" member-name)))) + (let ((member-lxml (lxml-find-tag sub-tag-name lxml))) + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (new-resolve-primitive member member-type member-lxml namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members))) + (multiple-value-bind (member-value required) + (new-resolve-type member-type member-lxml member + xml-schema-definition namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members)))))))) (values (nreverse resolved-members) t)) (if (xsd-primitive-type-name-p type) (let ((value (new-lxml-primitive-value (get-name super-element) type lxml namespace))) @@ -407,32 +430,31 @@ (resolved-members '())) (loop :for member :in members :do (let* ((member-name (get-name member)) - (member-type (get-type member))) + (member-type (get-type member)) + (sub-tag-name (intern member-name (s-xml:get-package namespace)))) (if (is-plural-p member) (let ((count 0)) (loop :for item-lxml :in sub-lxml :do - (let ((sub-tag-name (intern member-name (s-xml:get-package namespace)))) - (if (eql (lxml-get-tag item-lxml) sub-tag-name) - (if (xsd-primitive-type-name-p member-type) - (multiple-value-bind (member-value required) - (new-resolve-primitive member member-type item-lxml namespace) - (when required - (incf count) - (push member-name resolved-members) - (push member-value resolved-members))) + (if (eql (lxml-get-tag item-lxml) sub-tag-name) + (if (xsd-primitive-type-name-p member-type) (multiple-value-bind (member-value required) - (new-resolve-type member-type item-lxml member - xml-schema-definition namespace) + (new-resolve-primitive member member-type item-lxml namespace) (when required (incf count) (push member-name resolved-members) - (push member-value resolved-members)))) - (error "Expected a <~a> element" sub-tag-name)))) + (push member-value resolved-members))) + (multiple-value-bind (member-value required) + (new-resolve-type member-type item-lxml member + xml-schema-definition namespace) + (when required + (incf count) + (push member-name resolved-members) + (push member-value resolved-members)))) + (error "Expected a <~a> element" sub-tag-name))) (if (zerop count) - (unless (is-optional-p member) + (unless (or (is-optional-p member) (get-nillable member)) (error "Required element <~a> not found" member-name)))) - (let* ((sub-tag-name (intern member-name (s-xml:get-package namespace))) - (member-lxml (lxml-find-tag sub-tag-name sub-lxml))) + (let ((member-lxml (lxml-find-tag sub-tag-name sub-lxml))) (if (xsd-primitive-type-name-p member-type) (multiple-value-bind (member-value required) (new-resolve-primitive member member-type member-lxml namespace) @@ -508,10 +530,11 @@ (member-type (get-type member))) (indent level stream) (if (xsd-primitive-type-name-p member-type) - (format stream " Member ~s of primitive type ~s [~a]~%" - member-name member-type (describe-multiplicity member)) + (format stream " Member ~s of primitive type ~s [~a]~@[ nillable~]~%" + member-name member-type (describe-multiplicity member) (get-nillable member)) (progn - (format stream " Member ~s [~a]~%" member-name (describe-multiplicity member)) + (format stream " Member ~s [~a]~@[ nillable~]~%" member-name + (describe-multiplicity member) (get-nillable member)) (describe-xsd-type xml-schema-definition member-type :level (1+ level) :stream stream)))))) (if (xsd-primitive-type-name-p type) @@ -528,23 +551,25 @@ (if (xsd-primitive-type-name-p element-type) (progn (indent level stream) - (format stream "Element ~s of primitive type ~s [~a]~%" - element-name element-type (describe-multiplicity element)) + (format stream "Element ~s of primitive type ~s [~a]~@[ nillable~]~%" + element-name element-type (describe-multiplicity element) (get-nillable element)) (indent level stream) (format stream " <~a>~a</~a>~a~%" element-name element-type element-name (multiplicity-suffix element))) (let ((members (get-members element-type))) (indent level stream) - (format stream "Element ~s [~a]~%" element-name (describe-multiplicity element)) + (format stream "Element ~s [~a]~@[ nillable~]~%" element-name + (describe-multiplicity element) (get-nillable element)) (loop :for member :in members :do (let ((member-name (get-name member)) (member-type (get-type member))) (indent level stream) (if (xsd-primitive-type-name-p member-type) - (format stream " Member ~s of primitive type ~s [~a]~%" - member-name member-type (describe-multiplicity member)) + (format stream " Member ~s of primitive type ~s[ ~a]~@[ nillable~]~%" + member-name member-type (describe-multiplicity member) (get-nillable member)) (progn - (format stream " Member ~s [~a]~%" member-name (describe-multiplicity member)) + (format stream " Member ~s [~a]~@[ nillable~]~%" member-name + (describe-multiplicity member) (get-nillable member)) (describe-xsd-type xml-schema-definition member-type :level (1+ level) :stream stream))))) (indent level stream)

1 0

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

23 Sep '05

Update of /project/cl-soap/cvsroot/cl-soap/src In directory common-lisp.net:/tmp/cvs-serv26091/src Modified Files: wsdl.lisp xsd.lisp Log Message: added new, better structured new-bind-element & new-resolve-element functions to xsd to bind wsdl-soap-call document-style input/output binding Date: Fri Sep 23 23:33:05 2005 Author: scaekenberghe Index: cl-soap/src/wsdl.lisp diff -u cl-soap/src/wsdl.lisp:1.14 cl-soap/src/wsdl.lisp:1.15 --- cl-soap/src/wsdl.lisp:1.14 Fri Sep 23 10:39:13 2005 +++ cl-soap/src/wsdl.lisp Fri Sep 23 23:33:05 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: wsdl.lisp,v 1.14 2005/09/23 08:39:13 scaekenberghe Exp $ +;;;; $Id: wsdl.lisp,v 1.15 2005/09/23 21:33:05 scaekenberghe Exp $ ;;;; ;;;; The basic WSDL protocol: we parse the generic and soap specific parts ;;;; @@ -413,10 +413,10 @@ (unless (is-optional-p part-element) (error "No input binding found for ~a:~a" (get-name input-message) (get-name part)))))) (part-element - (push (bind-element part-element - input - (get-xml-schema-definition wsdl-document-definitions) - namespace) + (push (new-bind-element part-element + input + (get-xml-schema-definition wsdl-document-definitions) + namespace) actual-input-parameters)) (t (error "Cannot resolve input binding ~a:~a" (get-name input-message) (get-name part)))))) (nreverse actual-input-parameters))) @@ -453,11 +453,13 @@ (push (xsd-primitive->lisp part-value (intern-xsd-type-name part-type)) result-values))) (part-element - (push (resolve-element part-element - result - (get-xml-schema-definition wsdl-document-definitions) - namespace) - result-values)) + (multiple-value-bind (value required) + (new-resolve-element part-element + result + (get-xml-schema-definition wsdl-document-definitions) + namespace) + (when required + (push 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.9 cl-soap/src/xsd.lisp:1.10 --- cl-soap/src/xsd.lisp:1.9 Fri Sep 23 10:41:51 2005 +++ cl-soap/src/xsd.lisp Fri Sep 23 23:33:05 2005 @@ -1,6 +1,6 @@ ;;;; -*- mode: lisp -*- ;;;; -;;;; $Id: xsd.lisp,v 1.9 2005/09/23 08:41:51 scaekenberghe Exp $ +;;;; $Id: xsd.lisp,v 1.10 2005/09/23 21:33:05 scaekenberghe Exp $ ;;;; ;;;; A partial implementation of the XML Schema Definition standard ;;;; @@ -204,7 +204,7 @@ ;;; Binding and Resolving elements to and from actual data (defun get-name-binding (name bindings) - (second (member name bindings :test #'equal))) + (second (member (actual-name name) bindings :test #'equal))) (defun bind-element (element bindings xml-schema-definition namespace) (let* ((element (if (stringp element) (get-element-named xml-schema-definition element) element)) @@ -230,6 +230,99 @@ ,@(nreverse member-actual-bindings)))) (t (error "Cannot bind element ~s of type ~s" element element-type))))) +(defun new-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 new-bind-primitive (element type-name bindings namespace) + (let ((value (new-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 new-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 (new-bind-primitive member member-type sub-bindings namespace))) + (when member-binding + (push member-binding members-actual-bindings))) + (multiple-value-bind (member-binding bound) + (new-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 (new-binding-primitive-value (get-name super-element) type bindings))) + (if value (values value t) (values nil nil))) + (error "unexpected type"))))) + +(defun new-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) + (new-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 (new-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) + (new-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 (new-bind-primitive member member-type + bindings namespace))) + (when member-binding + (push member-binding members-actual-bindings))) + (multiple-value-bind (member-binding bound) + (new-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 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))) @@ -254,10 +347,109 @@ (push (get-name element) resolved-members) (push value resolved-members))))) (values (nreverse resolved-members) t)) - (if (zerop (get-min-occurs element)) + (if (is-optional-p element) (values nil nil) (error "Expected a <~a> element" tag-name))))) (t (error "Cannot bind element ~s of type ~s" element element-type))))) + +(defun new-lxml-primitive-value (name type lxml namespace) + (let ((tag-name (intern name (s-xml:get-package namespace)))) + (when (eql (lxml-get-tag lxml) tag-name) + (xsd-primitive->lisp (second lxml) (intern-xsd-type-name type))))) + +(defun new-resolve-primitive (element type-name lxml namespace) + (let ((value (new-lxml-primitive-value (get-name element) type-name lxml namespace))) + (if value + (values value t) + (if (is-optional-p element) + (values nil nil) + (error "Expected a <~a> element" (get-name element)))))) + +(defun new-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))) + (member-lxml (lxml-find-tag sub-tag-name lxml))) + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (new-resolve-primitive member member-type member-lxml namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members))) + (multiple-value-bind (member-value required) + (new-resolve-type member-type member-lxml member + xml-schema-definition namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members)))))) + (values (nreverse resolved-members) t)) + (if (xsd-primitive-type-name-p type) + (let ((value (new-lxml-primitive-value (get-name super-element) type lxml namespace))) + (if value (values value t) (values nil nil))) + (error "unexpected type"))))) + +(defun new-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) + (new-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))) + (if (is-plural-p member) + (let ((count 0)) + (loop :for item-lxml :in sub-lxml :do + (let ((sub-tag-name (intern member-name (s-xml:get-package namespace)))) + (if (eql (lxml-get-tag item-lxml) sub-tag-name) + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (new-resolve-primitive member member-type item-lxml namespace) + (when required + (incf count) + (push member-name resolved-members) + (push member-value resolved-members))) + (multiple-value-bind (member-value required) + (new-resolve-type member-type item-lxml member + xml-schema-definition namespace) + (when required + (incf count) + (push member-name resolved-members) + (push member-value resolved-members)))) + (error "Expected a <~a> element" sub-tag-name)))) + (if (zerop count) + (unless (is-optional-p member) + (error "Required element <~a> not found" member-name)))) + (let* ((sub-tag-name (intern member-name (s-xml:get-package namespace))) + (member-lxml (lxml-find-tag sub-tag-name sub-lxml))) + (if (xsd-primitive-type-name-p member-type) + (multiple-value-bind (member-value required) + (new-resolve-primitive member member-type member-lxml namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members))) + (multiple-value-bind (member-value required) + (new-resolve-type member-type member-lxml member + xml-schema-definition namespace) + (when required + (push member-name resolved-members) + (push member-value resolved-members)))))))) + (values (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)

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

cl-soap-cvs September 2005