aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorThomas Fitzsimmons2015-10-24 08:33:18 -0400
committerThomas Fitzsimmons2015-10-24 08:34:46 -0400
commit069a0e41f40822f3233333eee33ef6f15a640f0b (patch)
treea8d46b3a40a4d5d93d67ffc15567479bb5514ef0
parentab10d8825427714a2a7acd36adcc5b0b066ed6ca (diff)
downloademacs-069a0e41f40822f3233333eee33ef6f15a640f0b.tar.gz
emacs-069a0e41f40822f3233333eee33ef6f15a640f0b.zip
Sync with soap-client repository, version 3.0.0
Diffstat
-rw-r--r--lisp/net/soap-client.el3183
-rw-r--r--lisp/net/soap-inspect.el419
2 files changed, 2526 insertions, 1076 deletions
diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el
index 509c021c644..008bbf4e534 100644
--- a/lisp/net/soap-client.el
+++ b/lisp/net/soap-client.el
@@ -1,9 +1,11 @@
1;;;; soap-client.el -- Access SOAP web services from Emacs 1;;;; soap-client.el -- Access SOAP web services -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 2009-2015 Free Software Foundation, Inc. 3;; Copyright (C) 2009-2015 Free Software Foundation, Inc.
4 4
5;; Author: Alexandru Harsanyi <AlexHarsanyi@gmail.com> 5;; Author: Alexandru Harsanyi <AlexHarsanyi@gmail.com>
6;; Author: Thomas Fitzsimmons <fitzsim@fitzsim.org>
6;; Created: December, 2009 7;; Created: December, 2009
8;; Version: 3.0.0
7;; Keywords: soap, web-services, comm, hypermedia 9;; Keywords: soap, web-services, comm, hypermedia
8;; Package: soap-client 10;; Package: soap-client
9;; Homepage: http://code.google.com/p/emacs-soap-client 11;; Homepage: http://code.google.com/p/emacs-soap-client
@@ -43,10 +45,14 @@
43(eval-when-compile (require 'cl)) 45(eval-when-compile (require 'cl))
44 46
45(require 'xml) 47(require 'xml)
48(require 'xsd-regexp)
49(require 'rng-xsd)
50(require 'rng-dt)
46(require 'warnings) 51(require 'warnings)
47(require 'url) 52(require 'url)
48(require 'url-http) 53(require 'url-http)
49(require 'url-util) 54(require 'url-util)
55(require 'url-vars)
50(require 'mm-decode) 56(require 'mm-decode)
51 57
52(defsubst soap-warning (message &rest args) 58(defsubst soap-warning (message &rest args)
@@ -74,13 +80,17 @@
74 ("wsdlsoap" . "http://schemas.xmlsoap.org/wsdl/soap/") 80 ("wsdlsoap" . "http://schemas.xmlsoap.org/wsdl/soap/")
75 ("xsd" . "http://www.w3.org/2001/XMLSchema") 81 ("xsd" . "http://www.w3.org/2001/XMLSchema")
76 ("xsi" . "http://www.w3.org/2001/XMLSchema-instance") 82 ("xsi" . "http://www.w3.org/2001/XMLSchema-instance")
83 ("wsa" . "http://www.w3.org/2005/08/addressing")
84 ("wsaw" . "http://www.w3.org/2006/05/addressing/wsdl")
77 ("soap" . "http://schemas.xmlsoap.org/soap/envelope/") 85 ("soap" . "http://schemas.xmlsoap.org/soap/envelope/")
78 ("soap12" . "http://schemas.xmlsoap.org/wsdl/soap12/") 86 ("soap12" . "http://schemas.xmlsoap.org/wsdl/soap12/")
79 ("http" . "http://schemas.xmlsoap.org/wsdl/http/") 87 ("http" . "http://schemas.xmlsoap.org/wsdl/http/")
80 ("mime" . "http://schemas.xmlsoap.org/wsdl/mime/")) 88 ("mime" . "http://schemas.xmlsoap.org/wsdl/mime/")
89 ("xml" . "http://www.w3.org/XML/1998/namespace"))
81 "A list of well known xml namespaces and their aliases.") 90 "A list of well known xml namespaces and their aliases.")
82 91
83(defvar soap-local-xmlns nil 92(defvar soap-local-xmlns
93 '(("xml" . "http://www.w3.org/XML/1998/namespace"))
84 "A list of local namespace aliases. 94 "A list of local namespace aliases.
85This is a dynamically bound variable, controlled by 95This is a dynamically bound variable, controlled by
86`soap-with-local-xmlns'.") 96`soap-with-local-xmlns'.")
@@ -98,6 +108,10 @@ are fully qualified for a different namespace. This is a
98dynamically bound variable, controlled by 108dynamically bound variable, controlled by
99`soap-with-local-xmlns'") 109`soap-with-local-xmlns'")
100 110
111(defvar soap-current-wsdl nil
112 "The current WSDL document used when decoding the SOAP response.
113This is a dynamically bound variable.")
114
101(defun soap-wk2l (well-known-name) 115(defun soap-wk2l (well-known-name)
102 "Return local variant of WELL-KNOWN-NAME. 116 "Return local variant of WELL-KNOWN-NAME.
103This is done by looking up the namespace in the 117This is done by looking up the namespace in the
@@ -106,24 +120,24 @@ the local name based on the current local translation table
106`soap-local-xmlns'. See also `soap-with-local-xmlns'." 120`soap-local-xmlns'. See also `soap-with-local-xmlns'."
107 (let ((wk-name-1 (if (symbolp well-known-name) 121 (let ((wk-name-1 (if (symbolp well-known-name)
108 (symbol-name well-known-name) 122 (symbol-name well-known-name)
109 well-known-name))) 123 well-known-name)))
110 (cond 124 (cond
111 ((string-match "^\\(.*\\):\\(.*\\)$" wk-name-1) 125 ((string-match "^\\(.*\\):\\(.*\\)$" wk-name-1)
112 (let ((ns (match-string 1 wk-name-1)) 126 (let ((ns (match-string 1 wk-name-1))
113 (name (match-string 2 wk-name-1))) 127 (name (match-string 2 wk-name-1)))
114 (let ((namespace (cdr (assoc ns soap-well-known-xmlns)))) 128 (let ((namespace (cdr (assoc ns soap-well-known-xmlns))))
115 (cond ((equal namespace soap-default-xmlns) 129 (cond ((equal namespace soap-default-xmlns)
116 ;; Name is unqualified in the default namespace 130 ;; Name is unqualified in the default namespace
117 (if (symbolp well-known-name) 131 (if (symbolp well-known-name)
118 (intern name) 132 (intern name)
119 name)) 133 name))
120 (t 134 (t
121 (let* ((local-ns (car (rassoc namespace soap-local-xmlns))) 135 (let* ((local-ns (car (rassoc namespace soap-local-xmlns)))
122 (local-name (concat local-ns ":" name))) 136 (local-name (concat local-ns ":" name)))
123 (if (symbolp well-known-name) 137 (if (symbolp well-known-name)
124 (intern local-name) 138 (intern local-name)
125 local-name))))))) 139 local-name)))))))
126 (t well-known-name)))) 140 (t well-known-name))))
127 141
128(defun soap-l2wk (local-name) 142(defun soap-l2wk (local-name)
129 "Convert LOCAL-NAME into a well known name. 143 "Convert LOCAL-NAME into a well known name.
@@ -134,40 +148,37 @@ used in the name.
134nil is returned if there is no well-known namespace for the 148nil is returned if there is no well-known namespace for the
135namespace of LOCAL-NAME." 149namespace of LOCAL-NAME."
136 (let ((l-name-1 (if (symbolp local-name) 150 (let ((l-name-1 (if (symbolp local-name)
137 (symbol-name local-name) 151 (symbol-name local-name)
138 local-name)) 152 local-name))
139 namespace name) 153 namespace name)
140 (cond 154 (cond
141 ((string-match "^\\(.*\\):\\(.*\\)$" l-name-1) 155 ((string-match "^\\(.*\\):\\(.*\\)$" l-name-1)
142 (setq name (match-string 2 l-name-1)) 156 (setq name (match-string 2 l-name-1))
143 (let ((ns (match-string 1 l-name-1))) 157 (let ((ns (match-string 1 l-name-1)))
144 (setq namespace (cdr (assoc ns soap-local-xmlns))) 158 (setq namespace (cdr (assoc ns soap-local-xmlns)))
145 (unless namespace 159 (unless namespace
146 (error "Soap-l2wk(%s): no namespace for alias %s" local-name ns)))) 160 (error "Soap-l2wk(%s): no namespace for alias %s" local-name ns))))
147 (t 161 (t
148 (setq name l-name-1) 162 (setq name l-name-1)
149 (setq namespace soap-default-xmlns))) 163 (setq namespace soap-default-xmlns)))
150 164
151 (if namespace 165 (if namespace
152 (let ((well-known-ns (car (rassoc namespace soap-well-known-xmlns)))) 166 (let ((well-known-ns (car (rassoc namespace soap-well-known-xmlns))))
153 (if well-known-ns 167 (if well-known-ns
154 (let ((well-known-name (concat well-known-ns ":" name))) 168 (let ((well-known-name (concat well-known-ns ":" name)))
155 (if (symbol-name local-name) 169 (if (symbolp local-name)
156 (intern well-known-name) 170 (intern well-known-name)
157 well-known-name)) 171 well-known-name))
158 (progn 172 nil))
159 ;; (soap-warning "soap-l2wk(%s): namespace %s has no well-known tag" 173 ;; if no namespace is defined, just return the unqualified name
160 ;; local-name namespace) 174 name)))
161 nil)))
162 ;; if no namespace is defined, just return the unqualified name
163 name)))
164 175
165 176
166(defun soap-l2fq (local-name &optional use-tns) 177(defun soap-l2fq (local-name &optional use-tns)
167 "Convert LOCAL-NAME into a fully qualified name. 178 "Convert LOCAL-NAME into a fully qualified name.
168A fully qualified name is a cons of the namespace name and the 179A fully qualified name is a cons of the namespace name and the
169name of the element itself. For example \"xsd:string\" is 180name of the element itself. For example \"xsd:string\" is
170converted to \(\"http://www.w3.org/2001/XMLSchema\" . \"string\"). 181converted to (\"http://www.w3.org/2001/XMLSchema\" . \"string\").
171 182
172The USE-TNS argument specifies what to do when LOCAL-NAME has no 183The USE-TNS argument specifies what to do when LOCAL-NAME has no
173namespace tag. If USE-TNS is non-nil, the `soap-target-xmlns' 184namespace tag. If USE-TNS is non-nil, the `soap-target-xmlns'
@@ -178,19 +189,27 @@ This is needed because different parts of a WSDL document can use
178different namespace aliases for the same element." 189different namespace aliases for the same element."
179 (let ((local-name-1 (if (symbolp local-name) 190 (let ((local-name-1 (if (symbolp local-name)
180 (symbol-name local-name) 191 (symbol-name local-name)
181 local-name))) 192 local-name)))
182 (cond ((string-match "^\\(.*\\):\\(.*\\)$" local-name-1) 193 (cond ((string-match "^\\(.*\\):\\(.*\\)$" local-name-1)
183 (let ((ns (match-string 1 local-name-1)) 194 (let ((ns (match-string 1 local-name-1))
184 (name (match-string 2 local-name-1))) 195 (name (match-string 2 local-name-1)))
185 (let ((namespace (cdr (assoc ns soap-local-xmlns)))) 196 (let ((namespace (cdr (assoc ns soap-local-xmlns))))
186 (if namespace 197 (if namespace
187 (cons namespace name) 198 (cons namespace name)
188 (error "Soap-l2fq(%s): unknown alias %s" local-name ns))))) 199 (error "Soap-l2fq(%s): unknown alias %s" local-name ns)))))
189 (t 200 (t
190 (cons (if use-tns 201 (cons (if use-tns
191 soap-target-xmlns 202 soap-target-xmlns
192 soap-default-xmlns) 203 soap-default-xmlns)
193 local-name))))) 204 local-name-1)))))
205
206(defun soap-name-p (name)
207 "Return true if NAME is a valid name for XMLSchema types.
208A valid name is either a string or a cons of (NAMESPACE . NAME)."
209 (or (stringp name)
210 (and (consp name)
211 (stringp (car name))
212 (stringp (cdr name)))))
194 213
195(defun soap-extract-xmlns (node &optional xmlns-table) 214(defun soap-extract-xmlns (node &optional xmlns-table)
196 "Return a namespace alias table for NODE by extending XMLNS-TABLE." 215 "Return a namespace alias table for NODE by extending XMLNS-TABLE."
@@ -211,16 +230,10 @@ different namespace aliases for the same element."
211 ;; the target namespace. 230 ;; the target namespace.
212 (unless (equal target-ns (cdr tns)) 231 (unless (equal target-ns (cdr tns))
213 (soap-warning 232 (soap-warning
214 "soap-extract-xmlns(%s): tns alias and targetNamespace mismatch" 233 "soap-extract-xmlns(%s): tns alias and targetNamespace mismatch"
215 (xml-node-name node)))) 234 (xml-node-name node))))
216 ((and tns (not target-ns)) 235 ((and tns (not target-ns))
217 (setq target-ns (cdr tns))) 236 (setq target-ns (cdr tns)))))
218 ((and (not tns) target-ns)
219 ;; a tns alias was not defined in this node. See if the node has
220 ;; a "targetNamespace" attribute and add an alias to this. Note
221 ;; that we might override an existing tns alias in XMLNS-TABLE,
222 ;; but that is intended.
223 (push (cons "tns" target-ns) xmlns))))
224 237
225 (list default-ns target-ns (append xmlns xmlns-table)))) 238 (list default-ns target-ns (append xmlns xmlns-table))))
226 239
@@ -250,13 +263,21 @@ namespace tag."
250 (when (and (consp c) 263 (when (and (consp c)
251 (soap-with-local-xmlns c 264 (soap-with-local-xmlns c
252 ;; We use `ignore-errors' here because we want to silently 265 ;; We use `ignore-errors' here because we want to silently
253 ;; skip nodes for which we cannot convert them to a 266 ;; skip nodes when we cannot convert them to a well-known
254 ;; well-known name. 267 ;; name.
255 (eq (ignore-errors (soap-l2wk (xml-node-name c))) 268 (eq (ignore-errors (soap-l2wk (xml-node-name c)))
256 child-name))) 269 child-name)))
257 (push c result))) 270 (push c result)))
258 (nreverse result))) 271 (nreverse result)))
259 272
273(defun soap-xml-node-find-matching-child (node set)
274 "Return the first child of NODE whose name is a member of SET."
275 (catch 'found
276 (dolist (child (xml-node-children node))
277 (when (and (consp child)
278 (memq (soap-l2wk (xml-node-name child)) set))
279 (throw 'found child)))))
280
260(defun soap-xml-get-attribute-or-nil1 (node attribute) 281(defun soap-xml-get-attribute-or-nil1 (node attribute)
261 "Return the NODE's ATTRIBUTE, or nil if it does not exist. 282 "Return the NODE's ATTRIBUTE, or nil if it does not exist.
262This is the same as `xml-get-attribute-or-nil', but ATTRIBUTE can 283This is the same as `xml-get-attribute-or-nil', but ATTRIBUTE can
@@ -287,8 +308,13 @@ be tagged with a namespace tag."
287 "Return a fully qualified name for ELEMENT. 308 "Return a fully qualified name for ELEMENT.
288A fq name is the concatenation of the namespace tag and the 309A fq name is the concatenation of the namespace tag and the
289element name." 310element name."
290 (concat (soap-element-namespace-tag element) 311 (cond ((soap-element-namespace-tag element)
291 ":" (soap-element-name element))) 312 (concat (soap-element-namespace-tag element)
313 ":" (soap-element-name element)))
314 ((soap-element-name element)
315 (soap-element-name element))
316 (t
317 "*unnamed*")))
292 318
293;; a namespace link stores an alias for an object in once namespace to a 319;; a namespace link stores an alias for an object in once namespace to a
294;; "target" object possibly in a different namespace 320;; "target" object possibly in a different namespace
@@ -311,11 +337,8 @@ discriminant predicate to `soap-namespace-get'"
311 (let ((name (soap-element-name element))) 337 (let ((name (soap-element-name element)))
312 (push element (gethash name (soap-namespace-elements ns))))) 338 (push element (gethash name (soap-namespace-elements ns)))))
313 339
314(defun soap-namespace-put-link (name target ns &optional replace) 340(defun soap-namespace-put-link (name target ns)
315 "Store a link from NAME to TARGET in NS. 341 "Store a link from NAME to TARGET in NS.
316An error will be signaled if an element by the same name is
317already present in NS, unless REPLACE is non nil.
318
319TARGET can be either a SOAP-ELEMENT or a string denoting an 342TARGET can be either a SOAP-ELEMENT or a string denoting an
320element name into another namespace. 343element name into another namespace.
321 344
@@ -357,34 +380,1563 @@ binding) but the same name."
357 ((= (length elements) 1) (car elements)) 380 ((= (length elements) 1) (car elements))
358 ((> (length elements) 1) 381 ((> (length elements) 1)
359 (error 382 (error
360 "Soap-namespace-get(%s): multiple elements, discriminant needed" 383 "Soap-namespace-get(%s): multiple elements, discriminant needed"
361 name)) 384 name))
362 (t 385 (t
363 nil)))) 386 nil))))
364 387
365 388
366;;;; WSDL documents 389;;;; XML Schema
367;;;;; WSDL document elements
368 390
369(defstruct (soap-basic-type (:include soap-element)) 391;; SOAP WSDL documents use XML Schema to define the types that are part of the
370 kind ; a symbol of: string, dateTime, long, int 392;; message exchange. We include here an XML schema model with a parser and
371 ) 393;; serializer/deserialiser.
372 394
373(defstruct (soap-simple-type (:include soap-basic-type)) 395(defstruct (soap-xs-type (:include soap-element))
374 enumeration) 396 id
397 attributes
398 attribute-groups)
375 399
376(defstruct soap-sequence-element 400;;;;; soap-xs-basic-type
377 name type nillable? multiple?)
378 401
379(defstruct (soap-sequence-type (:include soap-element)) 402(defstruct (soap-xs-basic-type (:include soap-xs-type))
380 parent ; OPTIONAL WSDL-TYPE name 403 ;; Basic types are "built in" and we know how to handle them directly.
381 elements ; LIST of SOAP-SEQUENCE-ELEMENT 404 ;; Other type definitions reference basic types, so we need to create them
405 ;; in a namespace (see `soap-make-xs-basic-types')
406
407 ;; a symbol of: string, dateTime, long, int, etc
408 kind
382 ) 409 )
383 410
384(defstruct (soap-array-type (:include soap-element)) 411(defun soap-make-xs-basic-types (namespace-name &optional namespace-tag)
385 element-type ; WSDL-TYPE of the array elements 412 "Construct NAMESPACE-NAME containing the XMLSchema basic types.
413An optional NAMESPACE-TAG can also be specified."
414 (let ((ns (make-soap-namespace :name namespace-name)))
415 (dolist (type '("string" "language" "ID" "IDREF"
416 "dateTime" "time" "date" "boolean"
417 "gYearMonth" "gYear" "gMonthDay" "gDay" "gMonth"
418 "long" "short" "int" "integer" "nonNegativeInteger"
419 "unsignedLong" "unsignedShort" "unsignedInt"
420 "decimal" "duration"
421 "byte" "unsignedByte"
422 "float" "double"
423 "base64Binary" "anyType" "anyURI" "QName" "Array" "byte[]"))
424 (soap-namespace-put
425 (make-soap-xs-basic-type :name type
426 :namespace-tag namespace-tag
427 :kind (intern type))
428 ns))
429 ns))
430
431(defun soap-encode-xs-basic-type-attributes (value type)
432 "Encode the XML attributes for VALUE according to TYPE.
433The xsi:type and an optional xsi:nil attributes are added. The
434attributes are inserted in the current buffer at the current
435position.
436
437This is a specialization of `soap-encode-attributes' for
438`soap-xs-basic-type' objects."
439 (let ((xsi-type (soap-element-fq-name type))
440 (basic-type (soap-xs-basic-type-kind type)))
441 ;; try to classify the type based on the value type and use that type when
442 ;; encoding
443 (when (eq basic-type 'anyType)
444 (cond ((stringp value)
445 (setq xsi-type "xsd:string" basic-type 'string))
446 ((integerp value)
447 (setq xsi-type "xsd:int" basic-type 'int))
448 ((memq value '(t nil))
449 (setq xsi-type "xsd:boolean" basic-type 'boolean))
450 (t
451 (error "Cannot classify anyType value"))))
452
453 (insert " xsi:type=\"" xsi-type "\"")
454 ;; We have some ambiguity here, as a nil value represents "false" when the
455 ;; type is boolean, we will never have a "nil" boolean type...
456 (unless (or value (eq basic-type 'boolean))
457 (insert " xsi:nil=\"true\""))))
458
459(defun soap-encode-xs-basic-type (value type)
460 "Encode the VALUE according to TYPE.
461The data is inserted in the current buffer at the current
462position.
463
464This is a specialization of `soap-encode-value' for
465`soap-xs-basic-type' objects."
466 (let ((kind (soap-xs-basic-type-kind type)))
467
468 (when (eq kind 'anyType)
469 (cond ((stringp value)
470 (setq kind 'string))
471 ((integerp value)
472 (setq kind 'int))
473 ((memq value '(t nil))
474 (setq kind 'boolean))
475 (t
476 (error "Cannot classify anyType value"))))
477
478 ;; NOTE: a nil value is not encoded, as an xsi:nil="true" attribute was
479 ;; encoded for it. However, we have some ambiguity here, as a nil value
480 ;; also represents "false" when the type is boolean...
481
482 (when (or value (eq kind 'boolean))
483 (let ((value-string
484 (case kind
485 ((string anyURI QName ID IDREF language)
486 (unless (stringp value)
487 (error "Not a string value: %s" value))
488 (url-insert-entities-in-string value))
489 ((dateTime time date gYearMonth gYear gMonthDay gDay gMonth)
490 (cond ((consp value)
491 ;; Value is a (current-time) style value,
492 ;; convert to the ISO 8601-inspired XSD
493 ;; string format in UTC.
494 (format-time-string
495 (concat
496 (ecase kind
497 (dateTime "%Y-%m-%dT%H:%M:%S")
498 (time "%H:%M:%S")
499 (date "%Y-%m-%d")
500 (gYearMonth "%Y-%m")
501 (gYear "%Y")
502 (gMonthDay "--%m-%d")
503 (gDay "---%d")
504 (gMonth "--%m"))
505 ;; Internal time is always in UTC.
506 "Z")
507 value t))
508 ((stringp value)
509 ;; Value is a string in the ISO 8601-inspired XSD
510 ;; format. Validate it.
511 (soap-decode-date-time value kind)
512 (url-insert-entities-in-string value))
513 (t
514 (error "Invalid date-time format"))))
515 (boolean
516 (unless (memq value '(t nil))
517 (error "Not a boolean value"))
518 (if value "true" "false"))
519
520 ((long short int integer byte unsignedInt unsignedLong
521 unsignedShort nonNegativeInteger decimal duration)
522 (unless (integerp value)
523 (error "Not an integer value"))
524 (when (and (memq kind '(unsignedInt unsignedLong
525 unsignedShort
526 nonNegativeInteger))
527 (< value 0))
528 (error "Not a positive integer"))
529 (number-to-string value))
530
531 ((float double)
532 (unless (numberp value)
533 (error "Not a number"))
534 (number-to-string value))
535
536 (base64Binary
537 (unless (stringp value)
538 (error "Not a string value for base64Binary"))
539 (base64-encode-string value))
540
541 (otherwise
542 (error "Don't know how to encode %s for type %s"
543 value (soap-element-fq-name type))))))
544 (soap-validate-xs-basic-type value-string type)
545 (insert value-string)))))
546
547;; Inspired by rng-xsd-convert-date-time.
548(defun soap-decode-date-time (date-time-string datatype)
549 "Decode DATE-TIME-STRING as DATATYPE.
550DATE-TIME-STRING should be in ISO 8601 basic or extended format.
551DATATYPE is one of dateTime, time, date, gYearMonth, gYear,
552gMonthDay, gDay or gMonth.
553
554Return a list in a format (SEC MINUTE HOUR DAY MONTH YEAR
555SEC-FRACTION DATATYPE ZONE). This format is meant to be similar
556to that returned by `decode-time' (and compatible with
557`encode-time'). The differences are the DOW (day-of-week) field
558is replaced with SEC-FRACTION, a float representing the
559fractional seconds, and the DST (daylight savings time) field is
560replaced with DATATYPE, a symbol representing the XSD primitive
561datatype. This symbol can be used to determine which fields
562apply and which don't when it's not already clear from context.
563For example a datatype of 'time means the year, month and day
564fields should be ignored.
565
566This function will throw an error if DATE-TIME-STRING represents
567a leap second, since the XML Schema 1.1 standard explicitly
568disallows them."
569 (let* ((datetime-regexp (cadr (get datatype 'rng-xsd-convert)))
570 (year-sign (progn
571 (string-match datetime-regexp date-time-string)
572 (match-string 1 date-time-string)))
573 (year (match-string 2 date-time-string))
574 (month (match-string 3 date-time-string))
575 (day (match-string 4 date-time-string))
576 (hour (match-string 5 date-time-string))
577 (minute (match-string 6 date-time-string))
578 (second (match-string 7 date-time-string))
579 (second-fraction (match-string 8 date-time-string))
580 (has-time-zone (match-string 9 date-time-string))
581 (time-zone-sign (match-string 10 date-time-string))
582 (time-zone-hour (match-string 11 date-time-string))
583 (time-zone-minute (match-string 12 date-time-string)))
584 (setq year-sign (if year-sign -1 1))
585 (setq year
586 (if year
587 (* year-sign
588 (string-to-number year))
589 ;; By defaulting to the epoch date, a time value can be treated as
590 ;; a relative number of seconds.
591 1970))
592 (setq month
593 (if month (string-to-number month) 1))
594 (setq day
595 (if day (string-to-number day) 1))
596 (setq hour
597 (if hour (string-to-number hour) 0))
598 (setq minute
599 (if minute (string-to-number minute) 0))
600 (setq second
601 (if second (string-to-number second) 0))
602 (setq second-fraction
603 (if second-fraction
604 (float (string-to-number second-fraction))
605 0.0))
606 (setq has-time-zone (and has-time-zone t))
607 (setq time-zone-sign
608 (if (equal time-zone-sign "-") -1 1))
609 (setq time-zone-hour
610 (if time-zone-hour (string-to-number time-zone-hour) 0))
611 (setq time-zone-minute
612 (if time-zone-minute (string-to-number time-zone-minute) 0))
613 (unless (and
614 ;; XSD does not allow year 0.
615 (> year 0)
616 (>= month 1) (<= month 12)
617 (>= day 1) (<= day (rng-xsd-days-in-month year month))
618 (>= hour 0) (<= hour 23)
619 (>= minute 0) (<= minute 59)
620 ;; 60 represents a leap second, but leap seconds are explicitly
621 ;; disallowed by the XML Schema 1.1 specification. This agrees
622 ;; with typical Emacs installations, which don't count leap
623 ;; seconds in time values.
624 (>= second 0) (<= second 59)
625 (>= time-zone-hour 0)
626 (<= time-zone-hour 23)
627 (>= time-zone-minute 0)
628 (<= time-zone-minute 59))
629 (error "Invalid or unsupported time: %s" date-time-string))
630 ;; Return a value in a format similar to that returned by decode-time, and
631 ;; suitable for (apply 'encode-time ...).
632 (list second minute hour day month year second-fraction datatype
633 (if has-time-zone
634 (* (rng-xsd-time-to-seconds
635 time-zone-hour
636 time-zone-minute
637 0)
638 time-zone-sign)
639 ;; UTC.
640 0))))
641
642(defun soap-decode-xs-basic-type (type node)
643 "Use TYPE, a `soap-xs-basic-type', to decode the contents of NODE.
644A LISP value is returned based on the contents of NODE and the
645type-info stored in TYPE.
646
647This is a specialization of `soap-decode-type' for
648`soap-xs-basic-type' objects."
649 (let ((contents (xml-node-children node))
650 (kind (soap-xs-basic-type-kind type))
651 (attributes (xml-node-attributes node))
652 (validate-type type)
653 (is-nil nil))
654
655 (dolist (attribute attributes)
656 (let ((attribute-type (soap-l2fq (car attribute)))
657 (attribute-value (cdr attribute)))
658 ;; xsi:type can override an element's expected type.
659 (when (equal attribute-type (soap-l2fq "xsi:type"))
660 (setq validate-type
661 (soap-wsdl-get attribute-value soap-current-wsdl)))
662 ;; xsi:nil can specify that an element is nil in which case we don't
663 ;; validate it.
664 (when (equal attribute-type (soap-l2fq "xsi:nil"))
665 (setq is-nil (string= (downcase attribute-value) "true")))))
666
667 (unless is-nil
668 ;; For validation purposes, when xml-node-children returns nil, treat it
669 ;; as the empty string.
670 (soap-validate-xs-basic-type (car (or contents (list ""))) validate-type))
671
672 (if (null contents)
673 nil
674 (ecase kind
675 ((string anyURI QName ID IDREF language) (car contents))
676 ((dateTime time date gYearMonth gYear gMonthDay gDay gMonth)
677 (car contents))
678 ((long short int integer
679 unsignedInt unsignedLong unsignedShort nonNegativeInteger
680 decimal byte float double duration)
681 (string-to-number (car contents)))
682 (boolean (string= (downcase (car contents)) "true"))
683 (base64Binary (base64-decode-string (car contents)))
684 (anyType (soap-decode-any-type node))
685 (Array (soap-decode-array node))))))
686
687;; Register methods for `soap-xs-basic-type'
688(let ((tag (aref (make-soap-xs-basic-type) 0)))
689 (put tag 'soap-attribute-encoder #'soap-encode-xs-basic-type-attributes)
690 (put tag 'soap-encoder #'soap-encode-xs-basic-type)
691 (put tag 'soap-decoder #'soap-decode-xs-basic-type))
692
693;;;;; soap-xs-element
694
695(defstruct (soap-xs-element (:include soap-element))
696 ;; NOTE: we don't support exact number of occurrences via minOccurs,
697 ;; maxOccurs. Instead we support optional? and multiple?
698
699 id
700 type^ ; note: use soap-xs-element-type to retrieve this member
701 optional?
702 multiple?
703 reference
704 substitution-group
705 ;; contains a list of elements who point to this one via their
706 ;; substitution-group slot
707 alternatives
708 is-group)
709
710(defun soap-xs-element-type (element)
711 "Retrieve the type of ELEMENT.
712This is normally stored in the TYPE^ slot, but if this element
713contains a reference, we retrive the type of the reference."
714 (if (soap-xs-element-reference element)
715 (soap-xs-element-type (soap-xs-element-reference element))
716 (soap-xs-element-type^ element)))
717
718(defun soap-node-optional (node)
719 "Return t if NODE specifies an optional element."
720 (or (equal (xml-get-attribute-or-nil node 'nillable) "true")
721 (let ((e (xml-get-attribute-or-nil node 'minOccurs)))
722 (and e (equal e "0")))))
723
724(defun soap-node-multiple (node)
725 "Return t if NODE permits multiple elements."
726 (let* ((e (xml-get-attribute-or-nil node 'maxOccurs)))
727 (and e (not (equal e "1")))))
728
729(defun soap-xs-parse-element (node)
730 "Construct a `soap-xs-element' from NODE."
731 (let ((name (xml-get-attribute-or-nil node 'name))
732 (id (xml-get-attribute-or-nil node 'id))
733 (type (xml-get-attribute-or-nil node 'type))
734 (optional? (soap-node-optional node))
735 (multiple? (soap-node-multiple node))
736 (ref (xml-get-attribute-or-nil node 'ref))
737 (substitution-group (xml-get-attribute-or-nil node 'substitutionGroup))
738 (node-name (soap-l2wk (xml-node-name node))))
739 (assert (memq node-name '(xsd:element xsd:group))
740 "expecting xsd:element or xsd:group, got %s" node-name)
741
742 (when type
743 (setq type (soap-l2fq type 'tns)))
744
745 (when ref
746 (setq ref (soap-l2fq ref 'tns)))
747
748 (when substitution-group
749 (setq substitution-group (soap-l2fq substitution-group 'tns)))
750
751 (unless (or ref type)
752 ;; no type specified and this is not a reference. Must be a type
753 ;; defined within this node.
754 (let ((simple-type (soap-xml-get-children1 node 'xsd:simpleType)))
755 (if simple-type
756 (setq type (soap-xs-parse-simple-type (car simple-type)))
757 ;; else
758 (let ((complex-type (soap-xml-get-children1 node 'xsd:complexType)))
759 (if complex-type
760 (setq type (soap-xs-parse-complex-type (car complex-type)))
761 ;; else
762 (error "Soap-xs-parse-element: missing type or ref"))))))
763
764 (make-soap-xs-element :name name
765 ;; Use the full namespace name for now, we will
766 ;; convert it to a nstag in
767 ;; `soap-resolve-references-for-xs-element'
768 :namespace-tag soap-target-xmlns
769 :id id :type^ type
770 :optional? optional? :multiple? multiple?
771 :reference ref
772 :substitution-group substitution-group
773 :is-group (eq node-name 'xsd:group))))
774
775(defun soap-resolve-references-for-xs-element (element wsdl)
776 "Replace names in ELEMENT with the referenced objects in the WSDL.
777This is a specialization of `soap-resolve-references' for
778`soap-xs-element' objects.
779
780See also `soap-wsdl-resolve-references'."
781
782 (let ((namespace (soap-element-namespace-tag element)))
783 (when namespace
784 (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl)))))
785 (when nstag
786 (setf (soap-element-namespace-tag element) nstag)))))
787
788 (let ((type (soap-xs-element-type^ element)))
789 (cond ((soap-name-p type)
790 (setf (soap-xs-element-type^ element)
791 (soap-wsdl-get type wsdl 'soap-xs-type-p)))
792 ((soap-xs-type-p type)
793 ;; an inline defined type, this will not be reached from anywhere
794 ;; else, so we must resolve references now.
795 (soap-resolve-references type wsdl))))
796 (let ((reference (soap-xs-element-reference element)))
797 (when (and (soap-name-p reference)
798 ;; xsd:group reference nodes will be converted to inline types
799 ;; by soap-resolve-references-for-xs-complex-type, so skip them
800 ;; here.
801 (not (soap-xs-element-is-group element)))
802 (setf (soap-xs-element-reference element)
803 (soap-wsdl-get reference wsdl 'soap-xs-element-p))))
804
805 (let ((subst (soap-xs-element-substitution-group element)))
806 (when (soap-name-p subst)
807 (let ((target (soap-wsdl-get subst wsdl)))
808 (if target
809 (push element (soap-xs-element-alternatives target))
810 (soap-warning "No target found for substitution-group" subst))))))
811
812(defun soap-encode-xs-element-attributes (value element)
813 "Encode the XML attributes for VALUE according to ELEMENT.
814Currently no attributes are needed.
815
816This is a specialization of `soap-encode-attributes' for
817`soap-xs-basic-type' objects."
818 ;; Use the variables to suppress checkdoc and compiler warnings.
819 (list value element)
820 nil)
821
822(defun soap-should-encode-value-for-xs-element (value element)
823 "Return t if VALUE should be encoded for ELEMENT, nil otherwise."
824 (cond
825 ;; if value is not nil, attempt to encode it
826 (value)
827
828 ;; value is nil, but the element's type is a boolean, so nil in this case
829 ;; means "false". We need to encode it.
830 ((let ((type (soap-xs-element-type element)))
831 (and (soap-xs-basic-type-p type)
832 (eq (soap-xs-basic-type-kind type) 'boolean))))
833
834 ;; This is not an optional element. Force encoding it (although this
835 ;; might fail at the validation step, but this is what we intend.
836
837 ;; value is nil, but the element's type has some attributes which supply a
838 ;; default value. We need to encode it.
839
840 ((let ((type (soap-xs-element-type element)))
841 (catch 'found
842 (dolist (a (soap-xs-type-attributes type))
843 (when (soap-xs-attribute-default a)
844 (throw 'found t))))))
845
846 ;; otherwise, we don't need to encode it
847 (t nil)))
848
849(defun soap-type-is-array? (type)
850 "Return t if TYPE defines an ARRAY."
851 (and (soap-xs-complex-type-p type)
852 (eq (soap-xs-complex-type-indicator type) 'array)))
853
854(defvar soap-encoded-namespaces nil
855 "A list of namespace tags used during encoding a message.
856This list is populated by `soap-encode-value' and used by
857`soap-create-envelope' to add aliases for these namespace to the
858XML request.
859
860This variable is dynamically bound in `soap-create-envelope'.")
861
862(defun soap-encode-xs-element (value element)
863 "Encode the VALUE according to ELEMENT.
864The data is inserted in the current buffer at the current
865position.
866
867This is a specialization of `soap-encode-value' for
868`soap-xs-basic-type' objects."
869 (let ((fq-name (soap-element-fq-name element))
870 (type (soap-xs-element-type element)))
871 ;; Only encode the element if it has a name. NOTE: soap-element-fq-name
872 ;; will return *unnamed* for such elements
873 (if (soap-element-name element)
874 ;; Don't encode this element if value is nil. However, even if value
875 ;; is nil we still want to encode this element if it has any attributes
876 ;; with default values.
877 (when (soap-should-encode-value-for-xs-element value element)
878 (progn
879 (insert "<" fq-name)
880 (soap-encode-attributes value type)
881 ;; If value is nil and type is boolean encode the value as "false".
882 ;; Otherwise don't encode the value.
883 (if (or value (and (soap-xs-basic-type-p type)
884 (eq (soap-xs-basic-type-kind type) 'boolean)))
885 (progn (insert ">")
886 ;; ARRAY's need special treatment, as each element of
887 ;; the array is encoded with the same tag as the
888 ;; current element...
889 (if (soap-type-is-array? type)
890 (let ((new-element (copy-soap-xs-element element)))
891 (when (soap-element-namespace-tag type)
892 (add-to-list 'soap-encoded-namespaces
893 (soap-element-namespace-tag type)))
894 (setf (soap-xs-element-type^ new-element)
895 (soap-xs-complex-type-base type))
896 (loop for i below (length value)
897 do (progn
898 (soap-encode-xs-element (aref value i) new-element)
899 )))
900 (soap-encode-value value type))
901 (insert "</" fq-name ">\n"))
902 ;; else
903 (insert "/>\n"))))
904 (when (soap-should-encode-value-for-xs-element value element)
905 (soap-encode-value value type)))))
906
907(defun soap-decode-xs-element (element node)
908 "Use ELEMENT, a `soap-xs-element', to decode the contents of NODE.
909A LISP value is returned based on the contents of NODE and the
910type-info stored in ELEMENT.
911
912This is a specialization of `soap-decode-type' for
913`soap-xs-basic-type' objects."
914 (let ((type (soap-xs-element-type element)))
915 (soap-decode-type type node)))
916
917;; Register methods for `soap-xs-element'
918(let ((tag (aref (make-soap-xs-element) 0)))
919 (put tag 'soap-resolve-references #'soap-resolve-references-for-xs-element)
920 (put tag 'soap-attribute-encoder #'soap-encode-xs-element-attributes)
921 (put tag 'soap-encoder #'soap-encode-xs-element)
922 (put tag 'soap-decoder #'soap-decode-xs-element))
923
924;;;;; soap-xs-attribute
925
926(defstruct (soap-xs-attribute (:include soap-element))
927 type ; a simple type or basic type
928 default ; the default value, if any
929 reference)
930
931(defstruct (soap-xs-attribute-group (:include soap-xs-type))
932 reference)
933
934(defun soap-xs-parse-attribute (node)
935 "Construct a `soap-xs-attribute' from NODE."
936 (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:attribute)
937 "expecting xsd:attribute, got %s" (soap-l2wk (xml-node-name node)))
938 (let* ((name (xml-get-attribute-or-nil node 'name))
939 (type (soap-l2fq (xml-get-attribute-or-nil node 'type)))
940 (default (xml-get-attribute-or-nil node 'fixed))
941 (attribute (xml-get-attribute-or-nil node 'ref))
942 (ref (when attribute (soap-l2fq attribute))))
943 (unless (or type ref)
944 (setq type (soap-xs-parse-simple-type
945 (soap-xml-node-find-matching-child
946 node '(xsd:restriction xsd:list xsd:union)))))
947 (make-soap-xs-attribute
948 :name name :type type :default default :reference ref)))
949
950(defun soap-xs-parse-attribute-group (node)
951 "Construct a `soap-xs-attribute-group' from NODE."
952 (let ((node-name (soap-l2wk (xml-node-name node))))
953 (assert (eq node-name 'xsd:attributeGroup)
954 "expecting xsd:attributeGroup, got %s" node-name)
955 (let ((name (xml-get-attribute-or-nil node 'name))
956 (id (xml-get-attribute-or-nil node 'id))
957 (ref (xml-get-attribute-or-nil node 'ref))
958 attribute-group)
959 (when (and name ref)
960 (soap-warning "name and ref set for attribute group %s" node-name))
961 (setq attribute-group
962 (make-soap-xs-attribute-group :id id
963 :name name
964 :reference (and ref (soap-l2fq ref))))
965 (when (not ref)
966 (dolist (child (xml-node-children node))
967 ;; Ignore whitespace.
968 (unless (stringp child)
969 ;; Ignore optional annotation.
970 ;; Ignore anyAttribute nodes.
971 (case (soap-l2wk (xml-node-name child))
972 (xsd:attribute
973 (push (soap-xs-parse-attribute child)
974 (soap-xs-type-attributes attribute-group)))
975 (xsd:attributeGroup
976 (push (soap-xs-parse-attribute-group child)
977 (soap-xs-attribute-group-attribute-groups
978 attribute-group)))))))
979 attribute-group)))
980
981(defun soap-resolve-references-for-xs-attribute (attribute wsdl)
982 "Replace names in ATTRIBUTE with the referenced objects in the WSDL.
983This is a specialization of `soap-resolve-references' for
984`soap-xs-attribute' objects.
985
986See also `soap-wsdl-resolve-references'."
987 (let* ((type (soap-xs-attribute-type attribute))
988 (reference (soap-xs-attribute-reference attribute))
989 (predicate 'soap-xs-element-p)
990 (xml-reference
991 (and (soap-name-p reference)
992 (equal (car reference) "http://www.w3.org/XML/1998/namespace"))))
993 (cond (xml-reference
994 ;; Convert references to attributes defined by the XML
995 ;; schema (xml:base, xml:lang, xml:space and xml:id) to
996 ;; xsd:string, to avoid needing to bundle and parse
997 ;; xml.xsd.
998 (setq reference '("http://www.w3.org/2001/XMLSchema" . "string"))
999 (setq predicate 'soap-xs-basic-type-p))
1000 ((soap-name-p type)
1001 (setf (soap-xs-attribute-type attribute)
1002 (soap-wsdl-get type wsdl
1003 (lambda (type)
1004 (or (soap-xs-basic-type-p type)
1005 (soap-xs-simple-type-p type))))))
1006 ((soap-xs-type-p type)
1007 ;; an inline defined type, this will not be reached from anywhere
1008 ;; else, so we must resolve references now.
1009 (soap-resolve-references type wsdl)))
1010 (when (soap-name-p reference)
1011 (setf (soap-xs-attribute-reference attribute)
1012 (soap-wsdl-get reference wsdl predicate)))))
1013
1014(put (aref (make-soap-xs-attribute) 0)
1015 'soap-resolve-references #'soap-resolve-references-for-xs-attribute)
1016
1017(defun soap-resolve-references-for-xs-attribute-group (attribute-group wsdl)
1018 "Set slots in ATTRIBUTE-GROUP to the referenced objects in the WSDL.
1019This is a specialization of `soap-resolve-references' for
1020`soap-xs-attribute-group' objects.
1021
1022See also `soap-wsdl-resolve-references'."
1023 (let ((reference (soap-xs-attribute-group-reference attribute-group)))
1024 (when (soap-name-p reference)
1025 (let ((resolved (soap-wsdl-get reference wsdl
1026 'soap-xs-attribute-group-p)))
1027 (dolist (attribute (soap-xs-attribute-group-attributes resolved))
1028 (soap-resolve-references attribute wsdl))
1029 (setf (soap-xs-attribute-group-name attribute-group)
1030 (soap-xs-attribute-group-name resolved))
1031 (setf (soap-xs-attribute-group-id attribute-group)
1032 (soap-xs-attribute-group-id resolved))
1033 (setf (soap-xs-attribute-group-reference attribute-group) nil)
1034 (setf (soap-xs-attribute-group-attributes attribute-group)
1035 (soap-xs-attribute-group-attributes resolved))
1036 (setf (soap-xs-attribute-group-attribute-groups attribute-group)
1037 (soap-xs-attribute-group-attribute-groups resolved))))))
1038
1039(put (aref (make-soap-xs-attribute-group) 0)
1040 'soap-resolve-references #'soap-resolve-references-for-xs-attribute-group)
1041
1042;;;;; soap-xs-simple-type
1043
1044(defstruct (soap-xs-simple-type (:include soap-xs-type))
1045 ;; A simple type is an extension on the basic type to which some
1046 ;; restrictions can be added. For example we can define a simple type based
1047 ;; off "string" with the restrictions that only the strings "one", "two" and
1048 ;; "three" are valid values (this is an enumeration).
1049
1050 base ; can be a single type, or a list of types for union types
1051 enumeration ; nil, or list of permitted values for the type
1052 pattern ; nil, or value must match this pattern
1053 length-range ; a cons of (min . max) length, inclusive range.
1054 ; For exact length, use (l, l).
1055 ; nil means no range,
1056 ; (nil . l) means no min range,
1057 ; (l . nil) means no max range.
1058 integer-range ; a pair of (min, max) integer values, inclusive range,
1059 ; same meaning as `length-range'
1060 is-list ; t if this is an xs:list, nil otherwise
386 ) 1061 )
387 1062
1063(defun soap-xs-parse-simple-type (node)
1064 "Construct an `soap-xs-simple-type' object from the XML NODE."
1065 (assert (memq (soap-l2wk (xml-node-name node))
1066 '(xsd:simpleType xsd:simpleContent))
1067 nil
1068 "expecting xsd:simpleType or xsd:simpleContent node, got %s"
1069 (soap-l2wk (xml-node-name node)))
1070
1071 ;; NOTE: name can be nil for inline types. Such types cannot be added to a
1072 ;; namespace.
1073 (let ((name (xml-get-attribute-or-nil node 'name))
1074 (id (xml-get-attribute-or-nil node 'id)))
1075
1076 (let ((type (make-soap-xs-simple-type
1077 :name name :namespace-tag soap-target-xmlns :id id))
1078 (def (soap-xml-node-find-matching-child
1079 node '(xsd:restriction xsd:extension xsd:union xsd:list))))
1080 (ecase (soap-l2wk (xml-node-name def))
1081 (xsd:restriction (soap-xs-add-restriction def type))
1082 (xsd:extension (soap-xs-add-extension def type))
1083 (xsd:union (soap-xs-add-union def type))
1084 (xsd:list (soap-xs-add-list def type)))
1085
1086 type)))
1087
1088(defun soap-xs-add-restriction (node type)
1089 "Add restrictions defined in XML NODE to TYPE, an `soap-xs-simple-type'."
1090
1091 (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:restriction)
1092 nil
1093 "expecting xsd:restriction node, got %s"
1094 (soap-l2wk (xml-node-name node)))
1095
1096 (setf (soap-xs-simple-type-base type)
1097 (soap-l2fq (xml-get-attribute node 'base)))
1098
1099 (dolist (r (xml-node-children node))
1100 (unless (stringp r) ; skip the white space
1101 (let ((value (xml-get-attribute r 'value)))
1102 (case (soap-l2wk (xml-node-name r))
1103 (xsd:enumeration
1104 (push value (soap-xs-simple-type-enumeration type)))
1105 (xsd:pattern
1106 (setf (soap-xs-simple-type-pattern type)
1107 (concat "\\`" (xsdre-translate value) "\\'")))
1108 (xsd:length
1109 (let ((value (string-to-number value)))
1110 (setf (soap-xs-simple-type-length-range type)
1111 (cons value value))))
1112 (xsd:minLength
1113 (let ((value (string-to-number value)))
1114 (setf (soap-xs-simple-type-length-range type)
1115 (if (soap-xs-simple-type-length-range type)
1116 (cons value
1117 (cdr (soap-xs-simple-type-length-range type)))
1118 ;; else
1119 (cons value nil)))))
1120 (xsd:maxLength
1121 (let ((value (string-to-number value)))
1122 (setf (soap-xs-simple-type-length-range type)
1123 (if (soap-xs-simple-type-length-range type)
1124 (cons (car (soap-xs-simple-type-length-range type))
1125 value)
1126 ;; else
1127 (cons nil value)))))
1128 (xsd:minExclusive
1129 (let ((value (string-to-number value)))
1130 (setf (soap-xs-simple-type-integer-range type)
1131 (if (soap-xs-simple-type-integer-range type)
1132 (cons (1+ value)
1133 (cdr (soap-xs-simple-type-integer-range type)))
1134 ;; else
1135 (cons (1+ value) nil)))))
1136 (xsd:maxExclusive
1137 (let ((value (string-to-number value)))
1138 (setf (soap-xs-simple-type-integer-range type)
1139 (if (soap-xs-simple-type-integer-range type)
1140 (cons (car (soap-xs-simple-type-integer-range type))
1141 (1- value))
1142 ;; else
1143 (cons nil (1- value))))))
1144 (xsd:minInclusive
1145 (let ((value (string-to-number value)))
1146 (setf (soap-xs-simple-type-integer-range type)
1147 (if (soap-xs-simple-type-integer-range type)
1148 (cons value
1149 (cdr (soap-xs-simple-type-integer-range type)))
1150 ;; else
1151 (cons value nil)))))
1152 (xsd:maxInclusive
1153 (let ((value (string-to-number value)))
1154 (setf (soap-xs-simple-type-integer-range type)
1155 (if (soap-xs-simple-type-integer-range type)
1156 (cons (car (soap-xs-simple-type-integer-range type))
1157 value)
1158 ;; else
1159 (cons nil value))))))))))
1160
1161(defun soap-xs-add-union (node type)
1162 "Add union members defined in XML NODE to TYPE, an `soap-xs-simple-type'."
1163 (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:union)
1164 nil
1165 "expecting xsd:union node, got %s" (soap-l2wk (xml-node-name node)))
1166
1167 (setf (soap-xs-simple-type-base type)
1168 (mapcar 'soap-l2fq
1169 (split-string
1170 (or (xml-get-attribute-or-nil node 'memberTypes) ""))))
1171
1172 ;; Additional simple types can be defined inside the union node. Add them
1173 ;; to the base list. The "memberTypes" members will have to be resolved by
1174 ;; the "resolve-references" method, the inline types will not.
1175 (let (result)
1176 (dolist (simple-type (soap-xml-get-children1 node 'xsd:simpleType))
1177 (push (soap-xs-parse-simple-type simple-type) result))
1178 (setf (soap-xs-simple-type-base type)
1179 (append (soap-xs-simple-type-base type) (nreverse result)))))
1180
1181(defun soap-xs-add-list (node type)
1182 "Add list defined in XML NODE to TYPE, a `soap-xs-simple-type'."
1183 (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:list)
1184 nil
1185 "expecting xsd:list node, got %s" (soap-l2wk (xml-node-name node)))
1186
1187 ;; A simple type can be defined inline inside the list node or referenced by
1188 ;; the itemType attribute, in which case it will be resolved by the
1189 ;; resolve-references method.
1190 (let* ((item-type (xml-get-attribute-or-nil node 'itemType))
1191 (children (soap-xml-get-children1 node 'xsd:simpleType)))
1192 (if item-type
1193 (if (= (length children) 0)
1194 (setf (soap-xs-simple-type-base type) (soap-l2fq item-type))
1195 (soap-warning
1196 "xsd:list node with itemType has more than zero children: %s"
1197 (soap-xs-type-name type)))
1198 (if (= (length children) 1)
1199 (setf (soap-xs-simple-type-base type)
1200 (soap-xs-parse-simple-type
1201 (car (soap-xml-get-children1 node 'xsd:simpleType))))
1202 (soap-warning "xsd:list node has more than one child %s"
1203 (soap-xs-type-name type))))
1204 (setf (soap-xs-simple-type-is-list type) t)))
1205
1206(defun soap-xs-add-extension (node type)
1207 "Add the extended type defined in XML NODE to TYPE, an `soap-xs-simple-type'."
1208 (setf (soap-xs-simple-type-base type)
1209 (soap-l2fq (xml-get-attribute node 'base)))
1210 (dolist (attribute (soap-xml-get-children1 node 'xsd:attribute))
1211 (push (soap-xs-parse-attribute attribute)
1212 (soap-xs-type-attributes type)))
1213 (dolist (attribute-group (soap-xml-get-children1 node 'xsd:attributeGroup))
1214 (push (soap-xs-parse-attribute-group attribute-group)
1215 (soap-xs-type-attribute-groups type))))
1216
1217(defun soap-validate-xs-basic-type (value type)
1218 "Validate VALUE against the basic type TYPE."
1219 (let* ((kind (soap-xs-basic-type-kind type)))
1220 (case kind
1221 ((anyType Array byte[])
1222 value)
1223 (t
1224 (let ((convert (get kind 'rng-xsd-convert)))
1225 (if convert
1226 (if (rng-dt-make-value convert value)
1227 value
1228 (error "Invalid %s: %s" (symbol-name kind) value))
1229 (error "Don't know how to convert %s" kind)))))))
1230
1231(defun soap-validate-xs-simple-type (value type)
1232 "Validate VALUE against the restrictions of TYPE."
1233
1234 (let* ((base-type (soap-xs-simple-type-base type))
1235 (messages nil))
1236 (if (listp base-type)
1237 (catch 'valid
1238 (dolist (base base-type)
1239 (condition-case error-object
1240 (cond ((soap-xs-simple-type-p base)
1241 (throw 'valid
1242 (soap-validate-xs-simple-type value base)))
1243 ((soap-xs-basic-type-p base)
1244 (throw 'valid
1245 (soap-validate-xs-basic-type value base))))
1246 (error (push (cadr error-object) messages))))
1247 (when messages
1248 (error (mapconcat 'identity (nreverse messages) "; and: "))))
1249 (cl-flet ((fail-with-message (format value)
1250 (push (format format value) messages)
1251 (throw 'invalid nil)))
1252 (catch 'invalid
1253 (let ((enumeration (soap-xs-simple-type-enumeration type)))
1254 (when (and (> (length enumeration) 1)
1255 (not (member value enumeration)))
1256 (fail-with-message "bad value, should be one of %s" enumeration)))
1257
1258 (let ((pattern (soap-xs-simple-type-pattern type)))
1259 (when (and pattern (not (string-match-p pattern value)))
1260 (fail-with-message "bad value, should match pattern %s" pattern)))
1261
1262 (let ((length-range (soap-xs-simple-type-length-range type)))
1263 (when length-range
1264 (unless (stringp value)
1265 (fail-with-message
1266 "bad value, should be a string with length range %s"
1267 length-range))
1268 (when (car length-range)
1269 (unless (>= (length value) (car length-range))
1270 (fail-with-message "short string, should be at least %s chars"
1271 (car length-range))))
1272 (when (cdr length-range)
1273 (unless (<= (length value) (cdr length-range))
1274 (fail-with-message "long string, should be at most %s chars"
1275 (cdr length-range))))))
1276
1277 (let ((integer-range (soap-xs-simple-type-integer-range type)))
1278 (when integer-range
1279 (unless (numberp value)
1280 (fail-with-message "bad value, should be a number with range %s"
1281 integer-range))
1282 (when (car integer-range)
1283 (unless (>= value (car integer-range))
1284 (fail-with-message "small value, should be at least %s"
1285 (car integer-range))))
1286 (when (cdr integer-range)
1287 (unless (<= value (cdr integer-range))
1288 (fail-with-message "big value, should be at most %s"
1289 (cdr integer-range))))))))
1290 (when messages
1291 (error "Xs-simple-type(%s, %s): %s"
1292 value (or (soap-xs-type-name type) (soap-xs-type-id type))
1293 (car messages)))))
1294 ;; Return the validated value.
1295 value)
1296
1297(defun soap-resolve-references-for-xs-simple-type (type wsdl)
1298 "Replace names in TYPE with the referenced objects in the WSDL.
1299This is a specialization of `soap-resolve-references' for
1300`soap-xs-simple-type' objects.
1301
1302See also `soap-wsdl-resolve-references'."
1303
1304 (let ((namespace (soap-element-namespace-tag type)))
1305 (when namespace
1306 (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl)))))
1307 (when nstag
1308 (setf (soap-element-namespace-tag type) nstag)))))
1309
1310 (let ((base (soap-xs-simple-type-base type)))
1311 (cond
1312 ((soap-name-p base)
1313 (setf (soap-xs-simple-type-base type)
1314 (soap-wsdl-get base wsdl 'soap-xs-type-p)))
1315 ((soap-xs-type-p base)
1316 (soap-resolve-references base wsdl))
1317 ((listp base)
1318 (setf (soap-xs-simple-type-base type)
1319 (mapcar (lambda (type)
1320 (cond ((soap-name-p type)
1321 (soap-wsdl-get type wsdl 'soap-xs-type-p))
1322 ((soap-xs-type-p type)
1323 (soap-resolve-references type wsdl)
1324 type)
1325 (t ; signal an error?
1326 type)))
1327 base)))
1328 (t (error "Oops"))))
1329 (dolist (attribute (soap-xs-type-attributes type))
1330 (soap-resolve-references attribute wsdl))
1331 (dolist (attribute-group (soap-xs-type-attribute-groups type))
1332 (soap-resolve-references attribute-group wsdl)))
1333
1334(defun soap-encode-xs-simple-type-attributes (value type)
1335 "Encode the XML attributes for VALUE according to TYPE.
1336The xsi:type and an optional xsi:nil attributes are added. The
1337attributes are inserted in the current buffer at the current
1338position.
1339
1340This is a specialization of `soap-encode-attributes' for
1341`soap-xs-simple-type' objects."
1342 (insert " xsi:type=\"" (soap-element-fq-name type) "\"")
1343 (unless value (insert " xsi:nil=\"true\"")))
1344
1345(defun soap-encode-xs-simple-type (value type)
1346 "Encode the VALUE according to TYPE.
1347The data is inserted in the current buffer at the current
1348position.
1349
1350This is a specialization of `soap-encode-value' for
1351`soap-xs-simple-type' objects."
1352 (soap-validate-xs-simple-type value type)
1353 (if (soap-xs-simple-type-is-list type)
1354 (progn
1355 (dolist (v (butlast value))
1356 (soap-encode-value v (soap-xs-simple-type-base type))
1357 (insert " "))
1358 (soap-encode-value (car (last value)) (soap-xs-simple-type-base type)))
1359 (soap-encode-value value (soap-xs-simple-type-base type))))
1360
1361(defun soap-decode-xs-simple-type (type node)
1362 "Use TYPE, a `soap-xs-simple-type', to decode the contents of NODE.
1363A LISP value is returned based on the contents of NODE and the
1364type-info stored in TYPE.
1365
1366This is a specialization of `soap-decode-type' for
1367`soap-xs-simple-type' objects."
1368 (if (soap-xs-simple-type-is-list type)
1369 ;; Technically, we could construct fake XML NODEs and pass them to
1370 ;; soap-decode-value...
1371 (split-string (car (xml-node-children node)))
1372 (let ((value (soap-decode-type (soap-xs-simple-type-base type) node)))
1373 (soap-validate-xs-simple-type value type))))
1374
1375;; Register methods for `soap-xs-simple-type'
1376(let ((tag (aref (make-soap-xs-simple-type) 0)))
1377 (put tag 'soap-resolve-references
1378 #'soap-resolve-references-for-xs-simple-type)
1379 (put tag 'soap-attribute-encoder #'soap-encode-xs-simple-type-attributes)
1380 (put tag 'soap-encoder #'soap-encode-xs-simple-type)
1381 (put tag 'soap-decoder #'soap-decode-xs-simple-type))
1382
1383;;;;; soap-xs-complex-type
1384
1385(defstruct (soap-xs-complex-type (:include soap-xs-type))
1386 indicator ; sequence, choice, all, array
1387 base
1388 elements
1389 optional?
1390 multiple?
1391 is-group)
1392
1393(defun soap-xs-parse-complex-type (node)
1394 "Construct a `soap-xs-complex-type' by parsing the XML NODE."
1395 (let ((name (xml-get-attribute-or-nil node 'name))
1396 (id (xml-get-attribute-or-nil node 'id))
1397 (node-name (soap-l2wk (xml-node-name node)))
1398 type
1399 attributes
1400 attribute-groups)
1401 (assert (memq node-name '(xsd:complexType xsd:complexContent xsd:group))
1402 nil "unexpected node: %s" node-name)
1403
1404 (dolist (def (xml-node-children node))
1405 (when (consp def) ; skip text nodes
1406 (case (soap-l2wk (xml-node-name def))
1407 (xsd:attribute (push (soap-xs-parse-attribute def) attributes))
1408 (xsd:attributeGroup
1409 (push (soap-xs-parse-attribute-group def)
1410 attribute-groups))
1411 (xsd:simpleContent (setq type (soap-xs-parse-simple-type def)))
1412 ((xsd:sequence xsd:all xsd:choice)
1413 (setq type (soap-xs-parse-sequence def)))
1414 (xsd:complexContent
1415 (dolist (def (xml-node-children def))
1416 (when (consp def)
1417 (case (soap-l2wk (xml-node-name def))
1418 (xsd:attribute
1419 (push (soap-xs-parse-attribute def) attributes))
1420 (xsd:attributeGroup
1421 (push (soap-xs-parse-attribute-group def)
1422 attribute-groups))
1423 ((xsd:extension xsd:restriction)
1424 (setq type
1425 (soap-xs-parse-extension-or-restriction def)))
1426 ((xsd:sequence xsd:all xsd:choice)
1427 (soap-xs-parse-sequence def)))))))))
1428 (unless type
1429 ;; the type has not been built, this is a shortcut for a simpleContent
1430 ;; node
1431 (setq type (make-soap-xs-complex-type)))
1432
1433 (setf (soap-xs-type-name type) name)
1434 (setf (soap-xs-type-namespace-tag type) soap-target-xmlns)
1435 (setf (soap-xs-type-id type) id)
1436 (setf (soap-xs-type-attributes type)
1437 (append attributes (soap-xs-type-attributes type)))
1438 (setf (soap-xs-type-attribute-groups type)
1439 (append attribute-groups (soap-xs-type-attribute-groups type)))
1440 (when (soap-xs-complex-type-p type)
1441 (setf (soap-xs-complex-type-is-group type)
1442 (eq node-name 'xsd:group)))
1443 type))
1444
1445(defun soap-xs-parse-sequence (node)
1446 "Parse a sequence definition from XML NODE.
1447Returns a `soap-xs-complex-type'"
1448 (assert (memq (soap-l2wk (xml-node-name node))
1449 '(xsd:sequence xsd:choice xsd:all))
1450 nil
1451 "unexpected node: %s" (soap-l2wk (xml-node-name node)))
1452
1453 (let ((type (make-soap-xs-complex-type)))
1454
1455 (setf (soap-xs-complex-type-indicator type)
1456 (ecase (soap-l2wk (xml-node-name node))
1457 (xsd:sequence 'sequence)
1458 (xsd:all 'all)
1459 (xsd:choice 'choice)))
1460
1461 (setf (soap-xs-complex-type-optional? type) (soap-node-optional node))
1462 (setf (soap-xs-complex-type-multiple? type) (soap-node-multiple node))
1463
1464 (dolist (r (xml-node-children node))
1465 (unless (stringp r) ; skip the white space
1466 (case (soap-l2wk (xml-node-name r))
1467 ((xsd:element xsd:group)
1468 (push (soap-xs-parse-element r)
1469 (soap-xs-complex-type-elements type)))
1470 ((xsd:sequence xsd:choice xsd:all)
1471 ;; an inline sequence, choice or all node
1472 (let ((choice (soap-xs-parse-sequence r)))
1473 (push (make-soap-xs-element :name nil :type^ choice)
1474 (soap-xs-complex-type-elements type))))
1475 (xsd:attribute
1476 (push (soap-xs-parse-attribute r)
1477 (soap-xs-type-attributes type)))
1478 (xsd:attributeGroup
1479 (push (soap-xs-parse-attribute-group r)
1480 (soap-xs-type-attribute-groups type))))))
1481
1482 (setf (soap-xs-complex-type-elements type)
1483 (nreverse (soap-xs-complex-type-elements type)))
1484
1485 type))
1486
1487(defun soap-xs-parse-extension-or-restriction (node)
1488 "Parse an extension or restriction definition from XML NODE.
1489Return a `soap-xs-complex-type'."
1490 (assert (memq (soap-l2wk (xml-node-name node))
1491 '(xsd:extension xsd:restriction))
1492 nil
1493 "unexpected node: %s" (soap-l2wk (xml-node-name node)))
1494 (let (type
1495 attributes
1496 attribute-groups
1497 array?
1498 (base (xml-get-attribute-or-nil node 'base)))
1499
1500 ;; Array declarations are recognized specially, it is unclear to me how
1501 ;; they could be treated generally...
1502 (setq array?
1503 (and (eq (soap-l2wk (xml-node-name node)) 'xsd:restriction)
1504 (equal base (soap-wk2l "soapenc:Array"))))
1505
1506 (dolist (def (xml-node-children node))
1507 (when (consp def) ; skip text nodes
1508 (case (soap-l2wk (xml-node-name def))
1509 ((xsd:sequence xsd:choice xsd:all)
1510 (setq type (soap-xs-parse-sequence def)))
1511 (xsd:attribute
1512 (if array?
1513 (let ((array-type
1514 (soap-xml-get-attribute-or-nil1 def 'wsdl:arrayType)))
1515 (when (and array-type
1516 (string-match "^\\(.*\\)\\[\\]$" array-type))
1517 ;; Override
1518 (setq base (match-string 1 array-type))))
1519 ;; else
1520 (push (soap-xs-parse-attribute def) attributes)))
1521 (xsd:attributeGroup
1522 (push (soap-xs-parse-attribute-group def) attribute-groups)))))
1523
1524 (unless type
1525 (setq type (make-soap-xs-complex-type))
1526 (when array?
1527 (setf (soap-xs-complex-type-indicator type) 'array)))
1528
1529 (setf (soap-xs-complex-type-base type) (soap-l2fq base))
1530 (setf (soap-xs-complex-type-attributes type) attributes)
1531 (setf (soap-xs-complex-type-attribute-groups type) attribute-groups)
1532 type))
1533
1534(defun soap-resolve-references-for-xs-complex-type (type wsdl)
1535 "Replace names in TYPE with the referenced objects in the WSDL.
1536This is a specialization of `soap-resolve-references' for
1537`soap-xs-complex-type' objects.
1538
1539See also `soap-wsdl-resolve-references'."
1540
1541 (let ((namespace (soap-element-namespace-tag type)))
1542 (when namespace
1543 (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl)))))
1544 (when nstag
1545 (setf (soap-element-namespace-tag type) nstag)))))
1546
1547 (let ((base (soap-xs-complex-type-base type)))
1548 (cond ((soap-name-p base)
1549 (setf (soap-xs-complex-type-base type)
1550 (soap-wsdl-get base wsdl 'soap-xs-type-p)))
1551 ((soap-xs-type-p base)
1552 (soap-resolve-references base wsdl))))
1553 (let (all-elements)
1554 (dolist (element (soap-xs-complex-type-elements type))
1555 (if (soap-xs-element-is-group element)
1556 ;; This is an xsd:group element that references an xsd:group node,
1557 ;; which we treat as a complex type. We replace the reference
1558 ;; element by inlining the elements of the referenced xsd:group
1559 ;; (complex type) node.
1560 (let ((type (soap-wsdl-get
1561 (soap-xs-element-reference element)
1562 wsdl (lambda (type)
1563 (and
1564 (soap-xs-complex-type-p type)
1565 (soap-xs-complex-type-is-group type))))))
1566 (dolist (element (soap-xs-complex-type-elements type))
1567 (soap-resolve-references element wsdl)
1568 (push element all-elements)))
1569 ;; This is a non-xsd:group node so just add it directly.
1570 (soap-resolve-references element wsdl)
1571 (push element all-elements)))
1572 (setf (soap-xs-complex-type-elements type) (nreverse all-elements)))
1573 (dolist (attribute (soap-xs-type-attributes type))
1574 (soap-resolve-references attribute wsdl))
1575 (dolist (attribute-group (soap-xs-type-attribute-groups type))
1576 (soap-resolve-references attribute-group wsdl)))
1577
1578(defun soap-encode-xs-complex-type-attributes (value type)
1579 "Encode the XML attributes for encoding VALUE according to TYPE.
1580The xsi:type and optional xsi:nil attributes are added, plus
1581additional attributes needed for arrays types, if applicable. The
1582attributes are inserted in the current buffer at the current
1583position.
1584
1585This is a specialization of `soap-encode-attributes' for
1586`soap-xs-complex-type' objects."
1587 (if (eq (soap-xs-complex-type-indicator type) 'array)
1588 (let ((element-type (soap-xs-complex-type-base type)))
1589 (insert " xsi:type=\"soapenc:Array\"")
1590 (insert " soapenc:arrayType=\""
1591 (soap-element-fq-name element-type)
1592 "[" (format "%s" (length value)) "]" "\""))
1593 ;; else
1594 (progn
1595 (dolist (a (soap-get-xs-attributes type))
1596 (let ((element-name (soap-element-name a)))
1597 (if (soap-xs-attribute-default a)
1598 (insert " " element-name
1599 "=\"" (soap-xs-attribute-default a) "\"")
1600 (dolist (value-pair value)
1601 (when (equal element-name (symbol-name (car value-pair)))
1602 (insert " " element-name
1603 "=\"" (cdr value-pair) "\""))))))
1604 ;; If this is not an empty type, and we have no value, mark it as nil
1605 (when (and (soap-xs-complex-type-indicator type) (null value))
1606 (insert " xsi:nil=\"true\"")))))
1607
1608(defun soap-get-candidate-elements (element)
1609 "Return a list of elements that are compatible with ELEMENT.
1610The returned list includes ELEMENT's references and
1611alternatives."
1612 (let ((reference (soap-xs-element-reference element)))
1613 ;; If the element is a reference, append the reference and its
1614 ;; alternatives...
1615 (if reference
1616 (append (list reference)
1617 (soap-xs-element-alternatives reference))
1618 ;; ...otherwise append the element itself and its alternatives.
1619 (append (list element)
1620 (soap-xs-element-alternatives element)))))
1621
1622(defun soap-encode-xs-complex-type (value type)
1623 "Encode the VALUE according to TYPE.
1624The data is inserted in the current buffer at the current
1625position.
1626
1627This is a specialization of `soap-encode-value' for
1628`soap-xs-complex-type' objects."
1629 (case (soap-xs-complex-type-indicator type)
1630 (array
1631 (error "soap-encode-xs-complex-type arrays are handled elsewhere"))
1632 ((sequence choice all nil)
1633 (let ((type-list (list type)))
1634
1635 ;; Collect all base types
1636 (let ((base (soap-xs-complex-type-base type)))
1637 (while base
1638 (push base type-list)
1639 (setq base (soap-xs-complex-type-base base))))
1640
1641 (dolist (type type-list)
1642 (dolist (element (soap-xs-complex-type-elements type))
1643 (catch 'done
1644 (let ((instance-count 0))
1645 (dolist (candidate (soap-get-candidate-elements element))
1646 (let ((e-name (soap-xs-element-name candidate)))
1647 (if e-name
1648 (let ((e-name (intern e-name)))
1649 (dolist (v value)
1650 (when (equal (car v) e-name)
1651 (incf instance-count)
1652 (soap-encode-value (cdr v) candidate))))
1653 (if (soap-xs-complex-type-indicator type)
1654 (let ((current-point (point)))
1655 ;; Check if encoding happened by checking if
1656 ;; characters were inserted in the buffer.
1657 (soap-encode-value value candidate)
1658 (when (not (equal current-point (point)))
1659 (incf instance-count)))
1660 (dolist (v value)
1661 (let ((current-point (point)))
1662 (soap-encode-value v candidate)
1663 (when (not (equal current-point (point)))
1664 (incf instance-count))))))))
1665 ;; Do some sanity checking
1666 (let* ((indicator (soap-xs-complex-type-indicator type))
1667 (element-type (soap-xs-element-type element))
1668 (reference (soap-xs-element-reference element))
1669 (e-name (or (soap-xs-element-name element)
1670 (and reference
1671 (soap-xs-element-name reference)))))
1672 (cond ((and (eq indicator 'choice)
1673 (> instance-count 0))
1674 ;; This was a choice node and we encoded
1675 ;; one instance.
1676 (throw 'done t))
1677 ((and (not (eq indicator 'choice))
1678 (= instance-count 0)
1679 (not (soap-xs-element-optional? element))
1680 (and (soap-xs-complex-type-p element-type)
1681 (not (soap-xs-complex-type-optional-p
1682 element-type))))
1683 (soap-warning
1684 "While encoding %s: missing non-nillable slot %s"
1685 value e-name))
1686 ((and (> instance-count 1)
1687 (not (soap-xs-element-multiple? element))
1688 (and (soap-xs-complex-type-p element-type)
1689 (not (soap-xs-complex-type-multiple-p
1690 element-type))))
1691 (soap-warning
1692 (concat "While encoding %s: expected single,"
1693 " found multiple elements for slot %s")
1694 value e-name))))))))))
1695 (t
1696 (error "Don't know how to encode complex type: %s"
1697 (soap-xs-complex-type-indicator type)))))
1698
1699(defun soap-xml-get-children-fq (node child-name)
1700 "Return the children of NODE named CHILD-NAME.
1701This is the same as `xml-get-children1', but NODE's local
1702namespace is used to resolve the children's namespace tags."
1703 (let (result)
1704 (dolist (c (xml-node-children node))
1705 (when (and (consp c)
1706 (soap-with-local-xmlns node
1707 ;; We use `ignore-errors' here because we want to silently
1708 ;; skip nodes for which we cannot convert them to a
1709 ;; well-known name.
1710 (equal (ignore-errors
1711 (soap-l2fq (xml-node-name c)))
1712 child-name)))
1713 (push c result)))
1714 (nreverse result)))
1715
1716(defun soap-xs-element-get-fq-name (element wsdl)
1717 "Return ELEMENT's fully-qualified name using WSDL's alias table.
1718Return nil if ELEMENT does not have a name."
1719 (let* ((ns-aliases (soap-wsdl-alias-table wsdl))
1720 (ns-name (cdr (assoc
1721 (soap-element-namespace-tag element)
1722 ns-aliases))))
1723 (when ns-name
1724 (cons ns-name (soap-element-name element)))))
1725
1726(defun soap-xs-complex-type-optional-p (type)
1727 "Return t if TYPE or any of TYPE's ancestor types is optional.
1728Return nil otherwise."
1729 (when type
1730 (or (soap-xs-complex-type-optional? type)
1731 (and (soap-xs-complex-type-p type)
1732 (soap-xs-complex-type-optional-p
1733 (soap-xs-complex-type-base type))))))
1734
1735(defun soap-xs-complex-type-multiple-p (type)
1736 "Return t if TYPE or any of TYPE's ancestor types permits multiple elements.
1737Return nil otherwise."
1738 (when type
1739 (or (soap-xs-complex-type-multiple? type)
1740 (and (soap-xs-complex-type-p type)
1741 (soap-xs-complex-type-multiple-p
1742 (soap-xs-complex-type-base type))))))
1743
1744(defun soap-get-xs-attributes-from-groups (attribute-groups)
1745 "Return a list of attributes from all ATTRIBUTE-GROUPS."
1746 (let (attributes)
1747 (dolist (group attribute-groups)
1748 (let ((sub-groups (soap-xs-attribute-group-attribute-groups group)))
1749 (setq attributes (append attributes
1750 (soap-get-xs-attributes-from-groups sub-groups)
1751 (soap-xs-attribute-group-attributes group)))))
1752 attributes))
1753
1754(defun soap-get-xs-attributes (type)
1755 "Return a list of all of TYPE's and TYPE's ancestors' attributes."
1756 (let* ((base (and (soap-xs-complex-type-p type)
1757 (soap-xs-complex-type-base type)))
1758 (attributes (append (soap-xs-type-attributes type)
1759 (soap-get-xs-attributes-from-groups
1760 (soap-xs-type-attribute-groups type)))))
1761 (if base
1762 (append attributes (soap-get-xs-attributes base))
1763 attributes)))
1764
1765(defun soap-decode-xs-attributes (type node)
1766 "Use TYPE, a `soap-xs-complex-type', to decode the attributes of NODE."
1767 (let (result)
1768 (dolist (attribute (soap-get-xs-attributes type))
1769 (let* ((name (soap-xs-attribute-name attribute))
1770 (attribute-type (soap-xs-attribute-type attribute))
1771 (symbol (intern name))
1772 (value (xml-get-attribute-or-nil node symbol)))
1773 ;; We don't support attribute uses: required, optional, prohibited.
1774 (cond
1775 ((soap-xs-basic-type-p attribute-type)
1776 ;; Basic type values are validated by xml.el.
1777 (when value
1778 (push (cons symbol
1779 ;; Create a fake XML node to satisfy the
1780 ;; soap-decode-xs-basic-type API.
1781 (soap-decode-xs-basic-type attribute-type
1782 (list symbol nil value)))
1783 result)))
1784 ((soap-xs-simple-type-p attribute-type)
1785 (when value
1786 (push (cons symbol
1787 (soap-validate-xs-simple-type value attribute-type))
1788 result)))
1789 (t
1790 (error (concat "Attribute %s is of type %s which is"
1791 " not a basic or simple type")
1792 name (soap-name-p attribute))))))
1793 result))
1794
1795(defun soap-decode-xs-complex-type (type node)
1796 "Use TYPE, a `soap-xs-complex-type', to decode the contents of NODE.
1797A LISP value is returned based on the contents of NODE and the
1798type-info stored in TYPE.
1799
1800This is a specialization of `soap-decode-type' for
1801`soap-xs-basic-type' objects."
1802 (case (soap-xs-complex-type-indicator type)
1803 (array
1804 (let ((result nil)
1805 (element-type (soap-xs-complex-type-base type)))
1806 (dolist (node (xml-node-children node))
1807 (when (consp node)
1808 (push (soap-decode-type element-type node) result)))
1809 (nreverse result)))
1810 ((sequence choice all nil)
1811 (let ((result nil)
1812 (base (soap-xs-complex-type-base type)))
1813 (when base
1814 (setq result (nreverse (soap-decode-type base node))))
1815 (catch 'done
1816 (dolist (element (soap-xs-complex-type-elements type))
1817 (let* ((instance-count 0)
1818 (e-name (soap-xs-element-name element))
1819 ;; Heuristic: guess if we need to decode using local
1820 ;; namespaces.
1821 (use-fq-names (string-match ":" (symbol-name (car node))))
1822 (children (if e-name
1823 (if use-fq-names
1824 ;; Find relevant children
1825 ;; using local namespaces by
1826 ;; searching for the element's
1827 ;; fully-qualified name.
1828 (soap-xml-get-children-fq
1829 node
1830 (soap-xs-element-get-fq-name
1831 element soap-current-wsdl))
1832 ;; No local namespace resolution
1833 ;; needed so use the element's
1834 ;; name unqualified.
1835 (xml-get-children node (intern e-name)))
1836 ;; e-name is nil so a) we don't know which
1837 ;; children to operate on, and b) we want to
1838 ;; re-use soap-decode-xs-complex-type, which
1839 ;; expects a node argument with a complex
1840 ;; type; therefore we need to operate on the
1841 ;; entire node. We wrap node in a list so
1842 ;; that it will carry through as "node" in the
1843 ;; loop below.
1844 ;;
1845 ;; For example:
1846 ;;
1847 ;; Element Type:
1848 ;; <xs:complexType name="A">
1849 ;; <xs:sequence>
1850 ;; <xs:element name="B" type="t:BType"/>
1851 ;; <xs:choice>
1852 ;; <xs:element name="C" type="xs:string"/>
1853 ;; <xs:element name="D" type="t:DType"/>
1854 ;; </xs:choice>
1855 ;; </xs:sequence>
1856 ;; </xs:complexType>
1857 ;;
1858 ;; Node:
1859 ;; <t:A>
1860 ;; <t:B tag="b"/>
1861 ;; <t:C>1</C>
1862 ;; </t:A>
1863 ;;
1864 ;; soap-decode-type will be called below with:
1865 ;;
1866 ;; element =
1867 ;; <xs:choice>
1868 ;; <xs:element name="C" type="xs:string"/>
1869 ;; <xs:element name="D" type="t:DType"/>
1870 ;; </xs:choice>
1871 ;; node =
1872 ;; <t:A>
1873 ;; <t:B tag="b"/>
1874 ;; <t:C>1</C>
1875 ;; </t:A>
1876 (list node)))
1877 (element-type (soap-xs-element-type element)))
1878 (dolist (node children)
1879 (incf instance-count)
1880 (let* ((attributes
1881 (soap-decode-xs-attributes element-type node))
1882 ;; Attributes may specify xsi:type override.
1883 (element-type
1884 (if (soap-xml-get-attribute-or-nil1 node 'xsi:type)
1885 (soap-wsdl-get
1886 (soap-l2fq
1887 (soap-xml-get-attribute-or-nil1 node
1888 'xsi:type))
1889 soap-current-wsdl 'soap-xs-type-p t)
1890 element-type))
1891 (decoded-child (soap-decode-type element-type node)))
1892 (if e-name
1893 (push (cons (intern e-name)
1894 (append attributes decoded-child)) result)
1895 ;; When e-name is nil we don't want to introduce an extra
1896 ;; level of nesting, so we splice the decoding into
1897 ;; result.
1898 (setq result (append decoded-child result)))))
1899 (cond ((and (eq (soap-xs-complex-type-indicator type) 'choice)
1900 ;; Choices can allow multiple values.
1901 (not (soap-xs-complex-type-multiple-p type))
1902 (> instance-count 0))
1903 ;; This was a choice node, and we decoded one value.
1904 (throw 'done t))
1905
1906 ;; Do some sanity checking
1907 ((and (not (eq (soap-xs-complex-type-indicator type)
1908 'choice))
1909 (= instance-count 0)
1910 (not (soap-xs-element-optional? element))
1911 (and (soap-xs-complex-type-p element-type)
1912 (not (soap-xs-complex-type-optional-p
1913 element-type))))
1914 (soap-warning "missing non-nillable slot %s" e-name))
1915 ((and (> instance-count 1)
1916 (not (soap-xs-complex-type-multiple-p type))
1917 (not (soap-xs-element-multiple? element))
1918 (and (soap-xs-complex-type-p element-type)
1919 (not (soap-xs-complex-type-multiple-p
1920 element-type))))
1921 (soap-warning "expected single %s slot, found multiple"
1922 e-name))))))
1923 (nreverse result)))
1924 (t
1925 (error "Don't know how to decode complex type: %s"
1926 (soap-xs-complex-type-indicator type)))))
1927
1928;; Register methods for `soap-xs-complex-type'
1929(let ((tag (aref (make-soap-xs-complex-type) 0)))
1930 (put tag 'soap-resolve-references
1931 #'soap-resolve-references-for-xs-complex-type)
1932 (put tag 'soap-attribute-encoder #'soap-encode-xs-complex-type-attributes)
1933 (put tag 'soap-encoder #'soap-encode-xs-complex-type)
1934 (put tag 'soap-decoder #'soap-decode-xs-complex-type))
1935
1936;;;; WSDL documents
1937;;;;; WSDL document elements
1938
1939
388(defstruct (soap-message (:include soap-element)) 1940(defstruct (soap-message (:include soap-element))
389 parts ; ALIST of NAME => WSDL-TYPE name 1941 parts ; ALIST of NAME => WSDL-TYPE name
390 ) 1942 )
@@ -393,7 +1945,9 @@ binding) but the same name."
393 parameter-order 1945 parameter-order
394 input ; (NAME . MESSAGE) 1946 input ; (NAME . MESSAGE)
395 output ; (NAME . MESSAGE) 1947 output ; (NAME . MESSAGE)
396 faults) ; a list of (NAME . MESSAGE) 1948 faults ; a list of (NAME . MESSAGE)
1949 input-action ; WS-addressing action string
1950 output-action) ; WS-addressing action string
397 1951
398(defstruct (soap-port-type (:include soap-element)) 1952(defstruct (soap-port-type (:include soap-element))
399 operations) ; a namespace of operations 1953 operations) ; a namespace of operations
@@ -404,8 +1958,10 @@ binding) but the same name."
404(defstruct soap-bound-operation 1958(defstruct soap-bound-operation
405 operation ; SOAP-OPERATION 1959 operation ; SOAP-OPERATION
406 soap-action ; value for SOAPAction HTTP header 1960 soap-action ; value for SOAPAction HTTP header
1961 soap-headers ; list of (message part use)
1962 soap-body ; message parts present in the body
407 use ; 'literal or 'encoded, see 1963 use ; 'literal or 'encoded, see
408 ; http://www.w3.org/TR/wsdl#_soap:body 1964 ; http://www.w3.org/TR/wsdl#_soap:body
409 ) 1965 )
410 1966
411(defstruct (soap-binding (:include soap-element)) 1967(defstruct (soap-binding (:include soap-element))
@@ -416,49 +1972,49 @@ binding) but the same name."
416 service-url 1972 service-url
417 binding) 1973 binding)
418 1974
419(defun soap-default-xsd-types ()
420 "Return a namespace containing some of the XMLSchema types."
421 (let ((ns (make-soap-namespace :name "http://www.w3.org/2001/XMLSchema")))
422 (dolist (type '("string" "dateTime" "boolean"
423 "long" "int" "integer" "unsignedInt" "byte" "float" "double"
424 "base64Binary" "anyType" "anyURI" "Array" "byte[]"))
425 (soap-namespace-put
426 (make-soap-basic-type :name type :kind (intern type))
427 ns))
428 ns))
429
430(defun soap-default-soapenc-types ()
431 "Return a namespace containing some of the SOAPEnc types."
432 (let ((ns (make-soap-namespace
433 :name "http://schemas.xmlsoap.org/soap/encoding/")))
434 (dolist (type '("string" "dateTime" "boolean"
435 "long" "int" "integer" "unsignedInt" "byte" "float" "double"
436 "base64Binary" "anyType" "anyURI" "Array" "byte[]"))
437 (soap-namespace-put
438 (make-soap-basic-type :name type :kind (intern type))
439 ns))
440 ns))
441
442(defun soap-type-p (element)
443 "Return t if ELEMENT is a SOAP data type (basic or complex)."
444 (or (soap-basic-type-p element)
445 (soap-sequence-type-p element)
446 (soap-array-type-p element)))
447
448 1975
449;;;;; The WSDL document 1976;;;;; The WSDL document
450 1977
451;; The WSDL data structure used for encoding/decoding SOAP messages 1978;; The WSDL data structure used for encoding/decoding SOAP messages
452(defstruct soap-wsdl 1979(defstruct (soap-wsdl
1980 ;; NOTE: don't call this constructor, see `soap-make-wsdl'
1981 (:constructor soap-make-wsdl^)
1982 (:copier soap-copy-wsdl))
453 origin ; file or URL from which this wsdl was loaded 1983 origin ; file or URL from which this wsdl was loaded
1984 current-file ; most-recently fetched file or URL
1985 xmlschema-imports ; a list of schema imports
454 ports ; a list of SOAP-PORT instances 1986 ports ; a list of SOAP-PORT instances
455 alias-table ; a list of namespace aliases 1987 alias-table ; a list of namespace aliases
456 namespaces ; a list of namespaces 1988 namespaces ; a list of namespaces
457 ) 1989 )
458 1990
1991(defun soap-make-wsdl (origin)
1992 "Create a new WSDL document, loaded from ORIGIN, and intialize it."
1993 (let ((wsdl (soap-make-wsdl^ :origin origin)))
1994
1995 ;; Add the XSD types to the wsdl document
1996 (let ((ns (soap-make-xs-basic-types
1997 "http://www.w3.org/2001/XMLSchema" "xsd")))
1998 (soap-wsdl-add-namespace ns wsdl)
1999 (soap-wsdl-add-alias "xsd" (soap-namespace-name ns) wsdl))
2000
2001 ;; Add the soapenc types to the wsdl document
2002 (let ((ns (soap-make-xs-basic-types
2003 "http://schemas.xmlsoap.org/soap/encoding/" "soapenc")))
2004 (soap-wsdl-add-namespace ns wsdl)
2005 (soap-wsdl-add-alias "soapenc" (soap-namespace-name ns) wsdl))
2006
2007 wsdl))
2008
459(defun soap-wsdl-add-alias (alias name wsdl) 2009(defun soap-wsdl-add-alias (alias name wsdl)
460 "Add a namespace ALIAS for NAME to the WSDL document." 2010 "Add a namespace ALIAS for NAME to the WSDL document."
461 (push (cons alias name) (soap-wsdl-alias-table wsdl))) 2011 (let ((existing (assoc alias (soap-wsdl-alias-table wsdl))))
2012 (if existing
2013 (unless (equal (cdr existing) name)
2014 (warn "Redefining alias %s from %s to %s"
2015 alias (cdr existing) name)
2016 (push (cons alias name) (soap-wsdl-alias-table wsdl)))
2017 (push (cons alias name) (soap-wsdl-alias-table wsdl)))))
462 2018
463(defun soap-wsdl-find-namespace (name wsdl) 2019(defun soap-wsdl-find-namespace (name wsdl)
464 "Find a namespace by NAME in the WSDL document." 2020 "Find a namespace by NAME in the WSDL document."
@@ -474,11 +2030,11 @@ elements will be added to it."
474 (let ((existing (soap-wsdl-find-namespace (soap-namespace-name ns) wsdl))) 2030 (let ((existing (soap-wsdl-find-namespace (soap-namespace-name ns) wsdl)))
475 (if existing 2031 (if existing
476 ;; Add elements from NS to EXISTING, replacing existing values. 2032 ;; Add elements from NS to EXISTING, replacing existing values.
477 (maphash (lambda (key value) 2033 (maphash (lambda (_key value)
478 (dolist (v value) 2034 (dolist (v value)
479 (soap-namespace-put v existing))) 2035 (soap-namespace-put v existing)))
480 (soap-namespace-elements ns)) 2036 (soap-namespace-elements ns))
481 (push ns (soap-wsdl-namespaces wsdl))))) 2037 (push ns (soap-wsdl-namespaces wsdl)))))
482 2038
483(defun soap-wsdl-get (name wsdl &optional predicate use-local-alias-table) 2039(defun soap-wsdl-get (name wsdl &optional predicate use-local-alias-table)
484 "Retrieve element NAME from the WSDL document. 2040 "Retrieve element NAME from the WSDL document.
@@ -517,13 +2073,13 @@ used to resolve the namespace alias."
517 (ns-name (cdr (assoc ns-alias alias-table)))) 2073 (ns-name (cdr (assoc ns-alias alias-table))))
518 (unless ns-name 2074 (unless ns-name
519 (error "Soap-wsdl-get(%s): cannot find namespace alias %s" 2075 (error "Soap-wsdl-get(%s): cannot find namespace alias %s"
520 name ns-alias)) 2076 name ns-alias))
521 2077
522 (setq namespace (soap-wsdl-find-namespace ns-name wsdl)) 2078 (setq namespace (soap-wsdl-find-namespace ns-name wsdl))
523 (unless namespace 2079 (unless namespace
524 (error 2080 (error
525 "Soap-wsdl-get(%s): unknown namespace %s, referenced by alias %s" 2081 "Soap-wsdl-get(%s): unknown namespace %s, referenced as %s"
526 name ns-name ns-alias)))) 2082 name ns-name ns-alias))))
527 (t 2083 (t
528 (error "Soap-wsdl-get(%s): bad name" name))) 2084 (error "Soap-wsdl-get(%s): bad name" name)))
529 2085
@@ -533,7 +2089,7 @@ used to resolve the namespace alias."
533 (lambda (e) 2089 (lambda (e)
534 (or (funcall 'soap-namespace-link-p e) 2090 (or (funcall 'soap-namespace-link-p e)
535 (funcall predicate e))) 2091 (funcall predicate e)))
536 nil))) 2092 nil)))
537 2093
538 (unless element 2094 (unless element
539 (error "Soap-wsdl-get(%s): cannot find element" name)) 2095 (error "Soap-wsdl-get(%s): cannot find element" name))
@@ -541,92 +2097,96 @@ used to resolve the namespace alias."
541 (if (soap-namespace-link-p element) 2097 (if (soap-namespace-link-p element)
542 ;; NOTE: don't use the local alias table here 2098 ;; NOTE: don't use the local alias table here
543 (soap-wsdl-get (soap-namespace-link-target element) wsdl predicate) 2099 (soap-wsdl-get (soap-namespace-link-target element) wsdl predicate)
544 element))) 2100 element)))
2101
2102;;;;; soap-parse-schema
2103
2104(defun soap-parse-schema (node wsdl)
2105 "Parse a schema NODE, placing the results in WSDL.
2106Return a SOAP-NAMESPACE containing the elements."
2107 (soap-with-local-xmlns node
2108 (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:schema)
2109 nil
2110 "expecting an xsd:schema node, got %s"
2111 (soap-l2wk (xml-node-name node)))
2112
2113 (let ((ns (make-soap-namespace :name (soap-get-target-namespace node))))
2114
2115 (dolist (def (xml-node-children node))
2116 (unless (stringp def) ; skip text nodes
2117 (case (soap-l2wk (xml-node-name def))
2118 (xsd:import
2119 ;; Imports will be processed later
2120 ;; NOTE: we should expand the location now!
2121 (let ((location (or
2122 (xml-get-attribute-or-nil def 'schemaLocation)
2123 (xml-get-attribute-or-nil def 'location))))
2124 (when location
2125 (push location (soap-wsdl-xmlschema-imports wsdl)))))
2126 (xsd:element
2127 (soap-namespace-put (soap-xs-parse-element def) ns))
2128 (xsd:attribute
2129 (soap-namespace-put (soap-xs-parse-attribute def) ns))
2130 (xsd:attributeGroup
2131 (soap-namespace-put (soap-xs-parse-attribute-group def) ns))
2132 (xsd:simpleType
2133 (soap-namespace-put (soap-xs-parse-simple-type def) ns))
2134 ((xsd:complexType xsd:group)
2135 (soap-namespace-put (soap-xs-parse-complex-type def) ns)))))
2136 ns)))
545 2137
546;;;;; Resolving references for wsdl types 2138;;;;; Resolving references for wsdl types
547 2139
548;; See `soap-wsdl-resolve-references', which is the main entry point for 2140;; See `soap-wsdl-resolve-references', which is the main entry point for
549;; resolving references 2141;; resolving references
550 2142
551(defun soap-resolve-references-for-element (element wsdl) 2143(defun soap-resolve-references (element wsdl)
552 "Resolve references in ELEMENT using the WSDL document. 2144 "Replace names in ELEMENT with the referenced objects in the WSDL.
553This is a generic function which invokes a specific function 2145This is a generic function which invokes a specific resolver
554depending on the element type. 2146function depending on the type of the ELEMENT.
555 2147
556If ELEMENT has no resolver function, it is silently ignored. 2148If ELEMENT has no resolver function, it is silently ignored."
557
558All references are resolved in-place, that is the ELEMENT is
559updated."
560 (let ((resolver (get (aref element 0) 'soap-resolve-references))) 2149 (let ((resolver (get (aref element 0) 'soap-resolve-references)))
561 (when resolver 2150 (when resolver
562 (funcall resolver element wsdl)))) 2151 (funcall resolver element wsdl))))
563 2152
564(defun soap-resolve-references-for-simple-type (type wsdl)
565 "Resolve the base type for the simple TYPE using the WSDL
566 document."
567 (let ((kind (soap-basic-type-kind type)))
568 (unless (symbolp kind)
569 (let ((basic-type (soap-wsdl-get kind wsdl 'soap-basic-type-p)))
570 (setf (soap-basic-type-kind type)
571 (soap-basic-type-kind basic-type))))))
572
573(defun soap-resolve-references-for-sequence-type (type wsdl)
574 "Resolve references for a sequence TYPE using WSDL document.
575See also `soap-resolve-references-for-element' and
576`soap-wsdl-resolve-references'"
577 (let ((parent (soap-sequence-type-parent type)))
578 (when (or (consp parent) (stringp parent))
579 (setf (soap-sequence-type-parent type)
580 (soap-wsdl-get
581 parent wsdl
582 ;; Prevent self references, see Bug#9
583 (lambda (e) (and (not (eq e type)) (soap-type-p e)))))))
584 (dolist (element (soap-sequence-type-elements type))
585 (let ((element-type (soap-sequence-element-type element)))
586 (cond ((or (consp element-type) (stringp element-type))
587 (setf (soap-sequence-element-type element)
588 (soap-wsdl-get
589 element-type wsdl
590 ;; Prevent self references, see Bug#9
591 (lambda (e) (and (not (eq e type)) (soap-type-p e))))))
592 ((soap-element-p element-type)
593 ;; since the element already has a child element, it
594 ;; could be an inline structure. we must resolve
595 ;; references in it, because it might not be reached by
596 ;; scanning the wsdl names.
597 (soap-resolve-references-for-element element-type wsdl))))))
598
599(defun soap-resolve-references-for-array-type (type wsdl)
600 "Resolve references for an array TYPE using WSDL.
601See also `soap-resolve-references-for-element' and
602`soap-wsdl-resolve-references'"
603 (let ((element-type (soap-array-type-element-type type)))
604 (when (or (consp element-type) (stringp element-type))
605 (setf (soap-array-type-element-type type)
606 (soap-wsdl-get
607 element-type wsdl
608 ;; Prevent self references, see Bug#9
609 (lambda (e) (and (not (eq e type)) (soap-type-p e))))))))
610
611(defun soap-resolve-references-for-message (message wsdl) 2153(defun soap-resolve-references-for-message (message wsdl)
612 "Resolve references for a MESSAGE type using the WSDL document. 2154 "Replace names in MESSAGE with the referenced objects in the WSDL.
613See also `soap-resolve-references-for-element' and 2155This is a generic function, called by `soap-resolve-references',
614`soap-wsdl-resolve-references'" 2156you should use that function instead.
2157
2158See also `soap-wsdl-resolve-references'."
615 (let (resolved-parts) 2159 (let (resolved-parts)
616 (dolist (part (soap-message-parts message)) 2160 (dolist (part (soap-message-parts message))
617 (let ((name (car part)) 2161 (let ((name (car part))
618 (type (cdr part))) 2162 (element (cdr part)))
619 (when (stringp name) 2163 (when (stringp name)
620 (setq name (intern name))) 2164 (setq name (intern name)))
621 (when (or (consp type) (stringp type)) 2165 (if (soap-name-p element)
622 (setq type (soap-wsdl-get type wsdl 'soap-type-p))) 2166 (setq element (soap-wsdl-get
623 (push (cons name type) resolved-parts))) 2167 element wsdl
624 (setf (soap-message-parts message) (nreverse resolved-parts)))) 2168 (lambda (x)
2169 (or (soap-xs-type-p x) (soap-xs-element-p x)))))
2170 ;; else, inline element, resolve recursively, as the element
2171 ;; won't be reached.
2172 (soap-resolve-references element wsdl)
2173 (unless (soap-element-namespace-tag element)
2174 (setf (soap-element-namespace-tag element)
2175 (soap-element-namespace-tag message))))
2176 (push (cons name element) resolved-parts)))
2177 (setf (soap-message-parts message) (nreverse resolved-parts))))
625 2178
626(defun soap-resolve-references-for-operation (operation wsdl) 2179(defun soap-resolve-references-for-operation (operation wsdl)
627 "Resolve references for an OPERATION type using the WSDL document. 2180 "Resolve references for an OPERATION type using the WSDL document.
628See also `soap-resolve-references-for-element' and 2181See also `soap-resolve-references' and
629`soap-wsdl-resolve-references'" 2182`soap-wsdl-resolve-references'"
2183
2184 (let ((namespace (soap-element-namespace-tag operation)))
2185 (when namespace
2186 (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl)))))
2187 (when nstag
2188 (setf (soap-element-namespace-tag operation) nstag)))))
2189
630 (let ((input (soap-operation-input operation)) 2190 (let ((input (soap-operation-input operation))
631 (counter 0)) 2191 (counter 0))
632 (let ((name (car input)) 2192 (let ((name (car input))
@@ -634,10 +2194,10 @@ See also `soap-resolve-references-for-element' and
634 ;; Name this part if it was not named 2194 ;; Name this part if it was not named
635 (when (or (null name) (equal name "")) 2195 (when (or (null name) (equal name ""))
636 (setq name (format "in%d" (incf counter)))) 2196 (setq name (format "in%d" (incf counter))))
637 (when (or (consp message) (stringp message)) 2197 (when (soap-name-p message)
638 (setf (soap-operation-input operation) 2198 (setf (soap-operation-input operation)
639 (cons (intern name) 2199 (cons (intern name)
640 (soap-wsdl-get message wsdl 'soap-message-p)))))) 2200 (soap-wsdl-get message wsdl 'soap-message-p))))))
641 2201
642 (let ((output (soap-operation-output operation)) 2202 (let ((output (soap-operation-output operation))
643 (counter 0)) 2203 (counter 0))
@@ -645,10 +2205,10 @@ See also `soap-resolve-references-for-element' and
645 (message (cdr output))) 2205 (message (cdr output)))
646 (when (or (null name) (equal name "")) 2206 (when (or (null name) (equal name ""))
647 (setq name (format "out%d" (incf counter)))) 2207 (setq name (format "out%d" (incf counter))))
648 (when (or (consp message) (stringp message)) 2208 (when (soap-name-p message)
649 (setf (soap-operation-output operation) 2209 (setf (soap-operation-output operation)
650 (cons (intern name) 2210 (cons (intern name)
651 (soap-wsdl-get message wsdl 'soap-message-p)))))) 2211 (soap-wsdl-get message wsdl 'soap-message-p))))))
652 2212
653 (let ((resolved-faults nil) 2213 (let ((resolved-faults nil)
654 (counter 0)) 2214 (counter 0))
@@ -657,11 +2217,11 @@ See also `soap-resolve-references-for-element' and
657 (message (cdr fault))) 2217 (message (cdr fault)))
658 (when (or (null name) (equal name "")) 2218 (when (or (null name) (equal name ""))
659 (setq name (format "fault%d" (incf counter)))) 2219 (setq name (format "fault%d" (incf counter))))
660 (if (or (consp message) (stringp message)) 2220 (if (soap-name-p message)
661 (push (cons (intern name) 2221 (push (cons (intern name)
662 (soap-wsdl-get message wsdl 'soap-message-p)) 2222 (soap-wsdl-get message wsdl 'soap-message-p))
663 resolved-faults) 2223 resolved-faults)
664 (push fault resolved-faults)))) 2224 (push fault resolved-faults))))
665 (setf (soap-operation-faults operation) resolved-faults)) 2225 (setf (soap-operation-faults operation) resolved-faults))
666 2226
667 (when (= (length (soap-operation-parameter-order operation)) 0) 2227 (when (= (length (soap-operation-parameter-order operation)) 0)
@@ -673,42 +2233,44 @@ See also `soap-resolve-references-for-element' and
673 (mapcar (lambda (p) 2233 (mapcar (lambda (p)
674 (if (stringp p) 2234 (if (stringp p)
675 (intern p) 2235 (intern p)
676 p)) 2236 p))
677 (soap-operation-parameter-order operation)))) 2237 (soap-operation-parameter-order operation))))
678 2238
679(defun soap-resolve-references-for-binding (binding wsdl) 2239(defun soap-resolve-references-for-binding (binding wsdl)
680 "Resolve references for a BINDING type using the WSDL document. 2240 "Resolve references for a BINDING type using the WSDL document.
681See also `soap-resolve-references-for-element' and 2241See also `soap-resolve-references' and
682`soap-wsdl-resolve-references'" 2242`soap-wsdl-resolve-references'"
683 (when (or (consp (soap-binding-port-type binding)) 2243 (when (soap-name-p (soap-binding-port-type binding))
684 (stringp (soap-binding-port-type binding)))
685 (setf (soap-binding-port-type binding) 2244 (setf (soap-binding-port-type binding)
686 (soap-wsdl-get (soap-binding-port-type binding) 2245 (soap-wsdl-get (soap-binding-port-type binding)
687 wsdl 'soap-port-type-p))) 2246 wsdl 'soap-port-type-p)))
688 2247
689 (let ((port-ops (soap-port-type-operations (soap-binding-port-type binding)))) 2248 (let ((port-ops (soap-port-type-operations (soap-binding-port-type binding))))
690 (maphash (lambda (k v) 2249 (maphash (lambda (k v)
691 (setf (soap-bound-operation-operation v) 2250 (setf (soap-bound-operation-operation v)
692 (soap-namespace-get k port-ops 'soap-operation-p))) 2251 (soap-namespace-get k port-ops 'soap-operation-p))
2252 (let (resolved-headers)
2253 (dolist (h (soap-bound-operation-soap-headers v))
2254 (push (list (soap-wsdl-get (nth 0 h) wsdl)
2255 (intern (nth 1 h))
2256 (nth 2 h))
2257 resolved-headers))
2258 (setf (soap-bound-operation-soap-headers v)
2259 (nreverse resolved-headers))))
693 (soap-binding-operations binding)))) 2260 (soap-binding-operations binding))))
694 2261
695(defun soap-resolve-references-for-port (port wsdl) 2262(defun soap-resolve-references-for-port (port wsdl)
696 "Resolve references for a PORT type using the WSDL document. 2263 "Replace names in PORT with the referenced objects in the WSDL.
697See also `soap-resolve-references-for-element' and 2264This is a generic function, called by `soap-resolve-references',
698`soap-wsdl-resolve-references'" 2265you should use that function instead.
699 (when (or (consp (soap-port-binding port)) 2266
700 (stringp (soap-port-binding port))) 2267See also `soap-wsdl-resolve-references'."
2268 (when (soap-name-p (soap-port-binding port))
701 (setf (soap-port-binding port) 2269 (setf (soap-port-binding port)
702 (soap-wsdl-get (soap-port-binding port) wsdl 'soap-binding-p)))) 2270 (soap-wsdl-get (soap-port-binding port) wsdl 'soap-binding-p))))
703 2271
704;; Install resolvers for our types 2272;; Install resolvers for our types
705(progn 2273(progn
706 (put (aref (make-soap-simple-type) 0) 'soap-resolve-references
707 'soap-resolve-references-for-simple-type)
708 (put (aref (make-soap-sequence-type) 0) 'soap-resolve-references
709 'soap-resolve-references-for-sequence-type)
710 (put (aref (make-soap-array-type) 0) 'soap-resolve-references
711 'soap-resolve-references-for-array-type)
712 (put (aref (make-soap-message) 0) 'soap-resolve-references 2274 (put (aref (make-soap-message) 0) 'soap-resolve-references
713 'soap-resolve-references-for-message) 2275 'soap-resolve-references-for-message)
714 (put (aref (make-soap-operation) 0) 'soap-resolve-references 2276 (put (aref (make-soap-operation) 0) 'soap-resolve-references
@@ -745,312 +2307,173 @@ traverse an element tree."
745 (soap-wsdl-add-alias nstag (soap-namespace-name ns) wsdl) 2307 (soap-wsdl-add-alias nstag (soap-namespace-name ns) wsdl)
746 (throw 'done t))))) 2308 (throw 'done t)))))
747 2309
748 (maphash (lambda (name element) 2310 (maphash (lambda (_name element)
749 (cond ((soap-element-p element) ; skip links 2311 (cond ((soap-element-p element) ; skip links
750 (incf nprocessed) 2312 (incf nprocessed)
751 (soap-resolve-references-for-element element wsdl) 2313 (soap-resolve-references element wsdl))
752 (setf (soap-element-namespace-tag element) nstag))
753 ((listp element) 2314 ((listp element)
754 (dolist (e element) 2315 (dolist (e element)
755 (when (soap-element-p e) 2316 (when (soap-element-p e)
756 (incf nprocessed) 2317 (incf nprocessed)
757 (soap-resolve-references-for-element e wsdl) 2318 (soap-resolve-references e wsdl))))))
758 (setf (soap-element-namespace-tag e) nstag))))))
759 (soap-namespace-elements ns))))) 2319 (soap-namespace-elements ns)))))
760 wsdl) 2320 wsdl)
761 2321
762;;;;; Loading WSDL from XML documents 2322;;;;; Loading WSDL from XML documents
763 2323
764(defun soap-load-wsdl-from-url (url) 2324(defun soap-parse-server-response ()
765 "Load a WSDL document from URL and return it. 2325 "Error-check and parse the XML contents of the current buffer."
766The returned WSDL document needs to be used for `soap-invoke' 2326 (let ((mime-part (mm-dissect-buffer t t)))
767calls." 2327 (unless mime-part
768 (let ((url-request-method "GET") 2328 (error "Failed to decode response from server"))
2329 (unless (equal (car (mm-handle-type mime-part)) "text/xml")
2330 (error "Server response is not an XML document"))
2331 (with-temp-buffer
2332 (mm-insert-part mime-part)
2333 (prog1
2334 (car (xml-parse-region (point-min) (point-max)))
2335 (kill-buffer)
2336 (mm-destroy-part mime-part)))))
2337
2338(defun soap-fetch-xml-from-url (url wsdl)
2339 "Load an XML document from URL and return it.
2340The previously parsed URL is read from WSDL."
2341 (message "Fetching from %s" url)
2342 (let ((current-file (url-expand-file-name url (soap-wsdl-current-file wsdl)))
2343 (url-request-method "GET")
769 (url-package-name "soap-client.el") 2344 (url-package-name "soap-client.el")
770 (url-package-version "1.0") 2345 (url-package-version "1.0")
771 (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5") 2346 (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5")
772 (url-request-coding-system 'utf-8) 2347 (url-http-attempt-keepalives t))
773 (url-http-attempt-keepalives nil)) 2348 (setf (soap-wsdl-current-file wsdl) current-file)
774 (let ((buffer (url-retrieve-synchronously url))) 2349 (let ((buffer (url-retrieve-synchronously current-file)))
775 (with-current-buffer buffer 2350 (with-current-buffer buffer
776 (declare (special url-http-response-status)) 2351 (declare (special url-http-response-status))
777 (if (> url-http-response-status 299) 2352 (if (> url-http-response-status 299)
778 (error "Error retrieving WSDL: %s" url-http-response-status)) 2353 (error "Error retrieving WSDL: %s" url-http-response-status))
779 (let ((mime-part (mm-dissect-buffer t t))) 2354 (soap-parse-server-response)))))
780 (unless mime-part 2355
781 (error "Failed to decode response from server")) 2356(defun soap-fetch-xml-from-file (file wsdl)
782 (unless (equal (car (mm-handle-type mime-part)) "text/xml") 2357 "Load an XML document from FILE and return it.
783 (error "Server response is not an XML document")) 2358The previously parsed file is read from WSDL."
784 (with-temp-buffer 2359 (let* ((current-file (soap-wsdl-current-file wsdl))
785 (mm-insert-part mime-part) 2360 (expanded-file (expand-file-name file
786 (let ((wsdl-xml (car (xml-parse-region (point-min) (point-max))))) 2361 (if current-file
787 (prog1 2362 (file-name-directory current-file)
788 (let ((wsdl (soap-parse-wsdl wsdl-xml))) 2363 default-directory))))
789 (setf (soap-wsdl-origin wsdl) url) 2364 (setf (soap-wsdl-current-file wsdl) expanded-file)
790 wsdl) 2365 (with-temp-buffer
791 (kill-buffer buffer))))))))) 2366 (insert-file-contents expanded-file)
792 2367 (car (xml-parse-region (point-min) (point-max))))))
793(defun soap-load-wsdl (file) 2368
794 "Load a WSDL document from FILE and return it." 2369(defun soap-fetch-xml (file-or-url wsdl)
795 (with-temp-buffer 2370 "Load an XML document from FILE-OR-URL and return it.
796 (insert-file-contents file) 2371The previously parsed file or URL is read from WSDL."
797 (let ((xml (car (xml-parse-region (point-min) (point-max))))) 2372 (let ((current-file (or (soap-wsdl-current-file wsdl) file-or-url)))
798 (let ((wsdl (soap-parse-wsdl xml))) 2373 (if (or (and current-file (file-exists-p current-file))
799 (setf (soap-wsdl-origin wsdl) file) 2374 (file-exists-p file-or-url))
800 wsdl)))) 2375 (soap-fetch-xml-from-file file-or-url wsdl)
801 2376 (soap-fetch-xml-from-url file-or-url wsdl))))
802(defun soap-parse-wsdl (node) 2377
803 "Construct a WSDL structure from NODE, which is an XML document." 2378(defun soap-load-wsdl (file-or-url &optional wsdl)
2379 "Load a document from FILE-OR-URL and return it.
2380Build on WSDL if it is provided."
2381 (let* ((wsdl (or wsdl (soap-make-wsdl file-or-url)))
2382 (xml (soap-fetch-xml file-or-url wsdl)))
2383 (soap-wsdl-resolve-references (soap-parse-wsdl xml wsdl))
2384 wsdl))
2385
2386(defalias 'soap-load-wsdl-from-url 'soap-load-wsdl)
2387
2388(defun soap-parse-wsdl-phase-validate-node (node)
2389 "Assert that NODE is valid."
804 (soap-with-local-xmlns node 2390 (soap-with-local-xmlns node
2391 (let ((node-name (soap-l2wk (xml-node-name node))))
2392 (assert (eq node-name 'wsdl:definitions)
2393 nil
2394 "expecting wsdl:definitions node, got %s" node-name))))
805 2395
806 (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:definitions) 2396(defun soap-parse-wsdl-phase-fetch-imports (node wsdl)
807 nil 2397 "Fetch and load files imported by NODE into WSDL."
808 "soap-parse-wsdl: expecting wsdl:definitions node, got %s"
809 (soap-l2wk (xml-node-name node)))
810
811 (let ((wsdl (make-soap-wsdl)))
812
813 ;; Add the local alias table to the wsdl document -- it will be used for
814 ;; all types in this document even after we finish parsing it.
815 (setf (soap-wsdl-alias-table wsdl) soap-local-xmlns)
816
817 ;; Add the XSD types to the wsdl document
818 (let ((ns (soap-default-xsd-types)))
819 (soap-wsdl-add-namespace ns wsdl)
820 (soap-wsdl-add-alias "xsd" (soap-namespace-name ns) wsdl))
821
822 ;; Add the soapenc types to the wsdl document
823 (let ((ns (soap-default-soapenc-types)))
824 (soap-wsdl-add-namespace ns wsdl)
825 (soap-wsdl-add-alias "soapenc" (soap-namespace-name ns) wsdl))
826
827 ;; Find all the 'xsd:schema nodes which are children of wsdl:types nodes
828 ;; and build our type-library
829
830 (let ((types (car (soap-xml-get-children1 node 'wsdl:types))))
831 (dolist (node (xml-node-children types))
832 ;; We cannot use (xml-get-children node (soap-wk2l 'xsd:schema))
833 ;; because each node can install its own alias type so the schema
834 ;; nodes might have a different prefix.
835 (when (consp node)
836 (soap-with-local-xmlns node
837 (when (eq (soap-l2wk (xml-node-name node)) 'xsd:schema)
838 (soap-wsdl-add-namespace (soap-parse-schema node) wsdl))))))
839
840 (let ((ns (make-soap-namespace :name (soap-get-target-namespace node))))
841 (dolist (node (soap-xml-get-children1 node 'wsdl:message))
842 (soap-namespace-put (soap-parse-message node) ns))
843
844 (dolist (node (soap-xml-get-children1 node 'wsdl:portType))
845 (let ((port-type (soap-parse-port-type node)))
846 (soap-namespace-put port-type ns)
847 (soap-wsdl-add-namespace
848 (soap-port-type-operations port-type) wsdl)))
849
850 (dolist (node (soap-xml-get-children1 node 'wsdl:binding))
851 (soap-namespace-put (soap-parse-binding node) ns))
852
853 (dolist (node (soap-xml-get-children1 node 'wsdl:service))
854 (dolist (node (soap-xml-get-children1 node 'wsdl:port))
855 (let ((name (xml-get-attribute node 'name))
856 (binding (xml-get-attribute node 'binding))
857 (url (let ((n (car (soap-xml-get-children1
858 node 'wsdlsoap:address))))
859 (xml-get-attribute n 'location))))
860 (let ((port (make-soap-port
861 :name name :binding (soap-l2fq binding 'tns)
862 :service-url url)))
863 (soap-namespace-put port ns)
864 (push port (soap-wsdl-ports wsdl))))))
865
866 (soap-wsdl-add-namespace ns wsdl))
867
868 (soap-wsdl-resolve-references wsdl)
869
870 wsdl)))
871
872(defun soap-parse-schema (node)
873 "Parse a schema NODE.
874Return a SOAP-NAMESPACE containing the elements."
875 (soap-with-local-xmlns node 2398 (soap-with-local-xmlns node
876 (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:schema) 2399 (dolist (node (soap-xml-get-children1 node 'wsdl:import))
877 nil 2400 (let ((location (xml-get-attribute-or-nil node 'location)))
878 "soap-parse-schema: expecting an xsd:schema node, got %s" 2401 (when location
879 (soap-l2wk (xml-node-name node))) 2402 (soap-load-wsdl location wsdl))))))
880 (let ((ns (make-soap-namespace :name (soap-get-target-namespace node))))
881 ;; NOTE: we only extract the complexTypes from the schema, we wouldn't
882 ;; know how to handle basic types beyond the built in ones anyway.
883 (dolist (node (soap-xml-get-children1 node 'xsd:simpleType))
884 (soap-namespace-put (soap-parse-simple-type node) ns))
885
886 (dolist (node (soap-xml-get-children1 node 'xsd:complexType))
887 (soap-namespace-put (soap-parse-complex-type node) ns))
888 2403
889 (dolist (node (soap-xml-get-children1 node 'xsd:element)) 2404(defun soap-parse-wsdl-phase-parse-schema (node wsdl)
890 (soap-namespace-put (soap-parse-schema-element node) ns)) 2405 "Load types found in NODE into WSDL."
891 2406 (soap-with-local-xmlns node
892 ns))) 2407 ;; Find all the 'xsd:schema nodes which are children of wsdl:types nodes and
893 2408 ;; build our type-library.
894(defun soap-parse-simple-type (node) 2409 (let ((types (car (soap-xml-get-children1 node 'wsdl:types))))
895 "Parse NODE and construct a simple type from it." 2410 (dolist (node (xml-node-children types))
896 (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:simpleType) 2411 ;; We cannot use (xml-get-children node (soap-wk2l 'xsd:schema)) because
897 nil 2412 ;; each node can install its own alias type so the schema nodes might
898 "soap-parse-complex-type: expecting xsd:simpleType node, got %s" 2413 ;; have a different prefix.
899 (soap-l2wk (xml-node-name node))) 2414 (when (consp node)
900 (let ((name (xml-get-attribute-or-nil node 'name)) 2415 (soap-with-local-xmlns
901 type 2416 node
902 enumeration 2417 (when (eq (soap-l2wk (xml-node-name node)) 'xsd:schema)
903 (restriction (car-safe 2418 (soap-wsdl-add-namespace (soap-parse-schema node wsdl)
904 (soap-xml-get-children1 node 'xsd:restriction)))) 2419 wsdl))))))))
905 (unless restriction 2420
906 (error "simpleType %s has no base type" name)) 2421(defun soap-parse-wsdl-phase-fetch-schema (node wsdl)
907 2422 "Fetch and load schema imports defined by NODE into WSDL."
908 (setq type (xml-get-attribute-or-nil restriction 'base)) 2423 (soap-with-local-xmlns node
909 (dolist (e (soap-xml-get-children1 restriction 'xsd:enumeration)) 2424 (while (soap-wsdl-xmlschema-imports wsdl)
910 (push (xml-get-attribute e 'value) enumeration)) 2425 (let* ((import (pop (soap-wsdl-xmlschema-imports wsdl)))
911 2426 (xml (soap-fetch-xml import wsdl)))
912 (make-soap-simple-type :name name :kind type :enumeration enumeration))) 2427 (soap-wsdl-add-namespace (soap-parse-schema xml wsdl) wsdl)))))
913
914(defun soap-parse-schema-element (node)
915 "Parse NODE and construct a schema element from it."
916 (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:element)
917 nil
918 "soap-parse-schema-element: expecting xsd:element node, got %s"
919 (soap-l2wk (xml-node-name node)))
920 (let ((name (xml-get-attribute-or-nil node 'name))
921 type)
922 ;; A schema element that contains an inline complex type --
923 ;; construct the actual complex type for it.
924 (let ((type-node (soap-xml-get-children1 node 'xsd:complexType)))
925 (when (> (length type-node) 0)
926 (assert (= (length type-node) 1)) ; only one complex type
927 ; definition per element
928 (setq type (soap-parse-complex-type (car type-node)))))
929 (setf (soap-element-name type) name)
930 type))
931
932(defun soap-parse-complex-type (node)
933 "Parse NODE and construct a complex type from it."
934 (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:complexType)
935 nil
936 "soap-parse-complex-type: expecting xsd:complexType node, got %s"
937 (soap-l2wk (xml-node-name node)))
938 (let ((name (xml-get-attribute-or-nil node 'name))
939 ;; Use a dummy type for the complex type, it will be replaced
940 ;; with the real type below, except when the complex type node
941 ;; is empty...
942 (type (make-soap-sequence-type :elements nil)))
943 (dolist (c (xml-node-children node))
944 (when (consp c) ; skip string nodes, which are whitespace
945 (let ((node-name (soap-l2wk (xml-node-name c))))
946 (cond
947 ;; The difference between xsd:all and xsd:sequence is that fields
948 ;; in xsd:all are not ordered and they can occur only once. We
949 ;; don't care about that difference in soap-client.el
950 ((or (eq node-name 'xsd:sequence)
951 (eq node-name 'xsd:all))
952 (setq type (soap-parse-complex-type-sequence c)))
953 ((eq node-name 'xsd:complexContent)
954 (setq type (soap-parse-complex-type-complex-content c)))
955 ((eq node-name 'xsd:attribute)
956 ;; The name of this node comes from an attribute tag
957 (let ((n (xml-get-attribute-or-nil c 'name)))
958 (setq name n)))
959 (t
960 (error "Unknown node type %s" node-name))))))
961 (setf (soap-element-name type) name)
962 type))
963
964(defun soap-parse-sequence (node)
965 "Parse NODE and a list of sequence elements that it defines.
966NODE is assumed to be an xsd:sequence node. In that case, each
967of its children is assumed to be a sequence element. Each
968sequence element is parsed constructing the corresponding type.
969A list of these types is returned."
970 (assert (let ((n (soap-l2wk (xml-node-name node))))
971 (memq n '(xsd:sequence xsd:all)))
972 nil
973 "soap-parse-sequence: expecting xsd:sequence or xsd:all node, got %s"
974 (soap-l2wk (xml-node-name node)))
975 (let (elements)
976 (dolist (e (soap-xml-get-children1 node 'xsd:element))
977 (let ((name (xml-get-attribute-or-nil e 'name))
978 (type (xml-get-attribute-or-nil e 'type))
979 (nillable? (or (equal (xml-get-attribute-or-nil e 'nillable) "true")
980 (let ((e (xml-get-attribute-or-nil e 'minOccurs)))
981 (and e (equal e "0")))))
982 (multiple? (let ((e (xml-get-attribute-or-nil e 'maxOccurs)))
983 (and e (not (equal e "1"))))))
984 (if type
985 (setq type (soap-l2fq type 'tns))
986
987 ;; The node does not have a type, maybe it has a complexType
988 ;; defined inline...
989 (let ((type-node (soap-xml-get-children1 e 'xsd:complexType)))
990 (when (> (length type-node) 0)
991 (assert (= (length type-node) 1)
992 nil
993 "only one complex type definition per element supported")
994 (setq type (soap-parse-complex-type (car type-node))))))
995
996 (push (make-soap-sequence-element
997 :name (intern name) :type type :nillable? nillable?
998 :multiple? multiple?)
999 elements)))
1000 (nreverse elements)))
1001
1002(defun soap-parse-complex-type-sequence (node)
1003 "Parse NODE as a sequence type."
1004 (let ((elements (soap-parse-sequence node)))
1005 (make-soap-sequence-type :elements elements)))
1006
1007(defun soap-parse-complex-type-complex-content (node)
1008 "Parse NODE as a xsd:complexContent node.
1009A sequence or an array type is returned depending on the actual
1010contents."
1011 (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:complexContent)
1012 nil
1013 "soap-parse-complex-type-complex-content: expecting xsd:complexContent node, got %s"
1014 (soap-l2wk (xml-node-name node)))
1015 (let (array? parent elements)
1016 (let ((extension (car-safe (soap-xml-get-children1 node 'xsd:extension)))
1017 (restriction (car-safe
1018 (soap-xml-get-children1 node 'xsd:restriction))))
1019 ;; a complex content node is either an extension or a restriction
1020 (cond (extension
1021 (setq parent (xml-get-attribute-or-nil extension 'base))
1022 (setq elements (soap-parse-sequence
1023 (car (soap-xml-get-children1
1024 extension 'xsd:sequence)))))
1025 (restriction
1026 (let ((base (xml-get-attribute-or-nil restriction 'base)))
1027 (assert (equal base (soap-wk2l "soapenc:Array"))
1028 nil
1029 "restrictions supported only for soapenc:Array types, this is a %s"
1030 base))
1031 (setq array? t)
1032 (let ((attribute (car (soap-xml-get-children1
1033 restriction 'xsd:attribute))))
1034 (let ((array-type (soap-xml-get-attribute-or-nil1
1035 attribute 'wsdl:arrayType)))
1036 (when (string-match "^\\(.*\\)\\[\\]$" array-type)
1037 (setq parent (match-string 1 array-type))))))
1038
1039 (t
1040 (error "Unknown complex type"))))
1041
1042 (if parent
1043 (setq parent (soap-l2fq parent 'tns)))
1044 2428
1045 (if array? 2429(defun soap-parse-wsdl-phase-finish-parsing (node wsdl)
1046 (make-soap-array-type :element-type parent) 2430 "Finish parsing NODE into WSDL."
1047 (make-soap-sequence-type :parent parent :elements elements)))) 2431 (soap-with-local-xmlns node
2432 (let ((ns (make-soap-namespace :name (soap-get-target-namespace node))))
2433 (dolist (node (soap-xml-get-children1 node 'wsdl:message))
2434 (soap-namespace-put (soap-parse-message node) ns))
2435
2436 (dolist (node (soap-xml-get-children1 node 'wsdl:portType))
2437 (let ((port-type (soap-parse-port-type node)))
2438 (soap-namespace-put port-type ns)
2439 (soap-wsdl-add-namespace
2440 (soap-port-type-operations port-type) wsdl)))
2441
2442 (dolist (node (soap-xml-get-children1 node 'wsdl:binding))
2443 (soap-namespace-put (soap-parse-binding node) ns))
2444
2445 (dolist (node (soap-xml-get-children1 node 'wsdl:service))
2446 (dolist (node (soap-xml-get-children1 node 'wsdl:port))
2447 (let ((name (xml-get-attribute node 'name))
2448 (binding (xml-get-attribute node 'binding))
2449 (url (let ((n (car (soap-xml-get-children1
2450 node 'wsdlsoap:address))))
2451 (xml-get-attribute n 'location))))
2452 (let ((port (make-soap-port
2453 :name name :binding (soap-l2fq binding 'tns)
2454 :service-url url)))
2455 (soap-namespace-put port ns)
2456 (push port (soap-wsdl-ports wsdl))))))
2457
2458 (soap-wsdl-add-namespace ns wsdl))))
2459
2460(defun soap-parse-wsdl (node wsdl)
2461 "Construct from NODE a WSDL structure, which is an XML document."
2462 ;; Break this into phases to allow for asynchronous parsing.
2463 (soap-parse-wsdl-phase-validate-node node)
2464 ;; Makes synchronous calls.
2465 (soap-parse-wsdl-phase-fetch-imports node wsdl)
2466 (soap-parse-wsdl-phase-parse-schema node wsdl)
2467 ;; Makes synchronous calls.
2468 (soap-parse-wsdl-phase-fetch-schema node wsdl)
2469 (soap-parse-wsdl-phase-finish-parsing node wsdl)
2470 wsdl)
1048 2471
1049(defun soap-parse-message (node) 2472(defun soap-parse-message (node)
1050 "Parse NODE as a wsdl:message and return the corresponding type." 2473 "Parse NODE as a wsdl:message and return the corresponding type."
1051 (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:message) 2474 (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:message)
1052 nil 2475 nil
1053 "soap-parse-message: expecting wsdl:message node, got %s" 2476 "expecting wsdl:message node, got %s"
1054 (soap-l2wk (xml-node-name node))) 2477 (soap-l2wk (xml-node-name node)))
1055 (let ((name (xml-get-attribute-or-nil node 'name)) 2478 (let ((name (xml-get-attribute-or-nil node 'name))
1056 parts) 2479 parts)
@@ -1062,97 +2485,111 @@ contents."
1062 (when type 2485 (when type
1063 (setq type (soap-l2fq type 'tns))) 2486 (setq type (soap-l2fq type 'tns)))
1064 2487
1065 (when element 2488 (if element
1066 (setq element (soap-l2fq element 'tns))) 2489 (setq element (soap-l2fq element 'tns))
2490 ;; else
2491 (setq element (make-soap-xs-element
2492 :name name
2493 :namespace-tag soap-target-xmlns
2494 :type^ type)))
1067 2495
1068 (push (cons name (or type element)) parts))) 2496 (push (cons name element) parts)))
1069 (make-soap-message :name name :parts (nreverse parts)))) 2497 (make-soap-message :name name :parts (nreverse parts))))
1070 2498
1071(defun soap-parse-port-type (node) 2499(defun soap-parse-port-type (node)
1072 "Parse NODE as a wsdl:portType and return the corresponding port." 2500 "Parse NODE as a wsdl:portType and return the corresponding port."
1073 (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:portType) 2501 (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:portType)
1074 nil 2502 nil
1075 "soap-parse-port-type: expecting wsdl:portType node got %s" 2503 "expecting wsdl:portType node got %s"
1076 (soap-l2wk (xml-node-name node))) 2504 (soap-l2wk (xml-node-name node)))
1077 (let ((ns (make-soap-namespace 2505 (let* ((soap-target-xmlns (concat "urn:" (xml-get-attribute node 'name)))
1078 :name (concat "urn:" (xml-get-attribute node 'name))))) 2506 (ns (make-soap-namespace :name soap-target-xmlns)))
1079 (dolist (node (soap-xml-get-children1 node 'wsdl:operation)) 2507 (dolist (node (soap-xml-get-children1 node 'wsdl:operation))
1080 (let ((o (soap-parse-operation node))) 2508 (let ((o (soap-parse-operation node)))
1081 2509
1082 (let ((other-operation (soap-namespace-get 2510 (let ((other-operation (soap-namespace-get
1083 (soap-element-name o) ns 'soap-operation-p))) 2511 (soap-element-name o) ns 'soap-operation-p)))
1084 (if other-operation 2512 (if other-operation
1085 ;; Unfortunately, the Confluence WSDL defines two operations 2513 ;; Unfortunately, the Confluence WSDL defines two operations
1086 ;; named "search" which differ only in parameter names... 2514 ;; named "search" which differ only in parameter names...
1087 (soap-warning "Discarding duplicate operation: %s" 2515 (soap-warning "Discarding duplicate operation: %s"
1088 (soap-element-name o)) 2516 (soap-element-name o))
1089 2517
1090 (progn 2518 (progn
1091 (soap-namespace-put o ns) 2519 (soap-namespace-put o ns)
1092 2520
1093 ;; link all messages from this namespace, as this namespace 2521 ;; link all messages from this namespace, as this namespace
1094 ;; will be used for decoding the response. 2522 ;; will be used for decoding the response.
1095 (destructuring-bind (name . message) (soap-operation-input o) 2523 (destructuring-bind (name . message) (soap-operation-input o)
1096 (soap-namespace-put-link name message ns)) 2524 (soap-namespace-put-link name message ns))
1097 2525
1098 (destructuring-bind (name . message) (soap-operation-output o) 2526 (destructuring-bind (name . message) (soap-operation-output o)
1099 (soap-namespace-put-link name message ns)) 2527 (soap-namespace-put-link name message ns))
1100 2528
1101 (dolist (fault (soap-operation-faults o)) 2529 (dolist (fault (soap-operation-faults o))
1102 (destructuring-bind (name . message) fault 2530 (destructuring-bind (name . message) fault
1103 (soap-namespace-put-link name message ns 'replace))) 2531 (soap-namespace-put-link name message ns)))
1104 2532
1105 ))))) 2533 )))))
1106 2534
1107 (make-soap-port-type :name (xml-get-attribute node 'name) 2535 (make-soap-port-type :name (xml-get-attribute node 'name)
1108 :operations ns))) 2536 :operations ns)))
1109 2537
1110(defun soap-parse-operation (node) 2538(defun soap-parse-operation (node)
1111 "Parse NODE as a wsdl:operation and return the corresponding type." 2539 "Parse NODE as a wsdl:operation and return the corresponding type."
1112 (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:operation) 2540 (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:operation)
1113 nil 2541 nil
1114 "soap-parse-operation: expecting wsdl:operation node, got %s" 2542 "expecting wsdl:operation node, got %s"
1115 (soap-l2wk (xml-node-name node))) 2543 (soap-l2wk (xml-node-name node)))
1116 (let ((name (xml-get-attribute node 'name)) 2544 (let ((name (xml-get-attribute node 'name))
1117 (parameter-order (split-string 2545 (parameter-order (split-string
1118 (xml-get-attribute node 'parameterOrder))) 2546 (xml-get-attribute node 'parameterOrder)))
1119 input output faults) 2547 input output faults input-action output-action)
1120 (dolist (n (xml-node-children node)) 2548 (dolist (n (xml-node-children node))
1121 (when (consp n) ; skip string nodes which are whitespace 2549 (when (consp n) ; skip string nodes which are whitespace
1122 (let ((node-name (soap-l2wk (xml-node-name n)))) 2550 (let ((node-name (soap-l2wk (xml-node-name n))))
1123 (cond 2551 (cond
1124 ((eq node-name 'wsdl:input) 2552 ((eq node-name 'wsdl:input)
1125 (let ((message (xml-get-attribute n 'message)) 2553 (let ((message (xml-get-attribute n 'message))
1126 (name (xml-get-attribute n 'name))) 2554 (name (xml-get-attribute n 'name))
1127 (setq input (cons name (soap-l2fq message 'tns))))) 2555 (action (soap-xml-get-attribute-or-nil1 n 'wsaw:Action)))
1128 ((eq node-name 'wsdl:output) 2556 (setq input (cons name (soap-l2fq message 'tns)))
1129 (let ((message (xml-get-attribute n 'message)) 2557 (setq input-action action)))
1130 (name (xml-get-attribute n 'name))) 2558 ((eq node-name 'wsdl:output)
1131 (setq output (cons name (soap-l2fq message 'tns))))) 2559 (let ((message (xml-get-attribute n 'message))
1132 ((eq node-name 'wsdl:fault) 2560 (name (xml-get-attribute n 'name))
1133 (let ((message (xml-get-attribute n 'message)) 2561 (action (soap-xml-get-attribute-or-nil1 n 'wsaw:Action)))
1134 (name (xml-get-attribute n 'name))) 2562 (setq output (cons name (soap-l2fq message 'tns)))
1135 (push (cons name (soap-l2fq message 'tns)) faults))))))) 2563 (setq output-action action)))
2564 ((eq node-name 'wsdl:fault)
2565 (let ((message (xml-get-attribute n 'message))
2566 (name (xml-get-attribute n 'name)))
2567 (push (cons name (soap-l2fq message 'tns)) faults)))))))
1136 (make-soap-operation 2568 (make-soap-operation
1137 :name name 2569 :name name
2570 :namespace-tag soap-target-xmlns
1138 :parameter-order parameter-order 2571 :parameter-order parameter-order
1139 :input input 2572 :input input
1140 :output output 2573 :output output
1141 :faults (nreverse faults)))) 2574 :faults (nreverse faults)
2575 :input-action input-action
2576 :output-action output-action)))
1142 2577
1143(defun soap-parse-binding (node) 2578(defun soap-parse-binding (node)
1144 "Parse NODE as a wsdl:binding and return the corresponding type." 2579 "Parse NODE as a wsdl:binding and return the corresponding type."
1145 (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:binding) 2580 (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:binding)
1146 nil 2581 nil
1147 "soap-parse-binding: expecting wsdl:binding node, got %s" 2582 "expecting wsdl:binding node, got %s"
1148 (soap-l2wk (xml-node-name node))) 2583 (soap-l2wk (xml-node-name node)))
1149 (let ((name (xml-get-attribute node 'name)) 2584 (let ((name (xml-get-attribute node 'name))
1150 (type (xml-get-attribute node 'type))) 2585 (type (xml-get-attribute node 'type)))
1151 (let ((binding (make-soap-binding :name name 2586 (let ((binding (make-soap-binding :name name
1152 :port-type (soap-l2fq type 'tns)))) 2587 :port-type (soap-l2fq type 'tns))))
1153 (dolist (wo (soap-xml-get-children1 node 'wsdl:operation)) 2588 (dolist (wo (soap-xml-get-children1 node 'wsdl:operation))
1154 (let ((name (xml-get-attribute wo 'name)) 2589 (let ((name (xml-get-attribute wo 'name))
1155 soap-action 2590 soap-action
2591 soap-headers
2592 soap-body
1156 use) 2593 use)
1157 (dolist (so (soap-xml-get-children1 wo 'wsdlsoap:operation)) 2594 (dolist (so (soap-xml-get-children1 wo 'wsdlsoap:operation))
1158 (setq soap-action (xml-get-attribute-or-nil so 'soapAction))) 2595 (setq soap-action (xml-get-attribute-or-nil so 'soapAction)))
@@ -1163,9 +2600,24 @@ contents."
1163 ;; "use"-s for each of them... 2600 ;; "use"-s for each of them...
1164 2601
1165 (dolist (i (soap-xml-get-children1 wo 'wsdl:input)) 2602 (dolist (i (soap-xml-get-children1 wo 'wsdl:input))
1166 (dolist (b (soap-xml-get-children1 i 'wsdlsoap:body)) 2603
1167 (setq use (or use 2604 ;; There can be multiple headers ...
1168 (xml-get-attribute-or-nil b 'use))))) 2605 (dolist (h (soap-xml-get-children1 i 'wsdlsoap:header))
2606 (let ((message (soap-l2fq (xml-get-attribute-or-nil h 'message)))
2607 (part (xml-get-attribute-or-nil h 'part))
2608 (use (xml-get-attribute-or-nil h 'use)))
2609 (when (and message part)
2610 (push (list message part use) soap-headers))))
2611
2612 ;; ... but only one body
2613 (let ((body (car (soap-xml-get-children1 i 'wsdlsoap:body))))
2614 (setq soap-body (xml-get-attribute-or-nil body 'parts))
2615 (when soap-body
2616 (setq soap-body
2617 (mapcar #'intern (split-string soap-body
2618 nil
2619 'omit-nulls))))
2620 (setq use (xml-get-attribute-or-nil body 'use))))
1169 2621
1170 (unless use 2622 (unless use
1171 (dolist (i (soap-xml-get-children1 wo 'wsdl:output)) 2623 (dolist (i (soap-xml-get-children1 wo 'wsdl:output))
@@ -1173,9 +2625,12 @@ contents."
1173 (setq use (or use 2625 (setq use (or use
1174 (xml-get-attribute-or-nil b 'use)))))) 2626 (xml-get-attribute-or-nil b 'use))))))
1175 2627
1176 (puthash name (make-soap-bound-operation :operation name 2628 (puthash name (make-soap-bound-operation
1177 :soap-action soap-action 2629 :operation name
1178 :use (and use (intern use))) 2630 :soap-action soap-action
2631 :soap-headers (nreverse soap-headers)
2632 :soap-body soap-body
2633 :use (and use (intern use)))
1179 (soap-binding-operations binding)))) 2634 (soap-binding-operations binding))))
1180 binding))) 2635 binding)))
1181 2636
@@ -1191,10 +2646,6 @@ SOAP response.")
1191This is a dynamically bound variable used during decoding the 2646This is a dynamically bound variable used during decoding the
1192SOAP response.") 2647SOAP response.")
1193 2648
1194(defvar soap-current-wsdl nil
1195 "The current WSDL document used when decoding the SOAP response.
1196This is a dynamically bound variable.")
1197
1198(defun soap-decode-type (type node) 2649(defun soap-decode-type (type node)
1199 "Use TYPE (an xsd type) to decode the contents of NODE. 2650 "Use TYPE (an xsd type) to decode the contents of NODE.
1200 2651
@@ -1212,7 +2663,8 @@ decode function to perform the actual decoding."
1212 (when decoded 2663 (when decoded
1213 (throw 'done decoded))) 2664 (throw 'done decoded)))
1214 2665
1215 (string-match "^#\\(.*\\)$" href) ; TODO: check that it matched 2666 (unless (string-match "^#\\(.*\\)$" href)
2667 (error "Invalid multiRef: %s" href))
1216 2668
1217 (let ((id (match-string 1 href))) 2669 (let ((id (match-string 1 href)))
1218 (dolist (mr soap-multi-refs) 2670 (dolist (mr soap-multi-refs)
@@ -1227,38 +2679,53 @@ decode function to perform the actual decoding."
1227 (soap-with-local-xmlns node 2679 (soap-with-local-xmlns node
1228 (if (equal (soap-xml-get-attribute-or-nil1 node 'xsi:nil) "true") 2680 (if (equal (soap-xml-get-attribute-or-nil1 node 'xsi:nil) "true")
1229 nil 2681 nil
1230 (let ((decoder (get (aref type 0) 'soap-decoder))) 2682 ;; Handle union types.
1231 (assert decoder nil "no soap-decoder for %s type" 2683 (cond ((listp type)
1232 (aref type 0)) 2684 (catch 'done
1233 (funcall decoder type node)))))))) 2685 (dolist (union-member type)
2686 (let* ((decoder (get (aref union-member 0)
2687 'soap-decoder))
2688 (result (ignore-errors
2689 (funcall decoder
2690 union-member node))))
2691 (when result (throw 'done result))))))
2692 (t
2693 (let ((decoder (get (aref type 0) 'soap-decoder)))
2694 (assert decoder nil
2695 "no soap-decoder for %s type" (aref type 0))
2696 (funcall decoder type node))))))))))
1234 2697
1235(defun soap-decode-any-type (node) 2698(defun soap-decode-any-type (node)
1236 "Decode NODE using type information inside it." 2699 "Decode NODE using type information inside it."
1237 ;; If the NODE has type information, we use that... 2700 ;; If the NODE has type information, we use that...
1238 (let ((type (soap-xml-get-attribute-or-nil1 node 'xsi:type))) 2701 (let ((type (soap-xml-get-attribute-or-nil1 node 'xsi:type)))
2702 (when type
2703 (setq type (soap-l2fq type)))
1239 (if type 2704 (if type
1240 (let ((wtype (soap-wsdl-get type soap-current-wsdl 'soap-type-p))) 2705 (let ((wtype (soap-wsdl-get type soap-current-wsdl 'soap-xs-type-p)))
1241 (if wtype 2706 (if wtype
1242 (soap-decode-type wtype node) 2707 (soap-decode-type wtype node)
1243 ;; The node has type info encoded in it, but we don't know how 2708 ;; The node has type info encoded in it, but we don't know how
1244 ;; to decode it... 2709 ;; to decode it...
1245 (error "Soap-decode-any-type: node has unknown type: %s" type))) 2710 (error "Node has unknown type: %s" type)))
1246 2711
1247 ;; No type info in the node... 2712 ;; No type info in the node...
1248 2713
1249 (let ((contents (xml-node-children node))) 2714 (let ((contents (xml-node-children node)))
1250 (if (and (= (length contents) 1) (stringp (car contents))) 2715 (if (and (= (length contents) 1) (stringp (car contents)))
1251 ;; contents is just a string 2716 ;; contents is just a string
1252 (car contents) 2717 (car contents)
1253 2718
1254 ;; we assume the NODE is a sequence with every element a 2719 ;; we assume the NODE is a sequence with every element a
1255 ;; structure name 2720 ;; structure name
1256 (let (result) 2721 (let (result)
1257 (dolist (element contents) 2722 (dolist (element contents)
1258 (let ((key (xml-node-name element)) 2723 ;; skip any string contents, assume they are whitespace
1259 (value (soap-decode-any-type element))) 2724 (unless (stringp element)
1260 (push (cons key value) result))) 2725 (let ((key (xml-node-name element))
1261 (nreverse result))))))) 2726 (value (soap-decode-any-type element)))
2727 (push (cons key value) result))))
2728 (nreverse result)))))))
1262 2729
1263(defun soap-decode-array (node) 2730(defun soap-decode-array (node)
1264 "Decode NODE as an Array using type information inside it." 2731 "Decode NODE as an Array using type information inside it."
@@ -1267,90 +2734,23 @@ decode function to perform the actual decoding."
1267 (contents (xml-node-children node)) 2734 (contents (xml-node-children node))
1268 result) 2735 result)
1269 (when type 2736 (when type
1270 ;; Type is in the format "someType[NUM]" where NUM is the number of 2737 ;; Type is in the format "someType[NUM]" where NUM is the number of
1271 ;; elements in the array. We discard the [NUM] part. 2738 ;; elements in the array. We discard the [NUM] part.
1272 (setq type (replace-regexp-in-string "\\[[0-9]+\\]\\'" "" type)) 2739 (setq type (replace-regexp-in-string "\\[[0-9]+\\]\\'" "" type))
1273 (setq wtype (soap-wsdl-get type soap-current-wsdl 'soap-type-p)) 2740 (setq wtype (soap-wsdl-get (soap-l2fq type)
1274 (unless wtype 2741 soap-current-wsdl 'soap-xs-type-p))
1275 ;; The node has type info encoded in it, but we don't know how to 2742 (unless wtype
1276 ;; decode it... 2743 ;; The node has type info encoded in it, but we don't know how to
1277 (error "Soap-decode-array: node has unknown type: %s" type))) 2744 ;; decode it...
2745 (error "Soap-decode-array: node has unknown type: %s" type)))
1278 (dolist (e contents) 2746 (dolist (e contents)
1279 (when (consp e) 2747 (when (consp e)
1280 (push (if wtype 2748 (push (if wtype
1281 (soap-decode-type wtype e) 2749 (soap-decode-type wtype e)
1282 (soap-decode-any-type e)) 2750 (soap-decode-any-type e))
1283 result))) 2751 result)))
1284 (nreverse result))) 2752 (nreverse result)))
1285 2753
1286(defun soap-decode-basic-type (type node)
1287 "Use TYPE to decode the contents of NODE.
1288TYPE is a `soap-basic-type' struct, and NODE is an XML document.
1289A LISP value is returned based on the contents of NODE and the
1290type-info stored in TYPE."
1291 (let ((contents (xml-node-children node))
1292 (type-kind (soap-basic-type-kind type)))
1293
1294 (if (null contents)
1295 nil
1296 (ecase type-kind
1297 ((string anyURI) (car contents))
1298 (dateTime (car contents)) ; TODO: convert to a date time
1299 ((long int integer unsignedInt byte float double) (string-to-number (car contents)))
1300 (boolean (string= (downcase (car contents)) "true"))
1301 (base64Binary (base64-decode-string (car contents)))
1302 (anyType (soap-decode-any-type node))
1303 (Array (soap-decode-array node))))))
1304
1305(defun soap-decode-sequence-type (type node)
1306 "Use TYPE to decode the contents of NODE.
1307TYPE is assumed to be a sequence type and an ALIST with the
1308contents of the NODE is returned."
1309 (let ((result nil)
1310 (parent (soap-sequence-type-parent type)))
1311 (when parent
1312 (setq result (nreverse (soap-decode-type parent node))))
1313 (dolist (element (soap-sequence-type-elements type))
1314 (let ((instance-count 0)
1315 (e-name (soap-sequence-element-name element))
1316 (e-type (soap-sequence-element-type element)))
1317 (dolist (node (xml-get-children node e-name))
1318 (incf instance-count)
1319 (push (cons e-name (soap-decode-type e-type node)) result))
1320 ;; Do some sanity checking
1321 (cond ((and (= instance-count 0)
1322 (not (soap-sequence-element-nillable? element)))
1323 (soap-warning "While decoding %s: missing non-nillable slot %s"
1324 (soap-element-name type) e-name))
1325 ((and (> instance-count 1)
1326 (not (soap-sequence-element-multiple? element)))
1327 (soap-warning "While decoding %s: multiple slots named %s"
1328 (soap-element-name type) e-name)))))
1329 (nreverse result)))
1330
1331(defun soap-decode-array-type (type node)
1332 "Use TYPE to decode the contents of NODE.
1333TYPE is assumed to be an array type. Arrays are decoded as lists.
1334This is because it is easier to work with list results in LISP."
1335 (let ((result nil)
1336 (element-type (soap-array-type-element-type type)))
1337 (dolist (node (xml-node-children node))
1338 (when (consp node)
1339 (push (soap-decode-type element-type node) result)))
1340 (nreverse result)))
1341
1342(progn
1343 (put (aref (make-soap-basic-type) 0)
1344 'soap-decoder 'soap-decode-basic-type)
1345 ;; just use the basic type decoder for the simple type -- we accept any
1346 ;; value and don't do any validation on it.
1347 (put (aref (make-soap-simple-type) 0)
1348 'soap-decoder 'soap-decode-basic-type)
1349 (put (aref (make-soap-sequence-type) 0)
1350 'soap-decoder 'soap-decode-sequence-type)
1351 (put (aref (make-soap-array-type) 0)
1352 'soap-decoder 'soap-decode-array-type))
1353
1354;;;; Soap Envelope parsing 2754;;;; Soap Envelope parsing
1355 2755
1356(define-error 'soap-error "SOAP error") 2756(define-error 'soap-error "SOAP error")
@@ -1362,40 +2762,44 @@ WSDL is used to decode the NODE"
1362 (soap-with-local-xmlns node 2762 (soap-with-local-xmlns node
1363 (assert (eq (soap-l2wk (xml-node-name node)) 'soap:Envelope) 2763 (assert (eq (soap-l2wk (xml-node-name node)) 'soap:Envelope)
1364 nil 2764 nil
1365 "soap-parse-envelope: expecting soap:Envelope node, got %s" 2765 "expecting soap:Envelope node, got %s"
1366 (soap-l2wk (xml-node-name node))) 2766 (soap-l2wk (xml-node-name node)))
1367 (let ((body (car (soap-xml-get-children1 node 'soap:Body)))) 2767 (let ((headers (soap-xml-get-children1 node 'soap:Header))
2768 (body (car (soap-xml-get-children1 node 'soap:Body))))
1368 2769
1369 (let ((fault (car (soap-xml-get-children1 body 'soap:Fault)))) 2770 (let ((fault (car (soap-xml-get-children1 body 'soap:Fault))))
1370 (when fault 2771 (when fault
1371 (let ((fault-code (let ((n (car (xml-get-children 2772 (let ((fault-code (let ((n (car (xml-get-children
1372 fault 'faultcode)))) 2773 fault 'faultcode))))
1373 (car-safe (xml-node-children n)))) 2774 (car-safe (xml-node-children n))))
1374 (fault-string (let ((n (car (xml-get-children 2775 (fault-string (let ((n (car (xml-get-children
1375 fault 'faultstring)))) 2776 fault 'faultstring))))
1376 (car-safe (xml-node-children n)))) 2777 (car-safe (xml-node-children n))))
1377 (detail (xml-get-children fault 'detail))) 2778 (detail (xml-get-children fault 'detail)))
1378 (while t 2779 (while t
1379 (signal 'soap-error (list fault-code fault-string detail)))))) 2780 (signal 'soap-error (list fault-code fault-string detail))))))
1380 2781
1381 ;; First (non string) element of the body is the root node of he 2782 ;; First (non string) element of the body is the root node of he
1382 ;; response 2783 ;; response
1383 (let ((response (if (eq (soap-bound-operation-use operation) 'literal) 2784 (let ((response (if (eq (soap-bound-operation-use operation) 'literal)
1384 ;; For 'literal uses, the response is the actual body 2785 ;; For 'literal uses, the response is the actual body
1385 body 2786 body
1386 ;; ...otherwise the first non string element 2787 ;; ...otherwise the first non string element
1387 ;; of the body is the response 2788 ;; of the body is the response
1388 (catch 'found 2789 (catch 'found
1389 (dolist (n (xml-node-children body)) 2790 (dolist (n (xml-node-children body))
1390 (when (consp n) 2791 (when (consp n)
1391 (throw 'found n))))))) 2792 (throw 'found n)))))))
1392 (soap-parse-response response operation wsdl body))))) 2793 (soap-parse-response response operation wsdl headers body)))))
1393 2794
1394(defun soap-parse-response (response-node operation wsdl soap-body) 2795(defun soap-parse-response (response-node operation wsdl soap-headers soap-body)
1395 "Parse RESPONSE-NODE and return the result as a LISP value. 2796 "Parse RESPONSE-NODE and return the result as a LISP value.
1396OPERATION is the WSDL operation for which we expect the response, 2797OPERATION is the WSDL operation for which we expect the response,
1397WSDL is used to decode the NODE. 2798WSDL is used to decode the NODE.
1398 2799
2800SOAP-HEADERS is a list of the headers of the SOAP envelope or nil
2801if there are no headers.
2802
1399SOAP-BODY is the body of the SOAP envelope (of which 2803SOAP-BODY is the body of the SOAP envelope (of which
1400RESPONSE-NODE is a sub-node). It is used in case RESPONSE-NODE 2804RESPONSE-NODE is a sub-node). It is used in case RESPONSE-NODE
1401reference multiRef parts which are external to RESPONSE-NODE." 2805reference multiRef parts which are external to RESPONSE-NODE."
@@ -1409,7 +2813,7 @@ reference multiRef parts which are external to RESPONSE-NODE."
1409 (when (eq use 'encoded) 2813 (when (eq use 'encoded)
1410 (let* ((received-message-name (soap-l2fq (xml-node-name response-node))) 2814 (let* ((received-message-name (soap-l2fq (xml-node-name response-node)))
1411 (received-message (soap-wsdl-get 2815 (received-message (soap-wsdl-get
1412 received-message-name wsdl 'soap-message-p))) 2816 received-message-name wsdl 'soap-message-p)))
1413 (unless (eq received-message message) 2817 (unless (eq received-message message)
1414 (error "Unexpected message: got %s, expecting %s" 2818 (error "Unexpected message: got %s, expecting %s"
1415 received-message-name 2819 received-message-name
@@ -1426,42 +2830,52 @@ reference multiRef parts which are external to RESPONSE-NODE."
1426 2830
1427 (setq node 2831 (setq node
1428 (cond 2832 (cond
1429 ((eq use 'encoded) 2833 ((eq use 'encoded)
1430 (car (xml-get-children response-node tag))) 2834 (car (xml-get-children response-node tag)))
1431 2835
1432 ((eq use 'literal) 2836 ((eq use 'literal)
1433 (catch 'found 2837 (catch 'found
1434 (let* ((ns-aliases (soap-wsdl-alias-table wsdl)) 2838 (let* ((ns-aliases (soap-wsdl-alias-table wsdl))
1435 (ns-name (cdr (assoc 2839 (ns-name (cdr (assoc
1436 (soap-element-namespace-tag type) 2840 (soap-element-namespace-tag type)
1437 ns-aliases))) 2841 ns-aliases)))
1438 (fqname (cons ns-name (soap-element-name type)))) 2842 (fqname (cons ns-name (soap-element-name type))))
1439 (dolist (c (xml-node-children response-node)) 2843 (dolist (c (append (mapcar (lambda (header)
1440 (when (consp c) 2844 (car (xml-node-children
1441 (soap-with-local-xmlns c 2845 header)))
1442 (when (equal (soap-l2fq (xml-node-name c)) 2846 soap-headers)
1443 fqname) 2847 (xml-node-children response-node)))
1444 (throw 'found c)))))))))) 2848 (when (consp c)
2849 (soap-with-local-xmlns c
2850 (when (equal (soap-l2fq (xml-node-name c))
2851 fqname)
2852 (throw 'found c))))))))))
1445 2853
1446 (unless node 2854 (unless node
1447 (error "Soap-parse-response(%s): cannot find message part %s" 2855 (error "Soap-parse-response(%s): cannot find message part %s"
1448 (soap-element-name op) tag)) 2856 (soap-element-name op) tag))
1449 (push (soap-decode-type type node) decoded-parts))) 2857 (let ((decoded-value (soap-decode-type type node)))
2858 (when decoded-value
2859 (push decoded-value decoded-parts)))))
1450 2860
1451 decoded-parts)))) 2861 decoded-parts))))
1452 2862
1453;;;; SOAP type encoding 2863;;;; SOAP type encoding
1454 2864
1455(defvar soap-encoded-namespaces nil 2865(defun soap-encode-attributes (value type)
1456 "A list of namespace tags used during encoding a message. 2866 "Encode XML attributes for VALUE according to TYPE.
1457This list is populated by `soap-encode-value' and used by 2867This is a generic function which determines the attribute encoder
1458`soap-create-envelope' to add aliases for these namespace to the 2868for the type and calls that specialized function to do the work.
1459XML request.
1460 2869
1461This variable is dynamically bound in `soap-create-envelope'.") 2870Attributes are inserted in the current buffer at the current
2871position."
2872 (let ((attribute-encoder (get (aref type 0) 'soap-attribute-encoder)))
2873 (assert attribute-encoder nil
2874 "no soap-attribute-encoder for %s type" (aref type 0))
2875 (funcall attribute-encoder value type)))
1462 2876
1463(defun soap-encode-value (xml-tag value type) 2877(defun soap-encode-value (value type)
1464 "Encode inside an XML-TAG the VALUE using TYPE. 2878 "Encode the VALUE using TYPE.
1465The resulting XML data is inserted in the current buffer 2879The resulting XML data is inserted in the current buffer
1466at (point)/ 2880at (point)/
1467 2881
@@ -1471,190 +2885,24 @@ encoder function based on TYPE and calls that encoder to do the
1471work." 2885work."
1472 (let ((encoder (get (aref type 0) 'soap-encoder))) 2886 (let ((encoder (get (aref type 0) 'soap-encoder)))
1473 (assert encoder nil "no soap-encoder for %s type" (aref type 0)) 2887 (assert encoder nil "no soap-encoder for %s type" (aref type 0))
1474 ;; XML-TAG can be a string or a symbol, but we pass only string's to the 2888 (funcall encoder value type))
1475 ;; encoders 2889 (when (soap-element-namespace-tag type)
1476 (when (symbolp xml-tag) 2890 (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag type))))
1477 (setq xml-tag (symbol-name xml-tag)))
1478 (funcall encoder xml-tag value type))
1479 (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag type)))
1480
1481(defun soap-encode-basic-type (xml-tag value type)
1482 "Encode inside XML-TAG the LISP VALUE according to TYPE.
1483Do not call this function directly, use `soap-encode-value'
1484instead."
1485 (let ((xsi-type (soap-element-fq-name type))
1486 (basic-type (soap-basic-type-kind type)))
1487
1488 ;; try to classify the type based on the value type and use that type when
1489 ;; encoding
1490 (when (eq basic-type 'anyType)
1491 (cond ((stringp value)
1492 (setq xsi-type "xsd:string" basic-type 'string))
1493 ((integerp value)
1494 (setq xsi-type "xsd:int" basic-type 'int))
1495 ((memq value '(t nil))
1496 (setq xsi-type "xsd:boolean" basic-type 'boolean))
1497 (t
1498 (error
1499 "Soap-encode-basic-type(%s, %s, %s): cannot classify anyType value"
1500 xml-tag value xsi-type))))
1501 2891
1502 (insert "<" xml-tag " xsi:type=\"" xsi-type "\"") 2892(defun soap-encode-body (operation parameters &optional service-url)
1503
1504 ;; We have some ambiguity here, as a nil value represents "false" when the
1505 ;; type is boolean, we will never have a "nil" boolean type...
1506
1507 (if (or value (eq basic-type 'boolean))
1508 (progn
1509 (insert ">")
1510 (case basic-type
1511 ((string anyURI)
1512 (unless (stringp value)
1513 (error "Soap-encode-basic-type(%s, %s, %s): not a string value"
1514 xml-tag value xsi-type))
1515 (insert (url-insert-entities-in-string value)))
1516
1517 (dateTime
1518 (cond ((and (consp value) ; is there a time-value-p ?
1519 (>= (length value) 2)
1520 (numberp (nth 0 value))
1521 (numberp (nth 1 value)))
1522 ;; Value is a (current-time) style value, convert
1523 ;; to a string
1524 (insert (format-time-string "%Y-%m-%dT%H:%M:%S" value)))
1525 ((stringp value)
1526 (insert (url-insert-entities-in-string value)))
1527 (t
1528 (error
1529 "Soap-encode-basic-type(%s, %s, %s): not a dateTime value"
1530 xml-tag value xsi-type))))
1531
1532 (boolean
1533 (unless (memq value '(t nil))
1534 (error "Soap-encode-basic-type(%s, %s, %s): not a boolean value"
1535 xml-tag value xsi-type))
1536 (insert (if value "true" "false")))
1537
1538 ((long int integer byte unsignedInt)
1539 (unless (integerp value)
1540 (error "Soap-encode-basic-type(%s, %s, %s): not an integer value"
1541 xml-tag value xsi-type))
1542 (when (and (eq basic-type 'unsignedInt) (< value 0))
1543 (error "Soap-encode-basic-type(%s, %s, %s): not a positive integer"
1544 xml-tag value xsi-type))
1545 (insert (number-to-string value)))
1546
1547 ((float double)
1548 (unless (numberp value)
1549 (error "Soap-encode-basic-type(%s, %s, %s): not a number"
1550 xml-tag value xsi-type))
1551 (insert (number-to-string value)))
1552
1553 (base64Binary
1554 (unless (stringp value)
1555 (error "Soap-encode-basic-type(%s, %s, %s): not a string value"
1556 xml-tag value xsi-type))
1557 (insert (base64-encode-string value)))
1558
1559 (otherwise
1560 (error
1561 "Soap-encode-basic-type(%s, %s, %s): don't know how to encode"
1562 xml-tag value xsi-type))))
1563
1564 (insert " xsi:nil=\"true\">"))
1565 (insert "</" xml-tag ">\n")))
1566
1567(defun soap-encode-simple-type (xml-tag value type)
1568 "Encode inside XML-TAG the LISP VALUE according to TYPE."
1569
1570 ;; Validate VALUE against the simple type's enumeration, than just encode it
1571 ;; using `soap-encode-basic-type'
1572
1573 (let ((enumeration (soap-simple-type-enumeration type)))
1574 (unless (and (> (length enumeration) 1)
1575 (member value enumeration))
1576 (error "soap-encode-simple-type(%s, %s, %s): bad value, should be one of %s"
1577 xml-tag value (soap-element-fq-name type) enumeration)))
1578
1579 (soap-encode-basic-type xml-tag value type))
1580
1581(defun soap-encode-sequence-type (xml-tag value type)
1582 "Encode inside XML-TAG the LISP VALUE according to TYPE.
1583Do not call this function directly, use `soap-encode-value'
1584instead."
1585 (let ((xsi-type (soap-element-fq-name type)))
1586 (insert "<" xml-tag " xsi:type=\"" xsi-type "\"")
1587 (if value
1588 (progn
1589 (insert ">\n")
1590 (let ((parents (list type))
1591 (parent (soap-sequence-type-parent type)))
1592
1593 (while parent
1594 (push parent parents)
1595 (setq parent (soap-sequence-type-parent parent)))
1596
1597 (dolist (type parents)
1598 (dolist (element (soap-sequence-type-elements type))
1599 (let ((instance-count 0)
1600 (e-name (soap-sequence-element-name element))
1601 (e-type (soap-sequence-element-type element)))
1602 (dolist (v value)
1603 (when (equal (car v) e-name)
1604 (incf instance-count)
1605 (soap-encode-value e-name (cdr v) e-type)))
1606
1607 ;; Do some sanity checking
1608 (cond ((and (= instance-count 0)
1609 (not (soap-sequence-element-nillable? element)))
1610 (soap-warning
1611 "While encoding %s: missing non-nillable slot %s"
1612 (soap-element-name type) e-name))
1613 ((and (> instance-count 1)
1614 (not (soap-sequence-element-multiple? element)))
1615 (soap-warning
1616 "While encoding %s: multiple slots named %s"
1617 (soap-element-name type) e-name))))))))
1618 (insert " xsi:nil=\"true\">"))
1619 (insert "</" xml-tag ">\n")))
1620
1621(defun soap-encode-array-type (xml-tag value type)
1622 "Encode inside XML-TAG the LISP VALUE according to TYPE.
1623Do not call this function directly, use `soap-encode-value'
1624instead."
1625 (unless (vectorp value)
1626 (error "Soap-encode: %s(%s) expects a vector, got: %s"
1627 xml-tag (soap-element-fq-name type) value))
1628 (let* ((element-type (soap-array-type-element-type type))
1629 (array-type (concat (soap-element-fq-name element-type)
1630 "[" (format "%s" (length value)) "]")))
1631 (insert "<" xml-tag
1632 " soapenc:arrayType=\"" array-type "\" "
1633 " xsi:type=\"soapenc:Array\">\n")
1634 (loop for i below (length value)
1635 do (soap-encode-value xml-tag (aref value i) element-type))
1636 (insert "</" xml-tag ">\n")))
1637
1638(progn
1639 (put (aref (make-soap-basic-type) 0)
1640 'soap-encoder 'soap-encode-basic-type)
1641 (put (aref (make-soap-simple-type) 0)
1642 'soap-encoder 'soap-encode-simple-type)
1643 (put (aref (make-soap-sequence-type) 0)
1644 'soap-encoder 'soap-encode-sequence-type)
1645 (put (aref (make-soap-array-type) 0)
1646 'soap-encoder 'soap-encode-array-type))
1647
1648(defun soap-encode-body (operation parameters wsdl)
1649 "Create the body of a SOAP request for OPERATION in the current buffer. 2893 "Create the body of a SOAP request for OPERATION in the current buffer.
1650PARAMETERS is a list of parameters supplied to the OPERATION. 2894PARAMETERS is a list of parameters supplied to the OPERATION.
1651 2895
1652The OPERATION and PARAMETERS are encoded according to the WSDL 2896The OPERATION and PARAMETERS are encoded according to the WSDL
1653document." 2897document. SERVICE-URL should be provided when WS-Addressing is
2898being used."
1654 (let* ((op (soap-bound-operation-operation operation)) 2899 (let* ((op (soap-bound-operation-operation operation))
1655 (use (soap-bound-operation-use operation)) 2900 (use (soap-bound-operation-use operation))
1656 (message (cdr (soap-operation-input op))) 2901 (message (cdr (soap-operation-input op)))
1657 (parameter-order (soap-operation-parameter-order op))) 2902 (parameter-order (soap-operation-parameter-order op))
2903 (param-table (loop for formal in parameter-order
2904 for value in parameters
2905 collect (cons formal value))))
1658 2906
1659 (unless (= (length parameter-order) (length parameters)) 2907 (unless (= (length parameter-order) (length parameters))
1660 (error "Wrong number of parameters for %s: expected %d, got %s" 2908 (error "Wrong number of parameters for %s: expected %d, got %s"
@@ -1662,62 +2910,73 @@ document."
1662 (length parameter-order) 2910 (length parameter-order)
1663 (length parameters))) 2911 (length parameters)))
1664 2912
2913 (let ((headers (soap-bound-operation-soap-headers operation))
2914 (input-action (soap-operation-input-action op)))
2915 (when headers
2916 (insert "<soap:Header>\n")
2917 (when input-action
2918 (add-to-list 'soap-encoded-namespaces "wsa")
2919 (insert "<wsa:Action>" input-action "</wsa:Action>\n")
2920 (insert "<wsa:To>" service-url "</wsa:To>\n"))
2921 (dolist (h headers)
2922 (let* ((message (nth 0 h))
2923 (part (assq (nth 1 h) (soap-message-parts message)))
2924 (value (cdr (assoc (car part) (car parameters))))
2925 (use (nth 2 h))
2926 (element (cdr part)))
2927 (when (eq use 'encoded)
2928 (when (soap-element-namespace-tag element)
2929 (add-to-list 'soap-encoded-namespaces
2930 (soap-element-namespace-tag element)))
2931 (insert "<" (soap-element-fq-name element) ">\n"))
2932 (soap-encode-value value element)
2933 (when (eq use 'encoded)
2934 (insert "</" (soap-element-fq-name element) ">\n"))))
2935 (insert "</soap:Header>\n")))
2936
1665 (insert "<soap:Body>\n") 2937 (insert "<soap:Body>\n")
1666 (when (eq use 'encoded) 2938 (when (eq use 'encoded)
1667 (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag op)) 2939 (when (soap-element-namespace-tag op)
2940 (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag op)))
1668 (insert "<" (soap-element-fq-name op) ">\n")) 2941 (insert "<" (soap-element-fq-name op) ">\n"))
1669 2942
1670 (let ((param-table (loop for formal in parameter-order 2943 (dolist (part (soap-message-parts message))
1671 for value in parameters 2944 (let* ((param-name (car part))
1672 collect (cons formal value)))) 2945 (element (cdr part))
1673 (dolist (part (soap-message-parts message)) 2946 (value (cdr (assoc param-name param-table))))
1674 (let* ((param-name (car part)) 2947 (when (or (null (soap-bound-operation-soap-body operation))
1675 (type (cdr part)) 2948 (member param-name
1676 (tag-name (if (eq use 'encoded) 2949 (soap-bound-operation-soap-body operation)))
1677 param-name 2950 (soap-encode-value value element))))
1678 (soap-element-name type)))
1679 (value (cdr (assoc param-name param-table)))
1680 (start-pos (point)))
1681 (soap-encode-value tag-name value type)
1682 (when (eq use 'literal)
1683 ;; hack: add the xmlns attribute to the tag, the only way
1684 ;; ASP.NET web services recognize the namespace of the
1685 ;; element itself...
1686 (save-excursion
1687 (goto-char start-pos)
1688 (when (re-search-forward " ")
1689 (let* ((ns (soap-element-namespace-tag type))
1690 (namespace (cdr (assoc ns
1691 (soap-wsdl-alias-table wsdl)))))
1692 (when namespace
1693 (insert "xmlns=\"" namespace "\" ")))))))))
1694 2951
1695 (when (eq use 'encoded) 2952 (when (eq use 'encoded)
1696 (insert "</" (soap-element-fq-name op) ">\n")) 2953 (insert "</" (soap-element-fq-name op) ">\n"))
1697 (insert "</soap:Body>\n"))) 2954 (insert "</soap:Body>\n")))
1698 2955
1699(defun soap-create-envelope (operation parameters wsdl) 2956(defun soap-create-envelope (operation parameters wsdl &optional service-url)
1700 "Create a SOAP request envelope for OPERATION using PARAMETERS. 2957 "Create a SOAP request envelope for OPERATION using PARAMETERS.
1701WSDL is the wsdl document used to encode the PARAMETERS." 2958WSDL is the wsdl document used to encode the PARAMETERS.
2959SERVICE-URL should be provided when WS-Addressing is being used."
1702 (with-temp-buffer 2960 (with-temp-buffer
1703 (let ((soap-encoded-namespaces '("xsi" "soap" "soapenc")) 2961 (let ((soap-encoded-namespaces '("xsi" "soap" "soapenc"))
1704 (use (soap-bound-operation-use operation))) 2962 (use (soap-bound-operation-use operation)))
1705 2963
1706 ;; Create the request body 2964 ;; Create the request body
1707 (soap-encode-body operation parameters wsdl) 2965 (soap-encode-body operation parameters service-url)
1708 2966
1709 ;; Put the envelope around the body 2967 ;; Put the envelope around the body
1710 (goto-char (point-min)) 2968 (goto-char (point-min))
1711 (insert "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<soap:Envelope\n") 2969 (insert "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<soap:Envelope\n")
1712 (when (eq use 'encoded) 2970 (when (eq use 'encoded)
1713 (insert " soapenc:encodingStyle=\"http://schemas.xmlsoap.org/soap/encoding/\"\n")) 2971 (insert " soapenc:encodingStyle=\"\
2972http://schemas.xmlsoap.org/soap/encoding/\"\n"))
1714 (dolist (nstag soap-encoded-namespaces) 2973 (dolist (nstag soap-encoded-namespaces)
1715 (insert " xmlns:" nstag "=\"") 2974 (insert " xmlns:" nstag "=\"")
1716 (let ((nsname (cdr (assoc nstag soap-well-known-xmlns)))) 2975 (let ((nsname (cdr (assoc nstag soap-well-known-xmlns))))
1717 (unless nsname 2976 (unless nsname
1718 (setq nsname (cdr (assoc nstag (soap-wsdl-alias-table wsdl))))) 2977 (setq nsname (cdr (assoc nstag (soap-wsdl-alias-table wsdl)))))
1719 (insert nsname) 2978 (insert nsname)
1720 (insert "\"\n"))) 2979 (insert "\"\n")))
1721 (insert ">\n") 2980 (insert ">\n")
1722 (goto-char (point-max)) 2981 (goto-char (point-max))
1723 (insert "</soap:Envelope>\n")) 2982 (insert "</soap:Envelope>\n"))
@@ -1731,6 +2990,86 @@ WSDL is the wsdl document used to encode the PARAMETERS."
1731 :type 'boolean 2990 :type 'boolean
1732 :group 'soap-client) 2991 :group 'soap-client)
1733 2992
2993(defun soap-invoke-internal (callback cbargs wsdl service operation-name
2994 &rest parameters)
2995 "Implement `soap-invoke' and `soap-invoke-async'.
2996If CALLBACK is non-nil, operate asynchronously, then call CALLBACK as (apply
2997CALLBACK RESPONSE CBARGS), where RESPONSE is the SOAP invocation result.
2998If CALLBACK is nil, operate synchronously. WSDL, SERVICE,
2999OPERATION-NAME and PARAMETERS are as described in `soap-invoke'."
3000 (let ((port (catch 'found
3001 (dolist (p (soap-wsdl-ports wsdl))
3002 (when (equal service (soap-element-name p))
3003 (throw 'found p))))))
3004 (unless port
3005 (error "Unknown SOAP service: %s" service))
3006
3007 (let* ((binding (soap-port-binding port))
3008 (operation (gethash operation-name
3009 (soap-binding-operations binding))))
3010 (unless operation
3011 (error "No operation %s for SOAP service %s" operation-name service))
3012
3013 (let ((url-request-method "POST")
3014 (url-package-name "soap-client.el")
3015 (url-package-version "1.0")
3016 (url-request-data
3017 ;; url-request-data expects a unibyte string already encoded...
3018 (encode-coding-string
3019 (soap-create-envelope operation parameters wsdl
3020 (soap-port-service-url port))
3021 'utf-8))
3022 (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5")
3023 (url-http-attempt-keepalives t)
3024 (url-request-extra-headers
3025 (list
3026 (cons "SOAPAction"
3027 (concat "\"" (soap-bound-operation-soap-action
3028 operation) "\""))
3029 (cons "Content-Type"
3030 "text/xml; charset=utf-8"))))
3031 (if callback
3032 (url-retrieve
3033 (soap-port-service-url port)
3034 (lambda (status)
3035 (let ((data-buffer (current-buffer)))
3036 (unwind-protect
3037 (let ((error-status (plist-get status :error)))
3038 (if error-status
3039 (signal (car error-status) (cdr error-status))
3040 (apply callback
3041 (soap-parse-envelope
3042 (soap-parse-server-response)
3043 operation wsdl)
3044 cbargs)))
3045 ;; Ensure the url-retrieve buffer is not leaked.
3046 (and (buffer-live-p data-buffer)
3047 (kill-buffer data-buffer))))))
3048 (let ((buffer (url-retrieve-synchronously
3049 (soap-port-service-url port))))
3050 (condition-case err
3051 (with-current-buffer buffer
3052 (declare (special url-http-response-status))
3053 (if (null url-http-response-status)
3054 (error "No HTTP response from server"))
3055 (if (and soap-debug (> url-http-response-status 299))
3056 ;; This is a warning because some SOAP errors come
3057 ;; back with a HTTP response 500 (internal server
3058 ;; error)
3059 (warn "Error in SOAP response: HTTP code %s"
3060 url-http-response-status))
3061 (soap-parse-envelope (soap-parse-server-response)
3062 operation wsdl))
3063 (soap-error
3064 ;; Propagate soap-errors -- they are error replies of the
3065 ;; SOAP protocol and don't indicate a communication
3066 ;; problem or a bug in this code.
3067 (signal (car err) (cdr err)))
3068 (error
3069 (when soap-debug
3070 (pop-to-buffer buffer))
3071 (error (error-message-string err))))))))))
3072
1734(defun soap-invoke (wsdl service operation-name &rest parameters) 3073(defun soap-invoke (wsdl service operation-name &rest parameters)
1735 "Invoke a SOAP operation and return the result. 3074 "Invoke a SOAP operation and return the result.
1736 3075
@@ -1749,72 +3088,18 @@ NOTE: The SOAP service provider should document the available
1749operations and their parameters for the service. You can also 3088operations and their parameters for the service. You can also
1750use the `soap-inspect' function to browse the available 3089use the `soap-inspect' function to browse the available
1751operations in a WSDL document." 3090operations in a WSDL document."
1752 (let ((port (catch 'found 3091 (apply #'soap-invoke-internal nil nil wsdl service operation-name parameters))
1753 (dolist (p (soap-wsdl-ports wsdl)) 3092
1754 (when (equal service (soap-element-name p)) 3093(defun soap-invoke-async (callback cbargs wsdl service operation-name
1755 (throw 'found p)))))) 3094 &rest parameters)
1756 (unless port 3095 "Like `soap-invoke', but call CALLBACK asynchronously with response.
1757 (error "Unknown SOAP service: %s" service)) 3096CALLBACK is called as (apply CALLBACK RESPONSE CBARGS), where
1758 3097RESPONSE is the SOAP invocation result. WSDL, SERVICE,
1759 (let* ((binding (soap-port-binding port)) 3098OPERATION-NAME and PARAMETERS are as described in `soap-invoke'."
1760 (operation (gethash operation-name 3099 (unless callback
1761 (soap-binding-operations binding)))) 3100 (error "Callback argument is nil"))
1762 (unless operation 3101 (apply #'soap-invoke-internal callback cbargs wsdl service operation-name
1763 (error "No operation %s for SOAP service %s" operation-name service)) 3102 parameters))
1764
1765 (let ((url-request-method "POST")
1766 (url-package-name "soap-client.el")
1767 (url-package-version "1.0")
1768 (url-http-version "1.0")
1769 (url-request-data
1770 ;; url-request-data expects a unibyte string already encoded...
1771 (encode-coding-string
1772 (soap-create-envelope operation parameters wsdl)
1773 'utf-8))
1774 (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5")
1775 (url-request-coding-system 'utf-8)
1776 (url-http-attempt-keepalives t)
1777 (url-request-extra-headers (list
1778 (cons "SOAPAction"
1779 (soap-bound-operation-soap-action
1780 operation))
1781 (cons "Content-Type"
1782 "text/xml; charset=utf-8"))))
1783 (let ((buffer (url-retrieve-synchronously
1784 (soap-port-service-url port))))
1785 (condition-case err
1786 (with-current-buffer buffer
1787 (declare (special url-http-response-status))
1788 (if (null url-http-response-status)
1789 (error "No HTTP response from server"))
1790 (if (and soap-debug (> url-http-response-status 299))
1791 ;; This is a warning because some SOAP errors come
1792 ;; back with a HTTP response 500 (internal server
1793 ;; error)
1794 (warn "Error in SOAP response: HTTP code %s"
1795 url-http-response-status))
1796 (let ((mime-part (mm-dissect-buffer t t)))
1797 (unless mime-part
1798 (error "Failed to decode response from server"))
1799 (unless (equal (car (mm-handle-type mime-part)) "text/xml")
1800 (error "Server response is not an XML document"))
1801 (with-temp-buffer
1802 (mm-insert-part mime-part)
1803 (let ((response (car (xml-parse-region
1804 (point-min) (point-max)))))
1805 (prog1
1806 (soap-parse-envelope response operation wsdl)
1807 (kill-buffer buffer)
1808 (mm-destroy-part mime-part))))))
1809 (soap-error
1810 ;; Propagate soap-errors -- they are error replies of the
1811 ;; SOAP protocol and don't indicate a communication
1812 ;; problem or a bug in this code.
1813 (signal (car err) (cdr err)))
1814 (error
1815 (when soap-debug
1816 (pop-to-buffer buffer))
1817 (error (error-message-string err)))))))))
1818 3103
1819(provide 'soap-client) 3104(provide 'soap-client)
1820 3105
diff --git a/lisp/net/soap-inspect.el b/lisp/net/soap-inspect.el
index 2f9cdcb393e..7182b79c209 100644
--- a/lisp/net/soap-inspect.el
+++ b/lisp/net/soap-inspect.el
@@ -1,9 +1,10 @@
1;;;; soap-inspect.el -- Interactive inspector for soap WSDL structures 1;;;; soap-inspect.el -- Interactive WSDL inspector -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 2010-2015 Free Software Foundation, Inc. 3;; Copyright (C) 2010-2015 Free Software Foundation, Inc.
4 4
5;; Author: Alexandru Harsanyi <AlexHarsanyi@gmail.com> 5;; Author: Alexandru Harsanyi <AlexHarsanyi@gmail.com>
6;; Created: October 2010 6;; Created: October 2010
7;; Version: 3.0.0
7;; Keywords: soap, web-services, comm, hypermedia 8;; Keywords: soap, web-services, comm, hypermedia
8;; Package: soap-client 9;; Package: soap-client
9;; Homepage: http://code.google.com/p/emacs-soap-client 10;; Homepage: http://code.google.com/p/emacs-soap-client
@@ -55,86 +56,153 @@ will be called."
55 (funcall sample-value type) 56 (funcall sample-value type)
56 (error "Cannot provide sample value for type %s" (aref type 0))))) 57 (error "Cannot provide sample value for type %s" (aref type 0)))))
57 58
58(defun soap-sample-value-for-basic-type (type) 59(defun soap-sample-value-for-xs-basic-type (type)
59 "Provide a sample value for TYPE which is a basic type. 60 "Provide a sample value for TYPE, an xs-basic-type.
60This is a specific function which should not be called directly, 61This is a specialization of `soap-sample-value' for xs-basic-type
61use `soap-sample-value' instead." 62objects."
62 (case (soap-basic-type-kind type) 63 (case (soap-xs-basic-type-kind type)
63 (string "a string value") 64 (string "a string")
64 (boolean t) ; could be nil as well 65 (anyURI "an URI")
65 ((long int) (random 4200)) 66 (QName "a QName")
66 ;; TODO: we need better sample values for more types. 67 (dateTime "a time-value-p or string")
67 (t (format "%s" (soap-basic-type-kind type))))) 68 (boolean "t or nil")
68 69 ((long int integer byte unsignedInt) 42)
69(defun soap-sample-value-for-simple-type (type) 70 ((float double) 3.14)
70 "Provide a sample value for TYPE which is a simple type. 71 (base64Binary "a string")
71This is a specific function which should not be called directly, 72 (t (format "%s" (soap-xs-basic-type-kind type)))))
72use `soap-sample-value' instead." 73
73 (let ((enumeration (soap-simple-type-enumeration type))) 74(defun soap-sample-value-for-xs-element (element)
74 (if (> (length enumeration) 1) 75 "Provide a sample value for ELEMENT, a WSDL element.
75 (elt enumeration (random (length enumeration))) 76This is a specialization of `soap-sample-value' for xs-element
76 (soap-sample-value-for-basic-type type)))) 77objects."
77 78 (if (soap-xs-element-name element)
78(defun soap-sample-value-for-seqence-type (type) 79 (cons (intern (soap-xs-element-name element))
79 "Provide a sample value for TYPE which is a sequence type. 80 (soap-sample-value (soap-xs-element-type element)))
80Values for sequence types are ALISTS of (slot-name . VALUE) for 81 (soap-sample-value (soap-xs-element-type element))))
81each sequence element. 82
82 83(defun soap-sample-value-for-xs-attribute (attribute)
83This is a specific function which should not be called directly, 84 "Provide a sample value for ATTRIBUTE, a WSDL attribute.
84use `soap-sample-value' instead." 85This is a specialization of `soap-sample-value' for
85 (let ((sample-value nil)) 86soap-xs-attribute objects."
86 (dolist (element (soap-sequence-type-elements type)) 87 (if (soap-xs-attribute-name attribute)
87 (push (cons (soap-sequence-element-name element) 88 (cons (intern (soap-xs-attribute-name attribute))
88 (soap-sample-value (soap-sequence-element-type element))) 89 (soap-sample-value (soap-xs-attribute-type attribute)))
89 sample-value)) 90 (soap-sample-value (soap-xs-attribute-type attribute))))
90 (when (soap-sequence-type-parent type) 91
91 (setq sample-value 92(defun soap-sample-value-for-xs-attribute-group (attribute-group)
92 (append (soap-sample-value (soap-sequence-type-parent type)) 93 "Provide a sample value for ATTRIBUTE-GROUP, a WSDL attribute group.
93 sample-value))) 94This is a specialization of `soap-sample-value' for
94 sample-value)) 95soap-xs-attribute objects."
95 96 (let ((sample-values nil))
96(defun soap-sample-value-for-array-type (type) 97 (dolist (attribute (soap-xs-attribute-group-attributes attribute-group))
97 "Provide a sample value for TYPE which is an array type. 98 (if (soap-xs-attribute-name attribute)
98Values for array types are LISP vectors of values which are 99 (setq sample-values
99array's element type. 100 (append sample-values
100 101 (cons (intern (soap-xs-attribute-name attribute))
101This is a specific function which should not be called directly, 102 (soap-sample-value (soap-xs-attribute-type
102use `soap-sample-value' instead." 103 attribute)))))
103 (let* ((element-type (soap-array-type-element-type type)) 104 (setq sample-values
104 (sample1 (soap-sample-value element-type)) 105 (append sample-values
105 (sample2 (soap-sample-value element-type))) 106 (soap-sample-value
106 ;; Our sample value is a vector of two elements, but any number of 107 (soap-xs-attribute-type attribute))))))))
107 ;; elements are permissible 108
108 (vector sample1 sample2 '&etc))) 109(defun soap-sample-value-for-xs-simple-type (type)
110 "Provide a sample value for TYPE, a `soap-xs-simple-type'.
111This is a specialization of `soap-sample-value' for
112`soap-xs-simple-type' objects."
113 (append
114 (mapcar 'soap-sample-value-for-xs-attribute
115 (soap-xs-type-attributes type))
116 (cond
117 ((soap-xs-simple-type-enumeration type)
118 (let ((enumeration (soap-xs-simple-type-enumeration type)))
119 (nth (random (length enumeration)) enumeration)))
120 ((soap-xs-simple-type-pattern type)
121 (format "a string matching %s" (soap-xs-simple-type-pattern type)))
122 ((soap-xs-simple-type-length-range type)
123 (destructuring-bind (low . high) (soap-xs-simple-type-length-range type)
124 (cond
125 ((and low high)
126 (format "a string between %d and %d chars long" low high))
127 (low (format "a string at least %d chars long" low))
128 (high (format "a string at most %d chars long" high))
129 (t (format "a string OOPS")))))
130 ((soap-xs-simple-type-integer-range type)
131 (destructuring-bind (min . max) (soap-xs-simple-type-integer-range type)
132 (cond
133 ((and min max) (+ min (random (- max min))))
134 (min (+ min (random 10)))
135 (max (random max))
136 (t (random 100)))))
137 ((consp (soap-xs-simple-type-base type)) ; an union of values
138 (let ((base (soap-xs-simple-type-base type)))
139 (soap-sample-value (nth (random (length base)) base))))
140 ((soap-xs-basic-type-p (soap-xs-simple-type-base type))
141 (soap-sample-value (soap-xs-simple-type-base type))))))
142
143(defun soap-sample-value-for-xs-complex-type (type)
144 "Provide a sample value for TYPE, a `soap-xs-complex-type'.
145This is a specialization of `soap-sample-value' for
146`soap-xs-complex-type' objects."
147 (append
148 (mapcar 'soap-sample-value-for-xs-attribute
149 (soap-xs-type-attributes type))
150 (case (soap-xs-complex-type-indicator type)
151 (array
152 (let* ((element-type (soap-xs-complex-type-base type))
153 (sample1 (soap-sample-value element-type))
154 (sample2 (soap-sample-value element-type)))
155 ;; Our sample value is a vector of two elements, but any number of
156 ;; elements are permissible
157 (vector sample1 sample2 '&etc)))
158 ((sequence choice all)
159 (let ((base (soap-xs-complex-type-base type)))
160 (let ((value (append (and base (soap-sample-value base))
161 (mapcar #'soap-sample-value
162 (soap-xs-complex-type-elements type)))))
163 (if (eq (soap-xs-complex-type-indicator type) 'choice)
164 (cons '***choice-of*** value)
165 value)))))))
109 166
110(defun soap-sample-value-for-message (message) 167(defun soap-sample-value-for-message (message)
111 "Provide a sample value for a WSDL MESSAGE. 168 "Provide a sample value for a WSDL MESSAGE.
112This is a specific function which should not be called directly, 169This is a specialization of `soap-sample-value' for
113use `soap-sample-value' instead." 170`soap-message' objects."
114 ;; NOTE: parameter order is not considered. 171 ;; NOTE: parameter order is not considered.
115 (let (sample-value) 172 (let (sample-value)
116 (dolist (part (soap-message-parts message)) 173 (dolist (part (soap-message-parts message))
117 (push (cons (car part) 174 (push (soap-sample-value (cdr part)) sample-value))
118 (soap-sample-value (cdr part)))
119 sample-value))
120 (nreverse sample-value))) 175 (nreverse sample-value)))
121 176
122(progn 177(progn
123 ;; Install soap-sample-value methods for our types 178 ;; Install soap-sample-value methods for our types
124 (put (aref (make-soap-basic-type) 0) 'soap-sample-value 179 (put (aref (make-soap-xs-basic-type) 0)
125 'soap-sample-value-for-basic-type) 180 'soap-sample-value
181 'soap-sample-value-for-xs-basic-type)
126 182
127 (put (aref (make-soap-simple-type) 0) 'soap-sample-value 183 (put (aref (make-soap-xs-element) 0)
128 'soap-sample-value-for-simple-type) 184 'soap-sample-value
185 'soap-sample-value-for-xs-element)
129 186
130 (put (aref (make-soap-sequence-type) 0) 'soap-sample-value 187 (put (aref (make-soap-xs-attribute) 0)
131 'soap-sample-value-for-seqence-type) 188 'soap-sample-value
189 'soap-sample-value-for-xs-attribute)
132 190
133 (put (aref (make-soap-array-type) 0) 'soap-sample-value 191 (put (aref (make-soap-xs-attribute) 0)
134 'soap-sample-value-for-array-type) 192 'soap-sample-value
193 'soap-sample-value-for-xs-attribute-group)
135 194
136 (put (aref (make-soap-message) 0) 'soap-sample-value 195 (put (aref (make-soap-xs-simple-type) 0)
137 'soap-sample-value-for-message) ) 196 'soap-sample-value
197 'soap-sample-value-for-xs-simple-type)
198
199 (put (aref (make-soap-xs-complex-type) 0)
200 'soap-sample-value
201 'soap-sample-value-for-xs-complex-type)
202
203 (put (aref (make-soap-message) 0)
204 'soap-sample-value
205 'soap-sample-value-for-message))
138 206
139 207
140 208
@@ -184,7 +252,7 @@ entire WSDL can be inspected."
184 252
185 253
186(define-button-type 'soap-client-describe-link 254(define-button-type 'soap-client-describe-link
187 'face 'italic 255 'face 'link
188 'help-echo "mouse-2, RET: describe item" 256 'help-echo "mouse-2, RET: describe item"
189 'follow-link t 257 'follow-link t
190 'action (lambda (button) 258 'action (lambda (button)
@@ -193,10 +261,10 @@ entire WSDL can be inspected."
193 'skip t) 261 'skip t)
194 262
195(define-button-type 'soap-client-describe-back-link 263(define-button-type 'soap-client-describe-back-link
196 'face 'italic 264 'face 'link
197 'help-echo "mouse-2, RET: browse the previous item" 265 'help-echo "mouse-2, RET: browse the previous item"
198 'follow-link t 266 'follow-link t
199 'action (lambda (button) 267 'action (lambda (_button)
200 (let ((item (pop soap-inspect-previous-items))) 268 (let ((item (pop soap-inspect-previous-items)))
201 (when item 269 (when item
202 (setq soap-inspect-current-item nil) 270 (setq soap-inspect-current-item nil)
@@ -210,52 +278,142 @@ entire WSDL can be inspected."
210 'type 'soap-client-describe-link 278 'type 'soap-client-describe-link
211 'item element)) 279 'item element))
212 280
213(defun soap-inspect-basic-type (basic-type) 281(defun soap-inspect-xs-basic-type (type)
214 "Insert information about BASIC-TYPE into the current buffer." 282 "Insert information about TYPE, a soap-xs-basic-type, in the current buffer."
215 (insert "Basic type: " (soap-element-fq-name basic-type)) 283 (insert "Basic type: " (soap-element-fq-name type))
216 (insert "\nSample value\n") 284 (insert "\nSample value:\n")
217 (pp (soap-sample-value basic-type) (current-buffer))) 285 (pp (soap-sample-value type) (current-buffer)))
218 286
219(defun soap-inspect-simple-type (simple-type) 287(defun soap-inspect-xs-element (element)
220 "Insert information about SIMPLE-TYPE into the current buffer" 288 "Insert information about ELEMENT, a soap-xs-element, in the current buffer."
221 (insert "Simple type: " (soap-element-fq-name simple-type) "\n") 289 (insert "Element: " (soap-element-fq-name element))
222 (insert "Base: " (symbol-name (soap-basic-type-kind simple-type)) "\n") 290 (insert "\nType: ")
223 (let ((enumeration (soap-simple-type-enumeration simple-type))) 291 (soap-insert-describe-button (soap-xs-element-type element))
224 (when (> (length enumeration) 1) 292 (insert "\nAttributes:")
225 (insert "Valid values: ") 293 (when (soap-xs-element-optional? element)
226 (dolist (e enumeration) 294 (insert " optional"))
227 (insert "\"" e "\" "))))) 295 (when (soap-xs-element-multiple? element)
228 296 (insert " multiple"))
229(defun soap-inspect-sequence-type (sequence) 297 (insert "\nSample value:\n")
230 "Insert information about SEQUENCE into the current buffer." 298 (pp (soap-sample-value element) (current-buffer)))
231 (insert "Sequence type: " (soap-element-fq-name sequence) "\n") 299
232 (when (soap-sequence-type-parent sequence) 300(defun soap-inspect-xs-attribute (attribute)
233 (insert "Parent: ") 301 "Insert information about ATTRIBUTE, a soap-xs-attribute, in
234 (soap-insert-describe-button 302the current buffer."
235 (soap-sequence-type-parent sequence)) 303 (insert "Attribute: " (soap-element-fq-name attribute))
236 (insert "\n")) 304 (insert "\nType: ")
237 (insert "Elements: \n") 305 (soap-insert-describe-button (soap-xs-attribute-type attribute))
238 (dolist (element (soap-sequence-type-elements sequence))
239 (insert "\t" (symbol-name (soap-sequence-element-name element))
240 "\t")
241 (soap-insert-describe-button
242 (soap-sequence-element-type element))
243 (when (soap-sequence-element-multiple? element)
244 (insert " multiple"))
245 (when (soap-sequence-element-nillable? element)
246 (insert " optional"))
247 (insert "\n"))
248 (insert "Sample value:\n")
249 (pp (soap-sample-value sequence) (current-buffer)))
250
251(defun soap-inspect-array-type (array)
252 "Insert information about the ARRAY into the current buffer."
253 (insert "Array name: " (soap-element-fq-name array) "\n")
254 (insert "Element type: ")
255 (soap-insert-describe-button
256 (soap-array-type-element-type array))
257 (insert "\nSample value:\n") 306 (insert "\nSample value:\n")
258 (pp (soap-sample-value array) (current-buffer))) 307 (pp (soap-sample-value attribute) (current-buffer)))
308
309(defun soap-inspect-xs-attribute-group (attribute-group)
310 "Insert information about ATTRIBUTE-GROUP, a
311soap-xs-attribute-group, in the current buffer."
312 (insert "Attribute group: " (soap-element-fq-name attribute-group))
313 (insert "\nSample values:\n")
314 (pp (soap-sample-value attribute-group) (current-buffer)))
315
316(defun soap-inspect-xs-simple-type (type)
317 "Insert information about TYPE, a soap-xs-simple-type, in the current buffer."
318 (insert "Simple type: " (soap-element-fq-name type))
319 (insert "\nBase: " )
320 (if (listp (soap-xs-simple-type-base type))
321 (let ((first-time t))
322 (dolist (b (soap-xs-simple-type-base type))
323 (unless first-time
324 (insert ", ")
325 (setq first-time nil))
326 (soap-insert-describe-button b)))
327 (soap-insert-describe-button (soap-xs-simple-type-base type)))
328 (insert "\nAttributes: ")
329 (dolist (attribute (soap-xs-simple-type-attributes type))
330 (let ((name (or (soap-xs-attribute-name attribute) "*inline*"))
331 (type (soap-xs-attribute-type attribute)))
332 (insert "\n\t")
333 (insert name)
334 (insert "\t")
335 (soap-insert-describe-button type)))
336 (when (soap-xs-simple-type-enumeration type)
337 (insert "\nEnumeraton values: ")
338 (dolist (e (soap-xs-simple-type-enumeration type))
339 (insert "\n\t")
340 (pp e)))
341 (when (soap-xs-simple-type-pattern type)
342 (insert "\nPattern: " (soap-xs-simple-type-pattern type)))
343 (when (car (soap-xs-simple-type-length-range type))
344 (insert "\nMin length: "
345 (number-to-string (car (soap-xs-simple-type-length-range type)))))
346 (when (cdr (soap-xs-simple-type-length-range type))
347 (insert "\nMin length: "
348 (number-to-string (cdr (soap-xs-simple-type-length-range type)))))
349 (when (car (soap-xs-simple-type-integer-range type))
350 (insert "\nMin value: "
351 (number-to-string (car (soap-xs-simple-type-integer-range type)))))
352 (when (cdr (soap-xs-simple-type-integer-range type))
353 (insert "\nMin value: "
354 (number-to-string (cdr (soap-xs-simple-type-integer-range type)))))
355 (insert "\nSample value:\n")
356 (pp (soap-sample-value type) (current-buffer)))
357
358(defun soap-inspect-xs-complex-type (type)
359 "Insert information about TYPE in the current buffer.
360TYPE is a `soap-xs-complex-type'"
361 (insert "Complex type: " (soap-element-fq-name type))
362 (insert "\nKind: ")
363 (case (soap-xs-complex-type-indicator type)
364 ((sequence all)
365 (insert "a sequence ")
366 (when (soap-xs-complex-type-base type)
367 (insert "extending ")
368 (soap-insert-describe-button (soap-xs-complex-type-base type)))
369 (insert "\nAttributes: ")
370 (dolist (attribute (soap-xs-complex-type-attributes type))
371 (let ((name (or (soap-xs-attribute-name attribute) "*inline*"))
372 (type (soap-xs-attribute-type attribute)))
373 (insert "\n\t")
374 (insert name)
375 (insert "\t")
376 (soap-insert-describe-button type)))
377 (insert "\nElements: ")
378 (let ((name-width 0)
379 (type-width 0))
380 (dolist (element (soap-xs-complex-type-elements type))
381 (let ((name (or (soap-xs-element-name element) "*inline*"))
382 (type (soap-xs-element-type element)))
383 (setq name-width (max name-width (length name)))
384 (setq type-width
385 (max type-width (length (soap-element-fq-name type))))))
386 (setq name-width (+ name-width 2))
387 (setq type-width (+ type-width 2))
388 (dolist (element (soap-xs-complex-type-elements type))
389 (let ((name (or (soap-xs-element-name element) "*inline*"))
390 (type (soap-xs-element-type element)))
391 (insert "\n\t")
392 (insert name)
393 (insert (make-string (- name-width (length name)) ?\ ))
394 (soap-insert-describe-button type)
395 (insert
396 (make-string
397 (- type-width (length (soap-element-fq-name type))) ?\ ))
398 (when (soap-xs-element-multiple? element)
399 (insert " multiple"))
400 (when (soap-xs-element-optional? element)
401 (insert " optional"))))))
402 (choice
403 (insert "a choice ")
404 (when (soap-xs-complex-type-base type)
405 (insert "extending ")
406 (soap-insert-describe-button (soap-xs-complex-type-base type)))
407 (insert "\nElements: ")
408 (dolist (element (soap-xs-complex-type-elements type))
409 (insert "\n\t")
410 (soap-insert-describe-button element)))
411 (array
412 (insert "an array of ")
413 (soap-insert-describe-button (soap-xs-complex-type-base type))))
414 (insert "\nSample value:\n")
415 (pp (soap-sample-value type) (current-buffer)))
416
259 417
260(defun soap-inspect-message (message) 418(defun soap-inspect-message (message)
261 "Insert information about MESSAGE into the current buffer." 419 "Insert information about MESSAGE into the current buffer."
@@ -281,10 +439,11 @@ entire WSDL can be inspected."
281 439
282 (insert "\n\nSample invocation:\n") 440 (insert "\n\nSample invocation:\n")
283 (let ((sample-message-value 441 (let ((sample-message-value
284 (soap-sample-value (cdr (soap-operation-input operation)))) 442 (soap-sample-value (cdr (soap-operation-input operation))))
285 (funcall (list 'soap-invoke '*WSDL* "SomeService" (soap-element-name operation)))) 443 (funcall (list 'soap-invoke '*WSDL* "SomeService"
444 (soap-element-name operation))))
286 (let ((sample-invocation 445 (let ((sample-invocation
287 (append funcall (mapcar 'cdr sample-message-value)))) 446 (append funcall (mapcar 'cdr sample-message-value))))
288 (pp sample-invocation (current-buffer))))) 447 (pp sample-invocation (current-buffer)))))
289 448
290(defun soap-inspect-port-type (port-type) 449(defun soap-inspect-port-type (port-type)
@@ -350,17 +509,23 @@ entire WSDL can be inspected."
350(progn 509(progn
351 ;; Install the soap-inspect methods for our types 510 ;; Install the soap-inspect methods for our types
352 511
353 (put (aref (make-soap-basic-type) 0) 'soap-inspect 512 (put (aref (make-soap-xs-basic-type) 0) 'soap-inspect
354 'soap-inspect-basic-type) 513 'soap-inspect-xs-basic-type)
514
515 (put (aref (make-soap-xs-element) 0) 'soap-inspect
516 'soap-inspect-xs-element)
517
518 (put (aref (make-soap-xs-simple-type) 0) 'soap-inspect
519 'soap-inspect-xs-simple-type)
355 520
356 (put (aref (make-soap-simple-type) 0) 'soap-inspect 521 (put (aref (make-soap-xs-complex-type) 0) 'soap-inspect
357 'soap-inspect-simple-type) 522 'soap-inspect-xs-complex-type)
358 523
359 (put (aref (make-soap-sequence-type) 0) 'soap-inspect 524 (put (aref (make-soap-xs-attribute) 0) 'soap-inspect
360 'soap-inspect-sequence-type) 525 'soap-inspect-xs-attribute)
361 526
362 (put (aref (make-soap-array-type) 0) 'soap-inspect 527 (put (aref (make-soap-xs-attribute-group) 0) 'soap-inspect
363 'soap-inspect-array-type) 528 'soap-inspect-xs-attribute-group)
364 529
365 (put (aref (make-soap-message) 0) 'soap-inspect 530 (put (aref (make-soap-message) 0) 'soap-inspect
366 'soap-inspect-message) 531 'soap-inspect-message)
@@ -376,7 +541,7 @@ entire WSDL can be inspected."
376 (put (aref (make-soap-port) 0) 'soap-inspect 541 (put (aref (make-soap-port) 0) 'soap-inspect
377 'soap-inspect-port) 542 'soap-inspect-port)
378 543
379 (put (aref (make-soap-wsdl) 0) 'soap-inspect 544 (put (aref (soap-make-wsdl "origin") 0) 'soap-inspect
380 'soap-inspect-wsdl)) 545 'soap-inspect-wsdl))
381 546
382(provide 'soap-inspect) 547(provide 'soap-inspect)
generated by cgit v1.2.1 (git 2.18.0) at 2026-02-07 05:28:35 +0000