[cl-soap-cvs] CVS update: cl-soap/src/wsdl.lisp cl-soap/src/xsd.lisp
Sven Van Caekenberghe
scaekenberghe at common-lisp.net
Mon Sep 26 10:41:52 UTC 2005
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))
, at 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))))))))
More information about the Cl-soap-cvs
mailing list