[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master 069a0e4: Sync with soap-client repository, version
|
From: |
Thomas Fitzsimmons |
|
Subject: |
[Emacs-diffs] master 069a0e4: Sync with soap-client repository, version 3.0.0 |
|
Date: |
Sat, 24 Oct 2015 12:35:58 +0000 |
branch: master
commit 069a0e41f40822f3233333eee33ef6f15a640f0b
Author: Thomas Fitzsimmons <address@hidden>
Commit: Thomas Fitzsimmons <address@hidden>
Sync with soap-client repository, version 3.0.0
---
lisp/net/soap-client.el | 3183 ++++++++++++++++++++++++++++++++--------------
lisp/net/soap-inspect.el | 419 +++++--
2 files changed, 2526 insertions(+), 1076 deletions(-)
diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el
index 509c021..008bbf4 100644
--- a/lisp/net/soap-client.el
+++ b/lisp/net/soap-client.el
@@ -1,9 +1,11 @@
-;;;; soap-client.el -- Access SOAP web services from Emacs
+;;;; soap-client.el -- Access SOAP web services -*- lexical-binding: t
-*-
;; Copyright (C) 2009-2015 Free Software Foundation, Inc.
;; Author: Alexandru Harsanyi <address@hidden>
+;; Author: Thomas Fitzsimmons <address@hidden>
;; Created: December, 2009
+;; Version: 3.0.0
;; Keywords: soap, web-services, comm, hypermedia
;; Package: soap-client
;; Homepage: http://code.google.com/p/emacs-soap-client
@@ -43,10 +45,14 @@
(eval-when-compile (require 'cl))
(require 'xml)
+(require 'xsd-regexp)
+(require 'rng-xsd)
+(require 'rng-dt)
(require 'warnings)
(require 'url)
(require 'url-http)
(require 'url-util)
+(require 'url-vars)
(require 'mm-decode)
(defsubst soap-warning (message &rest args)
@@ -74,13 +80,17 @@
("wsdlsoap" . "http://schemas.xmlsoap.org/wsdl/soap/";)
("xsd" . "http://www.w3.org/2001/XMLSchema";)
("xsi" . "http://www.w3.org/2001/XMLSchema-instance";)
+ ("wsa" . "http://www.w3.org/2005/08/addressing";)
+ ("wsaw" . "http://www.w3.org/2006/05/addressing/wsdl";)
("soap" . "http://schemas.xmlsoap.org/soap/envelope/";)
("soap12" . "http://schemas.xmlsoap.org/wsdl/soap12/";)
("http" . "http://schemas.xmlsoap.org/wsdl/http/";)
- ("mime" . "http://schemas.xmlsoap.org/wsdl/mime/";))
+ ("mime" . "http://schemas.xmlsoap.org/wsdl/mime/";)
+ ("xml" . "http://www.w3.org/XML/1998/namespace";))
"A list of well known xml namespaces and their aliases.")
-(defvar soap-local-xmlns nil
+(defvar soap-local-xmlns
+ '(("xml" . "http://www.w3.org/XML/1998/namespace";))
"A list of local namespace aliases.
This is a dynamically bound variable, controlled by
`soap-with-local-xmlns'.")
@@ -98,6 +108,10 @@ are fully qualified for a different namespace. This is a
dynamically bound variable, controlled by
`soap-with-local-xmlns'")
+(defvar soap-current-wsdl nil
+ "The current WSDL document used when decoding the SOAP response.
+This is a dynamically bound variable.")
+
(defun soap-wk2l (well-known-name)
"Return local variant of WELL-KNOWN-NAME.
This is done by looking up the namespace in the
@@ -106,24 +120,24 @@ the local name based on the current local translation
table
`soap-local-xmlns'. See also `soap-with-local-xmlns'."
(let ((wk-name-1 (if (symbolp well-known-name)
(symbol-name well-known-name)
- well-known-name)))
+ well-known-name)))
(cond
- ((string-match "^\\(.*\\):\\(.*\\)$" wk-name-1)
- (let ((ns (match-string 1 wk-name-1))
- (name (match-string 2 wk-name-1)))
- (let ((namespace (cdr (assoc ns soap-well-known-xmlns))))
- (cond ((equal namespace soap-default-xmlns)
- ;; Name is unqualified in the default namespace
- (if (symbolp well-known-name)
- (intern name)
- name))
- (t
- (let* ((local-ns (car (rassoc namespace soap-local-xmlns)))
- (local-name (concat local-ns ":" name)))
- (if (symbolp well-known-name)
- (intern local-name)
- local-name)))))))
- (t well-known-name))))
+ ((string-match "^\\(.*\\):\\(.*\\)$" wk-name-1)
+ (let ((ns (match-string 1 wk-name-1))
+ (name (match-string 2 wk-name-1)))
+ (let ((namespace (cdr (assoc ns soap-well-known-xmlns))))
+ (cond ((equal namespace soap-default-xmlns)
+ ;; Name is unqualified in the default namespace
+ (if (symbolp well-known-name)
+ (intern name)
+ name))
+ (t
+ (let* ((local-ns (car (rassoc namespace soap-local-xmlns)))
+ (local-name (concat local-ns ":" name)))
+ (if (symbolp well-known-name)
+ (intern local-name)
+ local-name)))))))
+ (t well-known-name))))
(defun soap-l2wk (local-name)
"Convert LOCAL-NAME into a well known name.
@@ -134,40 +148,37 @@ used in the name.
nil is returned if there is no well-known namespace for the
namespace of LOCAL-NAME."
(let ((l-name-1 (if (symbolp local-name)
- (symbol-name local-name)
- local-name))
+ (symbol-name local-name)
+ local-name))
namespace name)
(cond
- ((string-match "^\\(.*\\):\\(.*\\)$" l-name-1)
- (setq name (match-string 2 l-name-1))
- (let ((ns (match-string 1 l-name-1)))
- (setq namespace (cdr (assoc ns soap-local-xmlns)))
- (unless namespace
- (error "Soap-l2wk(%s): no namespace for alias %s" local-name ns))))
- (t
- (setq name l-name-1)
- (setq namespace soap-default-xmlns)))
+ ((string-match "^\\(.*\\):\\(.*\\)$" l-name-1)
+ (setq name (match-string 2 l-name-1))
+ (let ((ns (match-string 1 l-name-1)))
+ (setq namespace (cdr (assoc ns soap-local-xmlns)))
+ (unless namespace
+ (error "Soap-l2wk(%s): no namespace for alias %s" local-name ns))))
+ (t
+ (setq name l-name-1)
+ (setq namespace soap-default-xmlns)))
(if namespace
(let ((well-known-ns (car (rassoc namespace soap-well-known-xmlns))))
(if well-known-ns
(let ((well-known-name (concat well-known-ns ":" name)))
- (if (symbol-name local-name)
+ (if (symbolp local-name)
(intern well-known-name)
- well-known-name))
- (progn
- ;; (soap-warning "soap-l2wk(%s): namespace %s has no
well-known tag"
- ;; local-name namespace)
- nil)))
- ;; if no namespace is defined, just return the unqualified name
- name)))
+ well-known-name))
+ nil))
+ ;; if no namespace is defined, just return the unqualified name
+ name)))
(defun soap-l2fq (local-name &optional use-tns)
"Convert LOCAL-NAME into a fully qualified name.
A fully qualified name is a cons of the namespace name and the
name of the element itself. For example \"xsd:string\" is
-converted to \(\"http://www.w3.org/2001/XMLSchema\"; . \"string\").
+converted to (\"http://www.w3.org/2001/XMLSchema\"; . \"string\").
The USE-TNS argument specifies what to do when LOCAL-NAME has no
namespace 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
different namespace aliases for the same element."
(let ((local-name-1 (if (symbolp local-name)
(symbol-name local-name)
- local-name)))
+ local-name)))
(cond ((string-match "^\\(.*\\):\\(.*\\)$" local-name-1)
(let ((ns (match-string 1 local-name-1))
(name (match-string 2 local-name-1)))
(let ((namespace (cdr (assoc ns soap-local-xmlns))))
(if namespace
(cons namespace name)
- (error "Soap-l2fq(%s): unknown alias %s" local-name ns)))))
+ (error "Soap-l2fq(%s): unknown alias %s" local-name ns)))))
(t
(cons (if use-tns
soap-target-xmlns
- soap-default-xmlns)
- local-name)))))
+ soap-default-xmlns)
+ local-name-1)))))
+
+(defun soap-name-p (name)
+ "Return true if NAME is a valid name for XMLSchema types.
+A valid name is either a string or a cons of (NAMESPACE . NAME)."
+ (or (stringp name)
+ (and (consp name)
+ (stringp (car name))
+ (stringp (cdr name)))))
(defun soap-extract-xmlns (node &optional xmlns-table)
"Return a namespace alias table for NODE by extending XMLNS-TABLE."
@@ -211,16 +230,10 @@ different namespace aliases for the same element."
;; the target namespace.
(unless (equal target-ns (cdr tns))
(soap-warning
- "soap-extract-xmlns(%s): tns alias and targetNamespace mismatch"
- (xml-node-name node))))
+ "soap-extract-xmlns(%s): tns alias and targetNamespace
mismatch"
+ (xml-node-name node))))
((and tns (not target-ns))
- (setq target-ns (cdr tns)))
- ((and (not tns) target-ns)
- ;; a tns alias was not defined in this node. See if the node has
- ;; a "targetNamespace" attribute and add an alias to this. Note
- ;; that we might override an existing tns alias in XMLNS-TABLE,
- ;; but that is intended.
- (push (cons "tns" target-ns) xmlns))))
+ (setq target-ns (cdr tns)))))
(list default-ns target-ns (append xmlns xmlns-table))))
@@ -250,13 +263,21 @@ namespace tag."
(when (and (consp c)
(soap-with-local-xmlns c
;; We use `ignore-errors' here because we want to silently
- ;; skip nodes for which we cannot convert them to a
- ;; well-known name.
+ ;; skip nodes when we cannot convert them to a well-known
+ ;; name.
(eq (ignore-errors (soap-l2wk (xml-node-name c)))
- child-name)))
+ child-name)))
(push c result)))
(nreverse result)))
+(defun soap-xml-node-find-matching-child (node set)
+ "Return the first child of NODE whose name is a member of SET."
+ (catch 'found
+ (dolist (child (xml-node-children node))
+ (when (and (consp child)
+ (memq (soap-l2wk (xml-node-name child)) set))
+ (throw 'found child)))))
+
(defun soap-xml-get-attribute-or-nil1 (node attribute)
"Return the NODE's ATTRIBUTE, or nil if it does not exist.
This is the same as `xml-get-attribute-or-nil', but ATTRIBUTE can
@@ -287,8 +308,13 @@ be tagged with a namespace tag."
"Return a fully qualified name for ELEMENT.
A fq name is the concatenation of the namespace tag and the
element name."
- (concat (soap-element-namespace-tag element)
- ":" (soap-element-name element)))
+ (cond ((soap-element-namespace-tag element)
+ (concat (soap-element-namespace-tag element)
+ ":" (soap-element-name element)))
+ ((soap-element-name element)
+ (soap-element-name element))
+ (t
+ "*unnamed*")))
;; a namespace link stores an alias for an object in once namespace to a
;; "target" object possibly in a different namespace
@@ -311,11 +337,8 @@ discriminant predicate to `soap-namespace-get'"
(let ((name (soap-element-name element)))
(push element (gethash name (soap-namespace-elements ns)))))
-(defun soap-namespace-put-link (name target ns &optional replace)
+(defun soap-namespace-put-link (name target ns)
"Store a link from NAME to TARGET in NS.
-An error will be signaled if an element by the same name is
-already present in NS, unless REPLACE is non nil.
-
TARGET can be either a SOAP-ELEMENT or a string denoting an
element name into another namespace.
@@ -357,34 +380,1563 @@ binding) but the same name."
((= (length elements) 1) (car elements))
((> (length elements) 1)
(error
- "Soap-namespace-get(%s): multiple elements, discriminant needed"
- name))
+ "Soap-namespace-get(%s): multiple elements, discriminant needed"
+ name))
(t
nil))))
-;;;; WSDL documents
-;;;;; WSDL document elements
+;;;; XML Schema
-(defstruct (soap-basic-type (:include soap-element))
- kind ; a symbol of: string, dateTime, long, int
- )
+;; SOAP WSDL documents use XML Schema to define the types that are part of the
+;; message exchange. We include here an XML schema model with a parser and
+;; serializer/deserialiser.
-(defstruct (soap-simple-type (:include soap-basic-type))
- enumeration)
+(defstruct (soap-xs-type (:include soap-element))
+ id
+ attributes
+ attribute-groups)
-(defstruct soap-sequence-element
- name type nillable? multiple?)
+;;;;; soap-xs-basic-type
-(defstruct (soap-sequence-type (:include soap-element))
- parent ; OPTIONAL WSDL-TYPE name
- elements ; LIST of SOAP-SEQUENCE-ELEMENT
+(defstruct (soap-xs-basic-type (:include soap-xs-type))
+ ;; Basic types are "built in" and we know how to handle them directly.
+ ;; Other type definitions reference basic types, so we need to create them
+ ;; in a namespace (see `soap-make-xs-basic-types')
+
+ ;; a symbol of: string, dateTime, long, int, etc
+ kind
)
-(defstruct (soap-array-type (:include soap-element))
- element-type ; WSDL-TYPE of the array elements
+(defun soap-make-xs-basic-types (namespace-name &optional namespace-tag)
+ "Construct NAMESPACE-NAME containing the XMLSchema basic types.
+An optional NAMESPACE-TAG can also be specified."
+ (let ((ns (make-soap-namespace :name namespace-name)))
+ (dolist (type '("string" "language" "ID" "IDREF"
+ "dateTime" "time" "date" "boolean"
+ "gYearMonth" "gYear" "gMonthDay" "gDay" "gMonth"
+ "long" "short" "int" "integer" "nonNegativeInteger"
+ "unsignedLong" "unsignedShort" "unsignedInt"
+ "decimal" "duration"
+ "byte" "unsignedByte"
+ "float" "double"
+ "base64Binary" "anyType" "anyURI" "QName" "Array"
"byte[]"))
+ (soap-namespace-put
+ (make-soap-xs-basic-type :name type
+ :namespace-tag namespace-tag
+ :kind (intern type))
+ ns))
+ ns))
+
+(defun soap-encode-xs-basic-type-attributes (value type)
+ "Encode the XML attributes for VALUE according to TYPE.
+The xsi:type and an optional xsi:nil attributes are added. The
+attributes are inserted in the current buffer at the current
+position.
+
+This is a specialization of `soap-encode-attributes' for
+`soap-xs-basic-type' objects."
+ (let ((xsi-type (soap-element-fq-name type))
+ (basic-type (soap-xs-basic-type-kind type)))
+ ;; try to classify the type based on the value type and use that type when
+ ;; encoding
+ (when (eq basic-type 'anyType)
+ (cond ((stringp value)
+ (setq xsi-type "xsd:string" basic-type 'string))
+ ((integerp value)
+ (setq xsi-type "xsd:int" basic-type 'int))
+ ((memq value '(t nil))
+ (setq xsi-type "xsd:boolean" basic-type 'boolean))
+ (t
+ (error "Cannot classify anyType value"))))
+
+ (insert " xsi:type=\"" xsi-type "\"")
+ ;; We have some ambiguity here, as a nil value represents "false" when the
+ ;; type is boolean, we will never have a "nil" boolean type...
+ (unless (or value (eq basic-type 'boolean))
+ (insert " xsi:nil=\"true\""))))
+
+(defun soap-encode-xs-basic-type (value type)
+ "Encode the VALUE according to TYPE.
+The data is inserted in the current buffer at the current
+position.
+
+This is a specialization of `soap-encode-value' for
+`soap-xs-basic-type' objects."
+ (let ((kind (soap-xs-basic-type-kind type)))
+
+ (when (eq kind 'anyType)
+ (cond ((stringp value)
+ (setq kind 'string))
+ ((integerp value)
+ (setq kind 'int))
+ ((memq value '(t nil))
+ (setq kind 'boolean))
+ (t
+ (error "Cannot classify anyType value"))))
+
+ ;; NOTE: a nil value is not encoded, as an xsi:nil="true" attribute was
+ ;; encoded for it. However, we have some ambiguity here, as a nil value
+ ;; also represents "false" when the type is boolean...
+
+ (when (or value (eq kind 'boolean))
+ (let ((value-string
+ (case kind
+ ((string anyURI QName ID IDREF language)
+ (unless (stringp value)
+ (error "Not a string value: %s" value))
+ (url-insert-entities-in-string value))
+ ((dateTime time date gYearMonth gYear gMonthDay gDay gMonth)
+ (cond ((consp value)
+ ;; Value is a (current-time) style value,
+ ;; convert to the ISO 8601-inspired XSD
+ ;; string format in UTC.
+ (format-time-string
+ (concat
+ (ecase kind
+ (dateTime "%Y-%m-%dT%H:%M:%S")
+ (time "%H:%M:%S")
+ (date "%Y-%m-%d")
+ (gYearMonth "%Y-%m")
+ (gYear "%Y")
+ (gMonthDay "--%m-%d")
+ (gDay "---%d")
+ (gMonth "--%m"))
+ ;; Internal time is always in UTC.
+ "Z")
+ value t))
+ ((stringp value)
+ ;; Value is a string in the ISO 8601-inspired XSD
+ ;; format. Validate it.
+ (soap-decode-date-time value kind)
+ (url-insert-entities-in-string value))
+ (t
+ (error "Invalid date-time format"))))
+ (boolean
+ (unless (memq value '(t nil))
+ (error "Not a boolean value"))
+ (if value "true" "false"))
+
+ ((long short int integer byte unsignedInt unsignedLong
+ unsignedShort nonNegativeInteger decimal duration)
+ (unless (integerp value)
+ (error "Not an integer value"))
+ (when (and (memq kind '(unsignedInt unsignedLong
+ unsignedShort
+ nonNegativeInteger))
+ (< value 0))
+ (error "Not a positive integer"))
+ (number-to-string value))
+
+ ((float double)
+ (unless (numberp value)
+ (error "Not a number"))
+ (number-to-string value))
+
+ (base64Binary
+ (unless (stringp value)
+ (error "Not a string value for base64Binary"))
+ (base64-encode-string value))
+
+ (otherwise
+ (error "Don't know how to encode %s for type %s"
+ value (soap-element-fq-name type))))))
+ (soap-validate-xs-basic-type value-string type)
+ (insert value-string)))))
+
+;; Inspired by rng-xsd-convert-date-time.
+(defun soap-decode-date-time (date-time-string datatype)
+ "Decode DATE-TIME-STRING as DATATYPE.
+DATE-TIME-STRING should be in ISO 8601 basic or extended format.
+DATATYPE is one of dateTime, time, date, gYearMonth, gYear,
+gMonthDay, gDay or gMonth.
+
+Return a list in a format (SEC MINUTE HOUR DAY MONTH YEAR
+SEC-FRACTION DATATYPE ZONE). This format is meant to be similar
+to that returned by `decode-time' (and compatible with
+`encode-time'). The differences are the DOW (day-of-week) field
+is replaced with SEC-FRACTION, a float representing the
+fractional seconds, and the DST (daylight savings time) field is
+replaced with DATATYPE, a symbol representing the XSD primitive
+datatype. This symbol can be used to determine which fields
+apply and which don't when it's not already clear from context.
+For example a datatype of 'time means the year, month and day
+fields should be ignored.
+
+This function will throw an error if DATE-TIME-STRING represents
+a leap second, since the XML Schema 1.1 standard explicitly
+disallows them."
+ (let* ((datetime-regexp (cadr (get datatype 'rng-xsd-convert)))
+ (year-sign (progn
+ (string-match datetime-regexp date-time-string)
+ (match-string 1 date-time-string)))
+ (year (match-string 2 date-time-string))
+ (month (match-string 3 date-time-string))
+ (day (match-string 4 date-time-string))
+ (hour (match-string 5 date-time-string))
+ (minute (match-string 6 date-time-string))
+ (second (match-string 7 date-time-string))
+ (second-fraction (match-string 8 date-time-string))
+ (has-time-zone (match-string 9 date-time-string))
+ (time-zone-sign (match-string 10 date-time-string))
+ (time-zone-hour (match-string 11 date-time-string))
+ (time-zone-minute (match-string 12 date-time-string)))
+ (setq year-sign (if year-sign -1 1))
+ (setq year
+ (if year
+ (* year-sign
+ (string-to-number year))
+ ;; By defaulting to the epoch date, a time value can be treated as
+ ;; a relative number of seconds.
+ 1970))
+ (setq month
+ (if month (string-to-number month) 1))
+ (setq day
+ (if day (string-to-number day) 1))
+ (setq hour
+ (if hour (string-to-number hour) 0))
+ (setq minute
+ (if minute (string-to-number minute) 0))
+ (setq second
+ (if second (string-to-number second) 0))
+ (setq second-fraction
+ (if second-fraction
+ (float (string-to-number second-fraction))
+ 0.0))
+ (setq has-time-zone (and has-time-zone t))
+ (setq time-zone-sign
+ (if (equal time-zone-sign "-") -1 1))
+ (setq time-zone-hour
+ (if time-zone-hour (string-to-number time-zone-hour) 0))
+ (setq time-zone-minute
+ (if time-zone-minute (string-to-number time-zone-minute) 0))
+ (unless (and
+ ;; XSD does not allow year 0.
+ (> year 0)
+ (>= month 1) (<= month 12)
+ (>= day 1) (<= day (rng-xsd-days-in-month year month))
+ (>= hour 0) (<= hour 23)
+ (>= minute 0) (<= minute 59)
+ ;; 60 represents a leap second, but leap seconds are explicitly
+ ;; disallowed by the XML Schema 1.1 specification. This agrees
+ ;; with typical Emacs installations, which don't count leap
+ ;; seconds in time values.
+ (>= second 0) (<= second 59)
+ (>= time-zone-hour 0)
+ (<= time-zone-hour 23)
+ (>= time-zone-minute 0)
+ (<= time-zone-minute 59))
+ (error "Invalid or unsupported time: %s" date-time-string))
+ ;; Return a value in a format similar to that returned by decode-time, and
+ ;; suitable for (apply 'encode-time ...).
+ (list second minute hour day month year second-fraction datatype
+ (if has-time-zone
+ (* (rng-xsd-time-to-seconds
+ time-zone-hour
+ time-zone-minute
+ 0)
+ time-zone-sign)
+ ;; UTC.
+ 0))))
+
+(defun soap-decode-xs-basic-type (type node)
+ "Use TYPE, a `soap-xs-basic-type', to decode the contents of NODE.
+A LISP value is returned based on the contents of NODE and the
+type-info stored in TYPE.
+
+This is a specialization of `soap-decode-type' for
+`soap-xs-basic-type' objects."
+ (let ((contents (xml-node-children node))
+ (kind (soap-xs-basic-type-kind type))
+ (attributes (xml-node-attributes node))
+ (validate-type type)
+ (is-nil nil))
+
+ (dolist (attribute attributes)
+ (let ((attribute-type (soap-l2fq (car attribute)))
+ (attribute-value (cdr attribute)))
+ ;; xsi:type can override an element's expected type.
+ (when (equal attribute-type (soap-l2fq "xsi:type"))
+ (setq validate-type
+ (soap-wsdl-get attribute-value soap-current-wsdl)))
+ ;; xsi:nil can specify that an element is nil in which case we don't
+ ;; validate it.
+ (when (equal attribute-type (soap-l2fq "xsi:nil"))
+ (setq is-nil (string= (downcase attribute-value) "true")))))
+
+ (unless is-nil
+ ;; For validation purposes, when xml-node-children returns nil, treat it
+ ;; as the empty string.
+ (soap-validate-xs-basic-type (car (or contents (list "")))
validate-type))
+
+ (if (null contents)
+ nil
+ (ecase kind
+ ((string anyURI QName ID IDREF language) (car contents))
+ ((dateTime time date gYearMonth gYear gMonthDay gDay gMonth)
+ (car contents))
+ ((long short int integer
+ unsignedInt unsignedLong unsignedShort nonNegativeInteger
+ decimal byte float double duration)
+ (string-to-number (car contents)))
+ (boolean (string= (downcase (car contents)) "true"))
+ (base64Binary (base64-decode-string (car contents)))
+ (anyType (soap-decode-any-type node))
+ (Array (soap-decode-array node))))))
+
+;; Register methods for `soap-xs-basic-type'
+(let ((tag (aref (make-soap-xs-basic-type) 0)))
+ (put tag 'soap-attribute-encoder #'soap-encode-xs-basic-type-attributes)
+ (put tag 'soap-encoder #'soap-encode-xs-basic-type)
+ (put tag 'soap-decoder #'soap-decode-xs-basic-type))
+
+;;;;; soap-xs-element
+
+(defstruct (soap-xs-element (:include soap-element))
+ ;; NOTE: we don't support exact number of occurrences via minOccurs,
+ ;; maxOccurs. Instead we support optional? and multiple?
+
+ id
+ type^ ; note: use soap-xs-element-type to retrieve this member
+ optional?
+ multiple?
+ reference
+ substitution-group
+ ;; contains a list of elements who point to this one via their
+ ;; substitution-group slot
+ alternatives
+ is-group)
+
+(defun soap-xs-element-type (element)
+ "Retrieve the type of ELEMENT.
+This is normally stored in the TYPE^ slot, but if this element
+contains a reference, we retrive the type of the reference."
+ (if (soap-xs-element-reference element)
+ (soap-xs-element-type (soap-xs-element-reference element))
+ (soap-xs-element-type^ element)))
+
+(defun soap-node-optional (node)
+ "Return t if NODE specifies an optional element."
+ (or (equal (xml-get-attribute-or-nil node 'nillable) "true")
+ (let ((e (xml-get-attribute-or-nil node 'minOccurs)))
+ (and e (equal e "0")))))
+
+(defun soap-node-multiple (node)
+ "Return t if NODE permits multiple elements."
+ (let* ((e (xml-get-attribute-or-nil node 'maxOccurs)))
+ (and e (not (equal e "1")))))
+
+(defun soap-xs-parse-element (node)
+ "Construct a `soap-xs-element' from NODE."
+ (let ((name (xml-get-attribute-or-nil node 'name))
+ (id (xml-get-attribute-or-nil node 'id))
+ (type (xml-get-attribute-or-nil node 'type))
+ (optional? (soap-node-optional node))
+ (multiple? (soap-node-multiple node))
+ (ref (xml-get-attribute-or-nil node 'ref))
+ (substitution-group (xml-get-attribute-or-nil node 'substitutionGroup))
+ (node-name (soap-l2wk (xml-node-name node))))
+ (assert (memq node-name '(xsd:element xsd:group))
+ "expecting xsd:element or xsd:group, got %s" node-name)
+
+ (when type
+ (setq type (soap-l2fq type 'tns)))
+
+ (when ref
+ (setq ref (soap-l2fq ref 'tns)))
+
+ (when substitution-group
+ (setq substitution-group (soap-l2fq substitution-group 'tns)))
+
+ (unless (or ref type)
+ ;; no type specified and this is not a reference. Must be a type
+ ;; defined within this node.
+ (let ((simple-type (soap-xml-get-children1 node 'xsd:simpleType)))
+ (if simple-type
+ (setq type (soap-xs-parse-simple-type (car simple-type)))
+ ;; else
+ (let ((complex-type (soap-xml-get-children1 node 'xsd:complexType)))
+ (if complex-type
+ (setq type (soap-xs-parse-complex-type (car complex-type)))
+ ;; else
+ (error "Soap-xs-parse-element: missing type or ref"))))))
+
+ (make-soap-xs-element :name name
+ ;; Use the full namespace name for now, we will
+ ;; convert it to a nstag in
+ ;; `soap-resolve-references-for-xs-element'
+ :namespace-tag soap-target-xmlns
+ :id id :type^ type
+ :optional? optional? :multiple? multiple?
+ :reference ref
+ :substitution-group substitution-group
+ :is-group (eq node-name 'xsd:group))))
+
+(defun soap-resolve-references-for-xs-element (element wsdl)
+ "Replace names in ELEMENT with the referenced objects in the WSDL.
+This is a specialization of `soap-resolve-references' for
+`soap-xs-element' objects.
+
+See also `soap-wsdl-resolve-references'."
+
+ (let ((namespace (soap-element-namespace-tag element)))
+ (when namespace
+ (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl)))))
+ (when nstag
+ (setf (soap-element-namespace-tag element) nstag)))))
+
+ (let ((type (soap-xs-element-type^ element)))
+ (cond ((soap-name-p type)
+ (setf (soap-xs-element-type^ element)
+ (soap-wsdl-get type wsdl 'soap-xs-type-p)))
+ ((soap-xs-type-p type)
+ ;; an inline defined type, this will not be reached from anywhere
+ ;; else, so we must resolve references now.
+ (soap-resolve-references type wsdl))))
+ (let ((reference (soap-xs-element-reference element)))
+ (when (and (soap-name-p reference)
+ ;; xsd:group reference nodes will be converted to inline types
+ ;; by soap-resolve-references-for-xs-complex-type, so skip them
+ ;; here.
+ (not (soap-xs-element-is-group element)))
+ (setf (soap-xs-element-reference element)
+ (soap-wsdl-get reference wsdl 'soap-xs-element-p))))
+
+ (let ((subst (soap-xs-element-substitution-group element)))
+ (when (soap-name-p subst)
+ (let ((target (soap-wsdl-get subst wsdl)))
+ (if target
+ (push element (soap-xs-element-alternatives target))
+ (soap-warning "No target found for substitution-group" subst))))))
+
+(defun soap-encode-xs-element-attributes (value element)
+ "Encode the XML attributes for VALUE according to ELEMENT.
+Currently no attributes are needed.
+
+This is a specialization of `soap-encode-attributes' for
+`soap-xs-basic-type' objects."
+ ;; Use the variables to suppress checkdoc and compiler warnings.
+ (list value element)
+ nil)
+
+(defun soap-should-encode-value-for-xs-element (value element)
+ "Return t if VALUE should be encoded for ELEMENT, nil otherwise."
+ (cond
+ ;; if value is not nil, attempt to encode it
+ (value)
+
+ ;; value is nil, but the element's type is a boolean, so nil in this case
+ ;; means "false". We need to encode it.
+ ((let ((type (soap-xs-element-type element)))
+ (and (soap-xs-basic-type-p type)
+ (eq (soap-xs-basic-type-kind type) 'boolean))))
+
+ ;; This is not an optional element. Force encoding it (although this
+ ;; might fail at the validation step, but this is what we intend.
+
+ ;; value is nil, but the element's type has some attributes which supply a
+ ;; default value. We need to encode it.
+
+ ((let ((type (soap-xs-element-type element)))
+ (catch 'found
+ (dolist (a (soap-xs-type-attributes type))
+ (when (soap-xs-attribute-default a)
+ (throw 'found t))))))
+
+ ;; otherwise, we don't need to encode it
+ (t nil)))
+
+(defun soap-type-is-array? (type)
+ "Return t if TYPE defines an ARRAY."
+ (and (soap-xs-complex-type-p type)
+ (eq (soap-xs-complex-type-indicator type) 'array)))
+
+(defvar soap-encoded-namespaces nil
+ "A list of namespace tags used during encoding a message.
+This list is populated by `soap-encode-value' and used by
+`soap-create-envelope' to add aliases for these namespace to the
+XML request.
+
+This variable is dynamically bound in `soap-create-envelope'.")
+
+(defun soap-encode-xs-element (value element)
+ "Encode the VALUE according to ELEMENT.
+The data is inserted in the current buffer at the current
+position.
+
+This is a specialization of `soap-encode-value' for
+`soap-xs-basic-type' objects."
+ (let ((fq-name (soap-element-fq-name element))
+ (type (soap-xs-element-type element)))
+ ;; Only encode the element if it has a name. NOTE: soap-element-fq-name
+ ;; will return *unnamed* for such elements
+ (if (soap-element-name element)
+ ;; Don't encode this element if value is nil. However, even if value
+ ;; is nil we still want to encode this element if it has any attributes
+ ;; with default values.
+ (when (soap-should-encode-value-for-xs-element value element)
+ (progn
+ (insert "<" fq-name)
+ (soap-encode-attributes value type)
+ ;; If value is nil and type is boolean encode the value as "false".
+ ;; Otherwise don't encode the value.
+ (if (or value (and (soap-xs-basic-type-p type)
+ (eq (soap-xs-basic-type-kind type) 'boolean)))
+ (progn (insert ">")
+ ;; ARRAY's need special treatment, as each element of
+ ;; the array is encoded with the same tag as the
+ ;; current element...
+ (if (soap-type-is-array? type)
+ (let ((new-element (copy-soap-xs-element element)))
+ (when (soap-element-namespace-tag type)
+ (add-to-list 'soap-encoded-namespaces
+ (soap-element-namespace-tag type)))
+ (setf (soap-xs-element-type^ new-element)
+ (soap-xs-complex-type-base type))
+ (loop for i below (length value)
+ do (progn
+ (soap-encode-xs-element (aref value i)
new-element)
+ )))
+ (soap-encode-value value type))
+ (insert "</" fq-name ">\n"))
+ ;; else
+ (insert "/>\n"))))
+ (when (soap-should-encode-value-for-xs-element value element)
+ (soap-encode-value value type)))))
+
+(defun soap-decode-xs-element (element node)
+ "Use ELEMENT, a `soap-xs-element', to decode the contents of NODE.
+A LISP value is returned based on the contents of NODE and the
+type-info stored in ELEMENT.
+
+This is a specialization of `soap-decode-type' for
+`soap-xs-basic-type' objects."
+ (let ((type (soap-xs-element-type element)))
+ (soap-decode-type type node)))
+
+;; Register methods for `soap-xs-element'
+(let ((tag (aref (make-soap-xs-element) 0)))
+ (put tag 'soap-resolve-references #'soap-resolve-references-for-xs-element)
+ (put tag 'soap-attribute-encoder #'soap-encode-xs-element-attributes)
+ (put tag 'soap-encoder #'soap-encode-xs-element)
+ (put tag 'soap-decoder #'soap-decode-xs-element))
+
+;;;;; soap-xs-attribute
+
+(defstruct (soap-xs-attribute (:include soap-element))
+ type ; a simple type or basic type
+ default ; the default value, if any
+ reference)
+
+(defstruct (soap-xs-attribute-group (:include soap-xs-type))
+ reference)
+
+(defun soap-xs-parse-attribute (node)
+ "Construct a `soap-xs-attribute' from NODE."
+ (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:attribute)
+ "expecting xsd:attribute, got %s" (soap-l2wk (xml-node-name node)))
+ (let* ((name (xml-get-attribute-or-nil node 'name))
+ (type (soap-l2fq (xml-get-attribute-or-nil node 'type)))
+ (default (xml-get-attribute-or-nil node 'fixed))
+ (attribute (xml-get-attribute-or-nil node 'ref))
+ (ref (when attribute (soap-l2fq attribute))))
+ (unless (or type ref)
+ (setq type (soap-xs-parse-simple-type
+ (soap-xml-node-find-matching-child
+ node '(xsd:restriction xsd:list xsd:union)))))
+ (make-soap-xs-attribute
+ :name name :type type :default default :reference ref)))
+
+(defun soap-xs-parse-attribute-group (node)
+ "Construct a `soap-xs-attribute-group' from NODE."
+ (let ((node-name (soap-l2wk (xml-node-name node))))
+ (assert (eq node-name 'xsd:attributeGroup)
+ "expecting xsd:attributeGroup, got %s" node-name)
+ (let ((name (xml-get-attribute-or-nil node 'name))
+ (id (xml-get-attribute-or-nil node 'id))
+ (ref (xml-get-attribute-or-nil node 'ref))
+ attribute-group)
+ (when (and name ref)
+ (soap-warning "name and ref set for attribute group %s" node-name))
+ (setq attribute-group
+ (make-soap-xs-attribute-group :id id
+ :name name
+ :reference (and ref (soap-l2fq
ref))))
+ (when (not ref)
+ (dolist (child (xml-node-children node))
+ ;; Ignore whitespace.
+ (unless (stringp child)
+ ;; Ignore optional annotation.
+ ;; Ignore anyAttribute nodes.
+ (case (soap-l2wk (xml-node-name child))
+ (xsd:attribute
+ (push (soap-xs-parse-attribute child)
+ (soap-xs-type-attributes attribute-group)))
+ (xsd:attributeGroup
+ (push (soap-xs-parse-attribute-group child)
+ (soap-xs-attribute-group-attribute-groups
+ attribute-group)))))))
+ attribute-group)))
+
+(defun soap-resolve-references-for-xs-attribute (attribute wsdl)
+ "Replace names in ATTRIBUTE with the referenced objects in the WSDL.
+This is a specialization of `soap-resolve-references' for
+`soap-xs-attribute' objects.
+
+See also `soap-wsdl-resolve-references'."
+ (let* ((type (soap-xs-attribute-type attribute))
+ (reference (soap-xs-attribute-reference attribute))
+ (predicate 'soap-xs-element-p)
+ (xml-reference
+ (and (soap-name-p reference)
+ (equal (car reference)
"http://www.w3.org/XML/1998/namespace";))))
+ (cond (xml-reference
+ ;; Convert references to attributes defined by the XML
+ ;; schema (xml:base, xml:lang, xml:space and xml:id) to
+ ;; xsd:string, to avoid needing to bundle and parse
+ ;; xml.xsd.
+ (setq reference '("http://www.w3.org/2001/XMLSchema"; . "string"))
+ (setq predicate 'soap-xs-basic-type-p))
+ ((soap-name-p type)
+ (setf (soap-xs-attribute-type attribute)
+ (soap-wsdl-get type wsdl
+ (lambda (type)
+ (or (soap-xs-basic-type-p type)
+ (soap-xs-simple-type-p type))))))
+ ((soap-xs-type-p type)
+ ;; an inline defined type, this will not be reached from anywhere
+ ;; else, so we must resolve references now.
+ (soap-resolve-references type wsdl)))
+ (when (soap-name-p reference)
+ (setf (soap-xs-attribute-reference attribute)
+ (soap-wsdl-get reference wsdl predicate)))))
+
+(put (aref (make-soap-xs-attribute) 0)
+ 'soap-resolve-references #'soap-resolve-references-for-xs-attribute)
+
+(defun soap-resolve-references-for-xs-attribute-group (attribute-group wsdl)
+ "Set slots in ATTRIBUTE-GROUP to the referenced objects in the WSDL.
+This is a specialization of `soap-resolve-references' for
+`soap-xs-attribute-group' objects.
+
+See also `soap-wsdl-resolve-references'."
+ (let ((reference (soap-xs-attribute-group-reference attribute-group)))
+ (when (soap-name-p reference)
+ (let ((resolved (soap-wsdl-get reference wsdl
+ 'soap-xs-attribute-group-p)))
+ (dolist (attribute (soap-xs-attribute-group-attributes resolved))
+ (soap-resolve-references attribute wsdl))
+ (setf (soap-xs-attribute-group-name attribute-group)
+ (soap-xs-attribute-group-name resolved))
+ (setf (soap-xs-attribute-group-id attribute-group)
+ (soap-xs-attribute-group-id resolved))
+ (setf (soap-xs-attribute-group-reference attribute-group) nil)
+ (setf (soap-xs-attribute-group-attributes attribute-group)
+ (soap-xs-attribute-group-attributes resolved))
+ (setf (soap-xs-attribute-group-attribute-groups attribute-group)
+ (soap-xs-attribute-group-attribute-groups resolved))))))
+
+(put (aref (make-soap-xs-attribute-group) 0)
+ 'soap-resolve-references #'soap-resolve-references-for-xs-attribute-group)
+
+;;;;; soap-xs-simple-type
+
+(defstruct (soap-xs-simple-type (:include soap-xs-type))
+ ;; A simple type is an extension on the basic type to which some
+ ;; restrictions can be added. For example we can define a simple type based
+ ;; off "string" with the restrictions that only the strings "one", "two" and
+ ;; "three" are valid values (this is an enumeration).
+
+ base ; can be a single type, or a list of types for union types
+ enumeration ; nil, or list of permitted values for the type
+ pattern ; nil, or value must match this pattern
+ length-range ; a cons of (min . max) length, inclusive range.
+ ; For exact length, use (l, l).
+ ; nil means no range,
+ ; (nil . l) means no min range,
+ ; (l . nil) means no max range.
+ integer-range ; a pair of (min, max) integer values, inclusive range,
+ ; same meaning as `length-range'
+ is-list ; t if this is an xs:list, nil otherwise
)
+(defun soap-xs-parse-simple-type (node)
+ "Construct an `soap-xs-simple-type' object from the XML NODE."
+ (assert (memq (soap-l2wk (xml-node-name node))
+ '(xsd:simpleType xsd:simpleContent))
+ nil
+ "expecting xsd:simpleType or xsd:simpleContent node, got %s"
+ (soap-l2wk (xml-node-name node)))
+
+ ;; NOTE: name can be nil for inline types. Such types cannot be added to a
+ ;; namespace.
+ (let ((name (xml-get-attribute-or-nil node 'name))
+ (id (xml-get-attribute-or-nil node 'id)))
+
+ (let ((type (make-soap-xs-simple-type
+ :name name :namespace-tag soap-target-xmlns :id id))
+ (def (soap-xml-node-find-matching-child
+ node '(xsd:restriction xsd:extension xsd:union xsd:list))))
+ (ecase (soap-l2wk (xml-node-name def))
+ (xsd:restriction (soap-xs-add-restriction def type))
+ (xsd:extension (soap-xs-add-extension def type))
+ (xsd:union (soap-xs-add-union def type))
+ (xsd:list (soap-xs-add-list def type)))
+
+ type)))
+
+(defun soap-xs-add-restriction (node type)
+ "Add restrictions defined in XML NODE to TYPE, an `soap-xs-simple-type'."
+
+ (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:restriction)
+ nil
+ "expecting xsd:restriction node, got %s"
+ (soap-l2wk (xml-node-name node)))
+
+ (setf (soap-xs-simple-type-base type)
+ (soap-l2fq (xml-get-attribute node 'base)))
+
+ (dolist (r (xml-node-children node))
+ (unless (stringp r) ; skip the white space
+ (let ((value (xml-get-attribute r 'value)))
+ (case (soap-l2wk (xml-node-name r))
+ (xsd:enumeration
+ (push value (soap-xs-simple-type-enumeration type)))
+ (xsd:pattern
+ (setf (soap-xs-simple-type-pattern type)
+ (concat "\\`" (xsdre-translate value) "\\'")))
+ (xsd:length
+ (let ((value (string-to-number value)))
+ (setf (soap-xs-simple-type-length-range type)
+ (cons value value))))
+ (xsd:minLength
+ (let ((value (string-to-number value)))
+ (setf (soap-xs-simple-type-length-range type)
+ (if (soap-xs-simple-type-length-range type)
+ (cons value
+ (cdr (soap-xs-simple-type-length-range type)))
+ ;; else
+ (cons value nil)))))
+ (xsd:maxLength
+ (let ((value (string-to-number value)))
+ (setf (soap-xs-simple-type-length-range type)
+ (if (soap-xs-simple-type-length-range type)
+ (cons (car (soap-xs-simple-type-length-range type))
+ value)
+ ;; else
+ (cons nil value)))))
+ (xsd:minExclusive
+ (let ((value (string-to-number value)))
+ (setf (soap-xs-simple-type-integer-range type)
+ (if (soap-xs-simple-type-integer-range type)
+ (cons (1+ value)
+ (cdr (soap-xs-simple-type-integer-range type)))
+ ;; else
+ (cons (1+ value) nil)))))
+ (xsd:maxExclusive
+ (let ((value (string-to-number value)))
+ (setf (soap-xs-simple-type-integer-range type)
+ (if (soap-xs-simple-type-integer-range type)
+ (cons (car (soap-xs-simple-type-integer-range type))
+ (1- value))
+ ;; else
+ (cons nil (1- value))))))
+ (xsd:minInclusive
+ (let ((value (string-to-number value)))
+ (setf (soap-xs-simple-type-integer-range type)
+ (if (soap-xs-simple-type-integer-range type)
+ (cons value
+ (cdr (soap-xs-simple-type-integer-range type)))
+ ;; else
+ (cons value nil)))))
+ (xsd:maxInclusive
+ (let ((value (string-to-number value)))
+ (setf (soap-xs-simple-type-integer-range type)
+ (if (soap-xs-simple-type-integer-range type)
+ (cons (car (soap-xs-simple-type-integer-range type))
+ value)
+ ;; else
+ (cons nil value))))))))))
+
+(defun soap-xs-add-union (node type)
+ "Add union members defined in XML NODE to TYPE, an `soap-xs-simple-type'."
+ (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:union)
+ nil
+ "expecting xsd:union node, got %s" (soap-l2wk (xml-node-name node)))
+
+ (setf (soap-xs-simple-type-base type)
+ (mapcar 'soap-l2fq
+ (split-string
+ (or (xml-get-attribute-or-nil node 'memberTypes) ""))))
+
+ ;; Additional simple types can be defined inside the union node. Add them
+ ;; to the base list. The "memberTypes" members will have to be resolved by
+ ;; the "resolve-references" method, the inline types will not.
+ (let (result)
+ (dolist (simple-type (soap-xml-get-children1 node 'xsd:simpleType))
+ (push (soap-xs-parse-simple-type simple-type) result))
+ (setf (soap-xs-simple-type-base type)
+ (append (soap-xs-simple-type-base type) (nreverse result)))))
+
+(defun soap-xs-add-list (node type)
+ "Add list defined in XML NODE to TYPE, a `soap-xs-simple-type'."
+ (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:list)
+ nil
+ "expecting xsd:list node, got %s" (soap-l2wk (xml-node-name node)))
+
+ ;; A simple type can be defined inline inside the list node or referenced by
+ ;; the itemType attribute, in which case it will be resolved by the
+ ;; resolve-references method.
+ (let* ((item-type (xml-get-attribute-or-nil node 'itemType))
+ (children (soap-xml-get-children1 node 'xsd:simpleType)))
+ (if item-type
+ (if (= (length children) 0)
+ (setf (soap-xs-simple-type-base type) (soap-l2fq item-type))
+ (soap-warning
+ "xsd:list node with itemType has more than zero children: %s"
+ (soap-xs-type-name type)))
+ (if (= (length children) 1)
+ (setf (soap-xs-simple-type-base type)
+ (soap-xs-parse-simple-type
+ (car (soap-xml-get-children1 node 'xsd:simpleType))))
+ (soap-warning "xsd:list node has more than one child %s"
+ (soap-xs-type-name type))))
+ (setf (soap-xs-simple-type-is-list type) t)))
+
+(defun soap-xs-add-extension (node type)
+ "Add the extended type defined in XML NODE to TYPE, an
`soap-xs-simple-type'."
+ (setf (soap-xs-simple-type-base type)
+ (soap-l2fq (xml-get-attribute node 'base)))
+ (dolist (attribute (soap-xml-get-children1 node 'xsd:attribute))
+ (push (soap-xs-parse-attribute attribute)
+ (soap-xs-type-attributes type)))
+ (dolist (attribute-group (soap-xml-get-children1 node 'xsd:attributeGroup))
+ (push (soap-xs-parse-attribute-group attribute-group)
+ (soap-xs-type-attribute-groups type))))
+
+(defun soap-validate-xs-basic-type (value type)
+ "Validate VALUE against the basic type TYPE."
+ (let* ((kind (soap-xs-basic-type-kind type)))
+ (case kind
+ ((anyType Array byte[])
+ value)
+ (t
+ (let ((convert (get kind 'rng-xsd-convert)))
+ (if convert
+ (if (rng-dt-make-value convert value)
+ value
+ (error "Invalid %s: %s" (symbol-name kind) value))
+ (error "Don't know how to convert %s" kind)))))))
+
+(defun soap-validate-xs-simple-type (value type)
+ "Validate VALUE against the restrictions of TYPE."
+
+ (let* ((base-type (soap-xs-simple-type-base type))
+ (messages nil))
+ (if (listp base-type)
+ (catch 'valid
+ (dolist (base base-type)
+ (condition-case error-object
+ (cond ((soap-xs-simple-type-p base)
+ (throw 'valid
+ (soap-validate-xs-simple-type value base)))
+ ((soap-xs-basic-type-p base)
+ (throw 'valid
+ (soap-validate-xs-basic-type value base))))
+ (error (push (cadr error-object) messages))))
+ (when messages
+ (error (mapconcat 'identity (nreverse messages) "; and: "))))
+ (cl-flet ((fail-with-message (format value)
+ (push (format format value) messages)
+ (throw 'invalid nil)))
+ (catch 'invalid
+ (let ((enumeration (soap-xs-simple-type-enumeration type)))
+ (when (and (> (length enumeration) 1)
+ (not (member value enumeration)))
+ (fail-with-message "bad value, should be one of %s"
enumeration)))
+
+ (let ((pattern (soap-xs-simple-type-pattern type)))
+ (when (and pattern (not (string-match-p pattern value)))
+ (fail-with-message "bad value, should match pattern %s"
pattern)))
+
+ (let ((length-range (soap-xs-simple-type-length-range type)))
+ (when length-range
+ (unless (stringp value)
+ (fail-with-message
+ "bad value, should be a string with length range %s"
+ length-range))
+ (when (car length-range)
+ (unless (>= (length value) (car length-range))
+ (fail-with-message "short string, should be at least %s
chars"
+ (car length-range))))
+ (when (cdr length-range)
+ (unless (<= (length value) (cdr length-range))
+ (fail-with-message "long string, should be at most %s chars"
+ (cdr length-range))))))
+
+ (let ((integer-range (soap-xs-simple-type-integer-range type)))
+ (when integer-range
+ (unless (numberp value)
+ (fail-with-message "bad value, should be a number with range
%s"
+ integer-range))
+ (when (car integer-range)
+ (unless (>= value (car integer-range))
+ (fail-with-message "small value, should be at least %s"
+ (car integer-range))))
+ (when (cdr integer-range)
+ (unless (<= value (cdr integer-range))
+ (fail-with-message "big value, should be at most %s"
+ (cdr integer-range))))))))
+ (when messages
+ (error "Xs-simple-type(%s, %s): %s"
+ value (or (soap-xs-type-name type) (soap-xs-type-id type))
+ (car messages)))))
+ ;; Return the validated value.
+ value)
+
+(defun soap-resolve-references-for-xs-simple-type (type wsdl)
+ "Replace names in TYPE with the referenced objects in the WSDL.
+This is a specialization of `soap-resolve-references' for
+`soap-xs-simple-type' objects.
+
+See also `soap-wsdl-resolve-references'."
+
+ (let ((namespace (soap-element-namespace-tag type)))
+ (when namespace
+ (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl)))))
+ (when nstag
+ (setf (soap-element-namespace-tag type) nstag)))))
+
+ (let ((base (soap-xs-simple-type-base type)))
+ (cond
+ ((soap-name-p base)
+ (setf (soap-xs-simple-type-base type)
+ (soap-wsdl-get base wsdl 'soap-xs-type-p)))
+ ((soap-xs-type-p base)
+ (soap-resolve-references base wsdl))
+ ((listp base)
+ (setf (soap-xs-simple-type-base type)
+ (mapcar (lambda (type)
+ (cond ((soap-name-p type)
+ (soap-wsdl-get type wsdl 'soap-xs-type-p))
+ ((soap-xs-type-p type)
+ (soap-resolve-references type wsdl)
+ type)
+ (t ; signal an error?
+ type)))
+ base)))
+ (t (error "Oops"))))
+ (dolist (attribute (soap-xs-type-attributes type))
+ (soap-resolve-references attribute wsdl))
+ (dolist (attribute-group (soap-xs-type-attribute-groups type))
+ (soap-resolve-references attribute-group wsdl)))
+
+(defun soap-encode-xs-simple-type-attributes (value type)
+ "Encode the XML attributes for VALUE according to TYPE.
+The xsi:type and an optional xsi:nil attributes are added. The
+attributes are inserted in the current buffer at the current
+position.
+
+This is a specialization of `soap-encode-attributes' for
+`soap-xs-simple-type' objects."
+ (insert " xsi:type=\"" (soap-element-fq-name type) "\"")
+ (unless value (insert " xsi:nil=\"true\"")))
+
+(defun soap-encode-xs-simple-type (value type)
+ "Encode the VALUE according to TYPE.
+The data is inserted in the current buffer at the current
+position.
+
+This is a specialization of `soap-encode-value' for
+`soap-xs-simple-type' objects."
+ (soap-validate-xs-simple-type value type)
+ (if (soap-xs-simple-type-is-list type)
+ (progn
+ (dolist (v (butlast value))
+ (soap-encode-value v (soap-xs-simple-type-base type))
+ (insert " "))
+ (soap-encode-value (car (last value)) (soap-xs-simple-type-base type)))
+ (soap-encode-value value (soap-xs-simple-type-base type))))
+
+(defun soap-decode-xs-simple-type (type node)
+ "Use TYPE, a `soap-xs-simple-type', to decode the contents of NODE.
+A LISP value is returned based on the contents of NODE and the
+type-info stored in TYPE.
+
+This is a specialization of `soap-decode-type' for
+`soap-xs-simple-type' objects."
+ (if (soap-xs-simple-type-is-list type)
+ ;; Technically, we could construct fake XML NODEs and pass them to
+ ;; soap-decode-value...
+ (split-string (car (xml-node-children node)))
+ (let ((value (soap-decode-type (soap-xs-simple-type-base type) node)))
+ (soap-validate-xs-simple-type value type))))
+
+;; Register methods for `soap-xs-simple-type'
+(let ((tag (aref (make-soap-xs-simple-type) 0)))
+ (put tag 'soap-resolve-references
+ #'soap-resolve-references-for-xs-simple-type)
+ (put tag 'soap-attribute-encoder #'soap-encode-xs-simple-type-attributes)
+ (put tag 'soap-encoder #'soap-encode-xs-simple-type)
+ (put tag 'soap-decoder #'soap-decode-xs-simple-type))
+
+;;;;; soap-xs-complex-type
+
+(defstruct (soap-xs-complex-type (:include soap-xs-type))
+ indicator ; sequence, choice, all, array
+ base
+ elements
+ optional?
+ multiple?
+ is-group)
+
+(defun soap-xs-parse-complex-type (node)
+ "Construct a `soap-xs-complex-type' by parsing the XML NODE."
+ (let ((name (xml-get-attribute-or-nil node 'name))
+ (id (xml-get-attribute-or-nil node 'id))
+ (node-name (soap-l2wk (xml-node-name node)))
+ type
+ attributes
+ attribute-groups)
+ (assert (memq node-name '(xsd:complexType xsd:complexContent xsd:group))
+ nil "unexpected node: %s" node-name)
+
+ (dolist (def (xml-node-children node))
+ (when (consp def) ; skip text nodes
+ (case (soap-l2wk (xml-node-name def))
+ (xsd:attribute (push (soap-xs-parse-attribute def) attributes))
+ (xsd:attributeGroup
+ (push (soap-xs-parse-attribute-group def)
+ attribute-groups))
+ (xsd:simpleContent (setq type (soap-xs-parse-simple-type def)))
+ ((xsd:sequence xsd:all xsd:choice)
+ (setq type (soap-xs-parse-sequence def)))
+ (xsd:complexContent
+ (dolist (def (xml-node-children def))
+ (when (consp def)
+ (case (soap-l2wk (xml-node-name def))
+ (xsd:attribute
+ (push (soap-xs-parse-attribute def) attributes))
+ (xsd:attributeGroup
+ (push (soap-xs-parse-attribute-group def)
+ attribute-groups))
+ ((xsd:extension xsd:restriction)
+ (setq type
+ (soap-xs-parse-extension-or-restriction def)))
+ ((xsd:sequence xsd:all xsd:choice)
+ (soap-xs-parse-sequence def)))))))))
+ (unless type
+ ;; the type has not been built, this is a shortcut for a simpleContent
+ ;; node
+ (setq type (make-soap-xs-complex-type)))
+
+ (setf (soap-xs-type-name type) name)
+ (setf (soap-xs-type-namespace-tag type) soap-target-xmlns)
+ (setf (soap-xs-type-id type) id)
+ (setf (soap-xs-type-attributes type)
+ (append attributes (soap-xs-type-attributes type)))
+ (setf (soap-xs-type-attribute-groups type)
+ (append attribute-groups (soap-xs-type-attribute-groups type)))
+ (when (soap-xs-complex-type-p type)
+ (setf (soap-xs-complex-type-is-group type)
+ (eq node-name 'xsd:group)))
+ type))
+
+(defun soap-xs-parse-sequence (node)
+ "Parse a sequence definition from XML NODE.
+Returns a `soap-xs-complex-type'"
+ (assert (memq (soap-l2wk (xml-node-name node))
+ '(xsd:sequence xsd:choice xsd:all))
+ nil
+ "unexpected node: %s" (soap-l2wk (xml-node-name node)))
+
+ (let ((type (make-soap-xs-complex-type)))
+
+ (setf (soap-xs-complex-type-indicator type)
+ (ecase (soap-l2wk (xml-node-name node))
+ (xsd:sequence 'sequence)
+ (xsd:all 'all)
+ (xsd:choice 'choice)))
+
+ (setf (soap-xs-complex-type-optional? type) (soap-node-optional node))
+ (setf (soap-xs-complex-type-multiple? type) (soap-node-multiple node))
+
+ (dolist (r (xml-node-children node))
+ (unless (stringp r) ; skip the white space
+ (case (soap-l2wk (xml-node-name r))
+ ((xsd:element xsd:group)
+ (push (soap-xs-parse-element r)
+ (soap-xs-complex-type-elements type)))
+ ((xsd:sequence xsd:choice xsd:all)
+ ;; an inline sequence, choice or all node
+ (let ((choice (soap-xs-parse-sequence r)))
+ (push (make-soap-xs-element :name nil :type^ choice)
+ (soap-xs-complex-type-elements type))))
+ (xsd:attribute
+ (push (soap-xs-parse-attribute r)
+ (soap-xs-type-attributes type)))
+ (xsd:attributeGroup
+ (push (soap-xs-parse-attribute-group r)
+ (soap-xs-type-attribute-groups type))))))
+
+ (setf (soap-xs-complex-type-elements type)
+ (nreverse (soap-xs-complex-type-elements type)))
+
+ type))
+
+(defun soap-xs-parse-extension-or-restriction (node)
+ "Parse an extension or restriction definition from XML NODE.
+Return a `soap-xs-complex-type'."
+ (assert (memq (soap-l2wk (xml-node-name node))
+ '(xsd:extension xsd:restriction))
+ nil
+ "unexpected node: %s" (soap-l2wk (xml-node-name node)))
+ (let (type
+ attributes
+ attribute-groups
+ array?
+ (base (xml-get-attribute-or-nil node 'base)))
+
+ ;; Array declarations are recognized specially, it is unclear to me how
+ ;; they could be treated generally...
+ (setq array?
+ (and (eq (soap-l2wk (xml-node-name node)) 'xsd:restriction)
+ (equal base (soap-wk2l "soapenc:Array"))))
+
+ (dolist (def (xml-node-children node))
+ (when (consp def) ; skip text nodes
+ (case (soap-l2wk (xml-node-name def))
+ ((xsd:sequence xsd:choice xsd:all)
+ (setq type (soap-xs-parse-sequence def)))
+ (xsd:attribute
+ (if array?
+ (let ((array-type
+ (soap-xml-get-attribute-or-nil1 def 'wsdl:arrayType)))
+ (when (and array-type
+ (string-match "^\\(.*\\)\\[\\]$" array-type))
+ ;; Override
+ (setq base (match-string 1 array-type))))
+ ;; else
+ (push (soap-xs-parse-attribute def) attributes)))
+ (xsd:attributeGroup
+ (push (soap-xs-parse-attribute-group def) attribute-groups)))))
+
+ (unless type
+ (setq type (make-soap-xs-complex-type))
+ (when array?
+ (setf (soap-xs-complex-type-indicator type) 'array)))
+
+ (setf (soap-xs-complex-type-base type) (soap-l2fq base))
+ (setf (soap-xs-complex-type-attributes type) attributes)
+ (setf (soap-xs-complex-type-attribute-groups type) attribute-groups)
+ type))
+
+(defun soap-resolve-references-for-xs-complex-type (type wsdl)
+ "Replace names in TYPE with the referenced objects in the WSDL.
+This is a specialization of `soap-resolve-references' for
+`soap-xs-complex-type' objects.
+
+See also `soap-wsdl-resolve-references'."
+
+ (let ((namespace (soap-element-namespace-tag type)))
+ (when namespace
+ (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl)))))
+ (when nstag
+ (setf (soap-element-namespace-tag type) nstag)))))
+
+ (let ((base (soap-xs-complex-type-base type)))
+ (cond ((soap-name-p base)
+ (setf (soap-xs-complex-type-base type)
+ (soap-wsdl-get base wsdl 'soap-xs-type-p)))
+ ((soap-xs-type-p base)
+ (soap-resolve-references base wsdl))))
+ (let (all-elements)
+ (dolist (element (soap-xs-complex-type-elements type))
+ (if (soap-xs-element-is-group element)
+ ;; This is an xsd:group element that references an xsd:group node,
+ ;; which we treat as a complex type. We replace the reference
+ ;; element by inlining the elements of the referenced xsd:group
+ ;; (complex type) node.
+ (let ((type (soap-wsdl-get
+ (soap-xs-element-reference element)
+ wsdl (lambda (type)
+ (and
+ (soap-xs-complex-type-p type)
+ (soap-xs-complex-type-is-group type))))))
+ (dolist (element (soap-xs-complex-type-elements type))
+ (soap-resolve-references element wsdl)
+ (push element all-elements)))
+ ;; This is a non-xsd:group node so just add it directly.
+ (soap-resolve-references element wsdl)
+ (push element all-elements)))
+ (setf (soap-xs-complex-type-elements type) (nreverse all-elements)))
+ (dolist (attribute (soap-xs-type-attributes type))
+ (soap-resolve-references attribute wsdl))
+ (dolist (attribute-group (soap-xs-type-attribute-groups type))
+ (soap-resolve-references attribute-group wsdl)))
+
+(defun soap-encode-xs-complex-type-attributes (value type)
+ "Encode the XML attributes for encoding VALUE according to TYPE.
+The xsi:type and optional xsi:nil attributes are added, plus
+additional attributes needed for arrays types, if applicable. The
+attributes are inserted in the current buffer at the current
+position.
+
+This is a specialization of `soap-encode-attributes' for
+`soap-xs-complex-type' objects."
+ (if (eq (soap-xs-complex-type-indicator type) 'array)
+ (let ((element-type (soap-xs-complex-type-base type)))
+ (insert " xsi:type=\"soapenc:Array\"")
+ (insert " soapenc:arrayType=\""
+ (soap-element-fq-name element-type)
+ "[" (format "%s" (length value)) "]" "\""))
+ ;; else
+ (progn
+ (dolist (a (soap-get-xs-attributes type))
+ (let ((element-name (soap-element-name a)))
+ (if (soap-xs-attribute-default a)
+ (insert " " element-name
+ "=\"" (soap-xs-attribute-default a) "\"")
+ (dolist (value-pair value)
+ (when (equal element-name (symbol-name (car value-pair)))
+ (insert " " element-name
+ "=\"" (cdr value-pair) "\""))))))
+ ;; If this is not an empty type, and we have no value, mark it as nil
+ (when (and (soap-xs-complex-type-indicator type) (null value))
+ (insert " xsi:nil=\"true\"")))))
+
+(defun soap-get-candidate-elements (element)
+ "Return a list of elements that are compatible with ELEMENT.
+The returned list includes ELEMENT's references and
+alternatives."
+ (let ((reference (soap-xs-element-reference element)))
+ ;; If the element is a reference, append the reference and its
+ ;; alternatives...
+ (if reference
+ (append (list reference)
+ (soap-xs-element-alternatives reference))
+ ;; ...otherwise append the element itself and its alternatives.
+ (append (list element)
+ (soap-xs-element-alternatives element)))))
+
+(defun soap-encode-xs-complex-type (value type)
+ "Encode the VALUE according to TYPE.
+The data is inserted in the current buffer at the current
+position.
+
+This is a specialization of `soap-encode-value' for
+`soap-xs-complex-type' objects."
+ (case (soap-xs-complex-type-indicator type)
+ (array
+ (error "soap-encode-xs-complex-type arrays are handled elsewhere"))
+ ((sequence choice all nil)
+ (let ((type-list (list type)))
+
+ ;; Collect all base types
+ (let ((base (soap-xs-complex-type-base type)))
+ (while base
+ (push base type-list)
+ (setq base (soap-xs-complex-type-base base))))
+
+ (dolist (type type-list)
+ (dolist (element (soap-xs-complex-type-elements type))
+ (catch 'done
+ (let ((instance-count 0))
+ (dolist (candidate (soap-get-candidate-elements element))
+ (let ((e-name (soap-xs-element-name candidate)))
+ (if e-name
+ (let ((e-name (intern e-name)))
+ (dolist (v value)
+ (when (equal (car v) e-name)
+ (incf instance-count)
+ (soap-encode-value (cdr v) candidate))))
+ (if (soap-xs-complex-type-indicator type)
+ (let ((current-point (point)))
+ ;; Check if encoding happened by checking if
+ ;; characters were inserted in the buffer.
+ (soap-encode-value value candidate)
+ (when (not (equal current-point (point)))
+ (incf instance-count)))
+ (dolist (v value)
+ (let ((current-point (point)))
+ (soap-encode-value v candidate)
+ (when (not (equal current-point (point)))
+ (incf instance-count))))))))
+ ;; Do some sanity checking
+ (let* ((indicator (soap-xs-complex-type-indicator type))
+ (element-type (soap-xs-element-type element))
+ (reference (soap-xs-element-reference element))
+ (e-name (or (soap-xs-element-name element)
+ (and reference
+ (soap-xs-element-name reference)))))
+ (cond ((and (eq indicator 'choice)
+ (> instance-count 0))
+ ;; This was a choice node and we encoded
+ ;; one instance.
+ (throw 'done t))
+ ((and (not (eq indicator 'choice))
+ (= instance-count 0)
+ (not (soap-xs-element-optional? element))
+ (and (soap-xs-complex-type-p element-type)
+ (not (soap-xs-complex-type-optional-p
+ element-type))))
+ (soap-warning
+ "While encoding %s: missing non-nillable slot %s"
+ value e-name))
+ ((and (> instance-count 1)
+ (not (soap-xs-element-multiple? element))
+ (and (soap-xs-complex-type-p element-type)
+ (not (soap-xs-complex-type-multiple-p
+ element-type))))
+ (soap-warning
+ (concat "While encoding %s: expected single,"
+ " found multiple elements for slot %s")
+ value e-name))))))))))
+ (t
+ (error "Don't know how to encode complex type: %s"
+ (soap-xs-complex-type-indicator type)))))
+
+(defun soap-xml-get-children-fq (node child-name)
+ "Return the children of NODE named CHILD-NAME.
+This is the same as `xml-get-children1', but NODE's local
+namespace is used to resolve the children's namespace tags."
+ (let (result)
+ (dolist (c (xml-node-children node))
+ (when (and (consp c)
+ (soap-with-local-xmlns node
+ ;; We use `ignore-errors' here because we want to silently
+ ;; skip nodes for which we cannot convert them to a
+ ;; well-known name.
+ (equal (ignore-errors
+ (soap-l2fq (xml-node-name c)))
+ child-name)))
+ (push c result)))
+ (nreverse result)))
+
+(defun soap-xs-element-get-fq-name (element wsdl)
+ "Return ELEMENT's fully-qualified name using WSDL's alias table.
+Return nil if ELEMENT does not have a name."
+ (let* ((ns-aliases (soap-wsdl-alias-table wsdl))
+ (ns-name (cdr (assoc
+ (soap-element-namespace-tag element)
+ ns-aliases))))
+ (when ns-name
+ (cons ns-name (soap-element-name element)))))
+
+(defun soap-xs-complex-type-optional-p (type)
+ "Return t if TYPE or any of TYPE's ancestor types is optional.
+Return nil otherwise."
+ (when type
+ (or (soap-xs-complex-type-optional? type)
+ (and (soap-xs-complex-type-p type)
+ (soap-xs-complex-type-optional-p
+ (soap-xs-complex-type-base type))))))
+
+(defun soap-xs-complex-type-multiple-p (type)
+ "Return t if TYPE or any of TYPE's ancestor types permits multiple elements.
+Return nil otherwise."
+ (when type
+ (or (soap-xs-complex-type-multiple? type)
+ (and (soap-xs-complex-type-p type)
+ (soap-xs-complex-type-multiple-p
+ (soap-xs-complex-type-base type))))))
+
+(defun soap-get-xs-attributes-from-groups (attribute-groups)
+ "Return a list of attributes from all ATTRIBUTE-GROUPS."
+ (let (attributes)
+ (dolist (group attribute-groups)
+ (let ((sub-groups (soap-xs-attribute-group-attribute-groups group)))
+ (setq attributes (append attributes
+ (soap-get-xs-attributes-from-groups
sub-groups)
+ (soap-xs-attribute-group-attributes group)))))
+ attributes))
+
+(defun soap-get-xs-attributes (type)
+ "Return a list of all of TYPE's and TYPE's ancestors' attributes."
+ (let* ((base (and (soap-xs-complex-type-p type)
+ (soap-xs-complex-type-base type)))
+ (attributes (append (soap-xs-type-attributes type)
+ (soap-get-xs-attributes-from-groups
+ (soap-xs-type-attribute-groups type)))))
+ (if base
+ (append attributes (soap-get-xs-attributes base))
+ attributes)))
+
+(defun soap-decode-xs-attributes (type node)
+ "Use TYPE, a `soap-xs-complex-type', to decode the attributes of NODE."
+ (let (result)
+ (dolist (attribute (soap-get-xs-attributes type))
+ (let* ((name (soap-xs-attribute-name attribute))
+ (attribute-type (soap-xs-attribute-type attribute))
+ (symbol (intern name))
+ (value (xml-get-attribute-or-nil node symbol)))
+ ;; We don't support attribute uses: required, optional, prohibited.
+ (cond
+ ((soap-xs-basic-type-p attribute-type)
+ ;; Basic type values are validated by xml.el.
+ (when value
+ (push (cons symbol
+ ;; Create a fake XML node to satisfy the
+ ;; soap-decode-xs-basic-type API.
+ (soap-decode-xs-basic-type attribute-type
+ (list symbol nil value)))
+ result)))
+ ((soap-xs-simple-type-p attribute-type)
+ (when value
+ (push (cons symbol
+ (soap-validate-xs-simple-type value attribute-type))
+ result)))
+ (t
+ (error (concat "Attribute %s is of type %s which is"
+ " not a basic or simple type")
+ name (soap-name-p attribute))))))
+ result))
+
+(defun soap-decode-xs-complex-type (type node)
+ "Use TYPE, a `soap-xs-complex-type', to decode the contents of NODE.
+A LISP value is returned based on the contents of NODE and the
+type-info stored in TYPE.
+
+This is a specialization of `soap-decode-type' for
+`soap-xs-basic-type' objects."
+ (case (soap-xs-complex-type-indicator type)
+ (array
+ (let ((result nil)
+ (element-type (soap-xs-complex-type-base type)))
+ (dolist (node (xml-node-children node))
+ (when (consp node)
+ (push (soap-decode-type element-type node) result)))
+ (nreverse result)))
+ ((sequence choice all nil)
+ (let ((result nil)
+ (base (soap-xs-complex-type-base type)))
+ (when base
+ (setq result (nreverse (soap-decode-type base node))))
+ (catch 'done
+ (dolist (element (soap-xs-complex-type-elements type))
+ (let* ((instance-count 0)
+ (e-name (soap-xs-element-name element))
+ ;; Heuristic: guess if we need to decode using local
+ ;; namespaces.
+ (use-fq-names (string-match ":" (symbol-name (car node))))
+ (children (if e-name
+ (if use-fq-names
+ ;; Find relevant children
+ ;; using local namespaces by
+ ;; searching for the element's
+ ;; fully-qualified name.
+ (soap-xml-get-children-fq
+ node
+ (soap-xs-element-get-fq-name
+ element soap-current-wsdl))
+ ;; No local namespace resolution
+ ;; needed so use the element's
+ ;; name unqualified.
+ (xml-get-children node (intern e-name)))
+ ;; e-name is nil so a) we don't know which
+ ;; children to operate on, and b) we want to
+ ;; re-use soap-decode-xs-complex-type, which
+ ;; expects a node argument with a complex
+ ;; type; therefore we need to operate on the
+ ;; entire node. We wrap node in a list so
+ ;; that it will carry through as "node" in the
+ ;; loop below.
+ ;;
+ ;; For example:
+ ;;
+ ;; Element Type:
+ ;; <xs:complexType name="A">
+ ;; <xs:sequence>
+ ;; <xs:element name="B" type="t:BType"/>
+ ;; <xs:choice>
+ ;; <xs:element name="C" type="xs:string"/>
+ ;; <xs:element name="D" type="t:DType"/>
+ ;; </xs:choice>
+ ;; </xs:sequence>
+ ;; </xs:complexType>
+ ;;
+ ;; Node:
+ ;; <t:A>
+ ;; <t:B tag="b"/>
+ ;; <t:C>1</C>
+ ;; </t:A>
+ ;;
+ ;; soap-decode-type will be called below with:
+ ;;
+ ;; element =
+ ;; <xs:choice>
+ ;; <xs:element name="C" type="xs:string"/>
+ ;; <xs:element name="D" type="t:DType"/>
+ ;; </xs:choice>
+ ;; node =
+ ;; <t:A>
+ ;; <t:B tag="b"/>
+ ;; <t:C>1</C>
+ ;; </t:A>
+ (list node)))
+ (element-type (soap-xs-element-type element)))
+ (dolist (node children)
+ (incf instance-count)
+ (let* ((attributes
+ (soap-decode-xs-attributes element-type node))
+ ;; Attributes may specify xsi:type override.
+ (element-type
+ (if (soap-xml-get-attribute-or-nil1 node 'xsi:type)
+ (soap-wsdl-get
+ (soap-l2fq
+ (soap-xml-get-attribute-or-nil1 node
+ 'xsi:type))
+ soap-current-wsdl 'soap-xs-type-p t)
+ element-type))
+ (decoded-child (soap-decode-type element-type node)))
+ (if e-name
+ (push (cons (intern e-name)
+ (append attributes decoded-child)) result)
+ ;; When e-name is nil we don't want to introduce an extra
+ ;; level of nesting, so we splice the decoding into
+ ;; result.
+ (setq result (append decoded-child result)))))
+ (cond ((and (eq (soap-xs-complex-type-indicator type) 'choice)
+ ;; Choices can allow multiple values.
+ (not (soap-xs-complex-type-multiple-p type))
+ (> instance-count 0))
+ ;; This was a choice node, and we decoded one value.
+ (throw 'done t))
+
+ ;; Do some sanity checking
+ ((and (not (eq (soap-xs-complex-type-indicator type)
+ 'choice))
+ (= instance-count 0)
+ (not (soap-xs-element-optional? element))
+ (and (soap-xs-complex-type-p element-type)
+ (not (soap-xs-complex-type-optional-p
+ element-type))))
+ (soap-warning "missing non-nillable slot %s" e-name))
+ ((and (> instance-count 1)
+ (not (soap-xs-complex-type-multiple-p type))
+ (not (soap-xs-element-multiple? element))
+ (and (soap-xs-complex-type-p element-type)
+ (not (soap-xs-complex-type-multiple-p
+ element-type))))
+ (soap-warning "expected single %s slot, found multiple"
+ e-name))))))
+ (nreverse result)))
+ (t
+ (error "Don't know how to decode complex type: %s"
+ (soap-xs-complex-type-indicator type)))))
+
+;; Register methods for `soap-xs-complex-type'
+(let ((tag (aref (make-soap-xs-complex-type) 0)))
+ (put tag 'soap-resolve-references
+ #'soap-resolve-references-for-xs-complex-type)
+ (put tag 'soap-attribute-encoder #'soap-encode-xs-complex-type-attributes)
+ (put tag 'soap-encoder #'soap-encode-xs-complex-type)
+ (put tag 'soap-decoder #'soap-decode-xs-complex-type))
+
+;;;; WSDL documents
+;;;;; WSDL document elements
+
+
(defstruct (soap-message (:include soap-element))
parts ; ALIST of NAME => WSDL-TYPE name
)
@@ -393,7 +1945,9 @@ binding) but the same name."
parameter-order
input ; (NAME . MESSAGE)
output ; (NAME . MESSAGE)
- faults) ; a list of (NAME . MESSAGE)
+ faults ; a list of (NAME . MESSAGE)
+ input-action ; WS-addressing action string
+ output-action) ; WS-addressing action string
(defstruct (soap-port-type (:include soap-element))
operations) ; a namespace of operations
@@ -404,8 +1958,10 @@ binding) but the same name."
(defstruct soap-bound-operation
operation ; SOAP-OPERATION
soap-action ; value for SOAPAction HTTP header
+ soap-headers ; list of (message part use)
+ soap-body ; message parts present in the body
use ; 'literal or 'encoded, see
- ; http://www.w3.org/TR/wsdl#_soap:body
+ ; http://www.w3.org/TR/wsdl#_soap:body
)
(defstruct (soap-binding (:include soap-element))
@@ -416,49 +1972,49 @@ binding) but the same name."
service-url
binding)
-(defun soap-default-xsd-types ()
- "Return a namespace containing some of the XMLSchema types."
- (let ((ns (make-soap-namespace :name "http://www.w3.org/2001/XMLSchema";)))
- (dolist (type '("string" "dateTime" "boolean"
- "long" "int" "integer" "unsignedInt" "byte" "float"
"double"
- "base64Binary" "anyType" "anyURI" "Array" "byte[]"))
- (soap-namespace-put
- (make-soap-basic-type :name type :kind (intern type))
- ns))
- ns))
-
-(defun soap-default-soapenc-types ()
- "Return a namespace containing some of the SOAPEnc types."
- (let ((ns (make-soap-namespace
- :name "http://schemas.xmlsoap.org/soap/encoding/";)))
- (dolist (type '("string" "dateTime" "boolean"
- "long" "int" "integer" "unsignedInt" "byte" "float"
"double"
- "base64Binary" "anyType" "anyURI" "Array" "byte[]"))
- (soap-namespace-put
- (make-soap-basic-type :name type :kind (intern type))
- ns))
- ns))
-
-(defun soap-type-p (element)
- "Return t if ELEMENT is a SOAP data type (basic or complex)."
- (or (soap-basic-type-p element)
- (soap-sequence-type-p element)
- (soap-array-type-p element)))
-
;;;;; The WSDL document
;; The WSDL data structure used for encoding/decoding SOAP messages
-(defstruct soap-wsdl
+(defstruct (soap-wsdl
+ ;; NOTE: don't call this constructor, see `soap-make-wsdl'
+ (:constructor soap-make-wsdl^)
+ (:copier soap-copy-wsdl))
origin ; file or URL from which this wsdl was loaded
+ current-file ; most-recently fetched file or URL
+ xmlschema-imports ; a list of schema imports
ports ; a list of SOAP-PORT instances
alias-table ; a list of namespace aliases
namespaces ; a list of namespaces
)
+(defun soap-make-wsdl (origin)
+ "Create a new WSDL document, loaded from ORIGIN, and intialize it."
+ (let ((wsdl (soap-make-wsdl^ :origin origin)))
+
+ ;; Add the XSD types to the wsdl document
+ (let ((ns (soap-make-xs-basic-types
+ "http://www.w3.org/2001/XMLSchema"; "xsd")))
+ (soap-wsdl-add-namespace ns wsdl)
+ (soap-wsdl-add-alias "xsd" (soap-namespace-name ns) wsdl))
+
+ ;; Add the soapenc types to the wsdl document
+ (let ((ns (soap-make-xs-basic-types
+ "http://schemas.xmlsoap.org/soap/encoding/"; "soapenc")))
+ (soap-wsdl-add-namespace ns wsdl)
+ (soap-wsdl-add-alias "soapenc" (soap-namespace-name ns) wsdl))
+
+ wsdl))
+
(defun soap-wsdl-add-alias (alias name wsdl)
"Add a namespace ALIAS for NAME to the WSDL document."
- (push (cons alias name) (soap-wsdl-alias-table wsdl)))
+ (let ((existing (assoc alias (soap-wsdl-alias-table wsdl))))
+ (if existing
+ (unless (equal (cdr existing) name)
+ (warn "Redefining alias %s from %s to %s"
+ alias (cdr existing) name)
+ (push (cons alias name) (soap-wsdl-alias-table wsdl)))
+ (push (cons alias name) (soap-wsdl-alias-table wsdl)))))
(defun soap-wsdl-find-namespace (name wsdl)
"Find a namespace by NAME in the WSDL document."
@@ -474,11 +2030,11 @@ elements will be added to it."
(let ((existing (soap-wsdl-find-namespace (soap-namespace-name ns) wsdl)))
(if existing
;; Add elements from NS to EXISTING, replacing existing values.
- (maphash (lambda (key value)
+ (maphash (lambda (_key value)
(dolist (v value)
(soap-namespace-put v existing)))
(soap-namespace-elements ns))
- (push ns (soap-wsdl-namespaces wsdl)))))
+ (push ns (soap-wsdl-namespaces wsdl)))))
(defun soap-wsdl-get (name wsdl &optional predicate use-local-alias-table)
"Retrieve element NAME from the WSDL document.
@@ -517,13 +2073,13 @@ used to resolve the namespace alias."
(ns-name (cdr (assoc ns-alias alias-table))))
(unless ns-name
(error "Soap-wsdl-get(%s): cannot find namespace alias %s"
- name ns-alias))
+ name ns-alias))
(setq namespace (soap-wsdl-find-namespace ns-name wsdl))
(unless namespace
(error
- "Soap-wsdl-get(%s): unknown namespace %s, referenced by alias
%s"
- name ns-name ns-alias))))
+ "Soap-wsdl-get(%s): unknown namespace %s, referenced as %s"
+ name ns-name ns-alias))))
(t
(error "Soap-wsdl-get(%s): bad name" name)))
@@ -533,7 +2089,7 @@ used to resolve the namespace alias."
(lambda (e)
(or (funcall 'soap-namespace-link-p e)
(funcall predicate e)))
- nil)))
+ nil)))
(unless element
(error "Soap-wsdl-get(%s): cannot find element" name))
@@ -541,92 +2097,96 @@ used to resolve the namespace alias."
(if (soap-namespace-link-p element)
;; NOTE: don't use the local alias table here
(soap-wsdl-get (soap-namespace-link-target element) wsdl predicate)
- element)))
+ element)))
+
+;;;;; soap-parse-schema
+
+(defun soap-parse-schema (node wsdl)
+ "Parse a schema NODE, placing the results in WSDL.
+Return a SOAP-NAMESPACE containing the elements."
+ (soap-with-local-xmlns node
+ (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:schema)
+ nil
+ "expecting an xsd:schema node, got %s"
+ (soap-l2wk (xml-node-name node)))
+
+ (let ((ns (make-soap-namespace :name (soap-get-target-namespace node))))
+
+ (dolist (def (xml-node-children node))
+ (unless (stringp def) ; skip text nodes
+ (case (soap-l2wk (xml-node-name def))
+ (xsd:import
+ ;; Imports will be processed later
+ ;; NOTE: we should expand the location now!
+ (let ((location (or
+ (xml-get-attribute-or-nil def 'schemaLocation)
+ (xml-get-attribute-or-nil def 'location))))
+ (when location
+ (push location (soap-wsdl-xmlschema-imports wsdl)))))
+ (xsd:element
+ (soap-namespace-put (soap-xs-parse-element def) ns))
+ (xsd:attribute
+ (soap-namespace-put (soap-xs-parse-attribute def) ns))
+ (xsd:attributeGroup
+ (soap-namespace-put (soap-xs-parse-attribute-group def) ns))
+ (xsd:simpleType
+ (soap-namespace-put (soap-xs-parse-simple-type def) ns))
+ ((xsd:complexType xsd:group)
+ (soap-namespace-put (soap-xs-parse-complex-type def) ns)))))
+ ns)))
;;;;; Resolving references for wsdl types
;; See `soap-wsdl-resolve-references', which is the main entry point for
;; resolving references
-(defun soap-resolve-references-for-element (element wsdl)
- "Resolve references in ELEMENT using the WSDL document.
-This is a generic function which invokes a specific function
-depending on the element type.
+(defun soap-resolve-references (element wsdl)
+ "Replace names in ELEMENT with the referenced objects in the WSDL.
+This is a generic function which invokes a specific resolver
+function depending on the type of the ELEMENT.
-If ELEMENT has no resolver function, it is silently ignored.
-
-All references are resolved in-place, that is the ELEMENT is
-updated."
+If ELEMENT has no resolver function, it is silently ignored."
(let ((resolver (get (aref element 0) 'soap-resolve-references)))
(when resolver
(funcall resolver element wsdl))))
-(defun soap-resolve-references-for-simple-type (type wsdl)
- "Resolve the base type for the simple TYPE using the WSDL
- document."
- (let ((kind (soap-basic-type-kind type)))
- (unless (symbolp kind)
- (let ((basic-type (soap-wsdl-get kind wsdl 'soap-basic-type-p)))
- (setf (soap-basic-type-kind type)
- (soap-basic-type-kind basic-type))))))
-
-(defun soap-resolve-references-for-sequence-type (type wsdl)
- "Resolve references for a sequence TYPE using WSDL document.
-See also `soap-resolve-references-for-element' and
-`soap-wsdl-resolve-references'"
- (let ((parent (soap-sequence-type-parent type)))
- (when (or (consp parent) (stringp parent))
- (setf (soap-sequence-type-parent type)
- (soap-wsdl-get
- parent wsdl
- ;; Prevent self references, see Bug#9
- (lambda (e) (and (not (eq e type)) (soap-type-p e)))))))
- (dolist (element (soap-sequence-type-elements type))
- (let ((element-type (soap-sequence-element-type element)))
- (cond ((or (consp element-type) (stringp element-type))
- (setf (soap-sequence-element-type element)
- (soap-wsdl-get
- element-type wsdl
- ;; Prevent self references, see Bug#9
- (lambda (e) (and (not (eq e type)) (soap-type-p e))))))
- ((soap-element-p element-type)
- ;; since the element already has a child element, it
- ;; could be an inline structure. we must resolve
- ;; references in it, because it might not be reached by
- ;; scanning the wsdl names.
- (soap-resolve-references-for-element element-type wsdl))))))
-
-(defun soap-resolve-references-for-array-type (type wsdl)
- "Resolve references for an array TYPE using WSDL.
-See also `soap-resolve-references-for-element' and
-`soap-wsdl-resolve-references'"
- (let ((element-type (soap-array-type-element-type type)))
- (when (or (consp element-type) (stringp element-type))
- (setf (soap-array-type-element-type type)
- (soap-wsdl-get
- element-type wsdl
- ;; Prevent self references, see Bug#9
- (lambda (e) (and (not (eq e type)) (soap-type-p e))))))))
-
(defun soap-resolve-references-for-message (message wsdl)
- "Resolve references for a MESSAGE type using the WSDL document.
-See also `soap-resolve-references-for-element' and
-`soap-wsdl-resolve-references'"
+ "Replace names in MESSAGE with the referenced objects in the WSDL.
+This is a generic function, called by `soap-resolve-references',
+you should use that function instead.
+
+See also `soap-wsdl-resolve-references'."
(let (resolved-parts)
(dolist (part (soap-message-parts message))
(let ((name (car part))
- (type (cdr part)))
+ (element (cdr part)))
(when (stringp name)
(setq name (intern name)))
- (when (or (consp type) (stringp type))
- (setq type (soap-wsdl-get type wsdl 'soap-type-p)))
- (push (cons name type) resolved-parts)))
- (setf (soap-message-parts message) (nreverse resolved-parts))))
+ (if (soap-name-p element)
+ (setq element (soap-wsdl-get
+ element wsdl
+ (lambda (x)
+ (or (soap-xs-type-p x) (soap-xs-element-p x)))))
+ ;; else, inline element, resolve recursively, as the element
+ ;; won't be reached.
+ (soap-resolve-references element wsdl)
+ (unless (soap-element-namespace-tag element)
+ (setf (soap-element-namespace-tag element)
+ (soap-element-namespace-tag message))))
+ (push (cons name element) resolved-parts)))
+ (setf (soap-message-parts message) (nreverse resolved-parts))))
(defun soap-resolve-references-for-operation (operation wsdl)
"Resolve references for an OPERATION type using the WSDL document.
-See also `soap-resolve-references-for-element' and
+See also `soap-resolve-references' and
`soap-wsdl-resolve-references'"
+
+ (let ((namespace (soap-element-namespace-tag operation)))
+ (when namespace
+ (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl)))))
+ (when nstag
+ (setf (soap-element-namespace-tag operation) nstag)))))
+
(let ((input (soap-operation-input operation))
(counter 0))
(let ((name (car input))
@@ -634,10 +2194,10 @@ See also `soap-resolve-references-for-element' and
;; Name this part if it was not named
(when (or (null name) (equal name ""))
(setq name (format "in%d" (incf counter))))
- (when (or (consp message) (stringp message))
+ (when (soap-name-p message)
(setf (soap-operation-input operation)
(cons (intern name)
- (soap-wsdl-get message wsdl 'soap-message-p))))))
+ (soap-wsdl-get message wsdl 'soap-message-p))))))
(let ((output (soap-operation-output operation))
(counter 0))
@@ -645,10 +2205,10 @@ See also `soap-resolve-references-for-element' and
(message (cdr output)))
(when (or (null name) (equal name ""))
(setq name (format "out%d" (incf counter))))
- (when (or (consp message) (stringp message))
+ (when (soap-name-p message)
(setf (soap-operation-output operation)
(cons (intern name)
- (soap-wsdl-get message wsdl 'soap-message-p))))))
+ (soap-wsdl-get message wsdl 'soap-message-p))))))
(let ((resolved-faults nil)
(counter 0))
@@ -657,11 +2217,11 @@ See also `soap-resolve-references-for-element' and
(message (cdr fault)))
(when (or (null name) (equal name ""))
(setq name (format "fault%d" (incf counter))))
- (if (or (consp message) (stringp message))
+ (if (soap-name-p message)
(push (cons (intern name)
- (soap-wsdl-get message wsdl 'soap-message-p))
+ (soap-wsdl-get message wsdl 'soap-message-p))
resolved-faults)
- (push fault resolved-faults))))
+ (push fault resolved-faults))))
(setf (soap-operation-faults operation) resolved-faults))
(when (= (length (soap-operation-parameter-order operation)) 0)
@@ -673,42 +2233,44 @@ See also `soap-resolve-references-for-element' and
(mapcar (lambda (p)
(if (stringp p)
(intern p)
- p))
+ p))
(soap-operation-parameter-order operation))))
(defun soap-resolve-references-for-binding (binding wsdl)
- "Resolve references for a BINDING type using the WSDL document.
-See also `soap-resolve-references-for-element' and
+ "Resolve references for a BINDING type using the WSDL document.
+See also `soap-resolve-references' and
`soap-wsdl-resolve-references'"
- (when (or (consp (soap-binding-port-type binding))
- (stringp (soap-binding-port-type binding)))
+ (when (soap-name-p (soap-binding-port-type binding))
(setf (soap-binding-port-type binding)
(soap-wsdl-get (soap-binding-port-type binding)
- wsdl 'soap-port-type-p)))
+ wsdl 'soap-port-type-p)))
(let ((port-ops (soap-port-type-operations (soap-binding-port-type
binding))))
(maphash (lambda (k v)
(setf (soap-bound-operation-operation v)
- (soap-namespace-get k port-ops 'soap-operation-p)))
+ (soap-namespace-get k port-ops 'soap-operation-p))
+ (let (resolved-headers)
+ (dolist (h (soap-bound-operation-soap-headers v))
+ (push (list (soap-wsdl-get (nth 0 h) wsdl)
+ (intern (nth 1 h))
+ (nth 2 h))
+ resolved-headers))
+ (setf (soap-bound-operation-soap-headers v)
+ (nreverse resolved-headers))))
(soap-binding-operations binding))))
(defun soap-resolve-references-for-port (port wsdl)
- "Resolve references for a PORT type using the WSDL document.
-See also `soap-resolve-references-for-element' and
-`soap-wsdl-resolve-references'"
- (when (or (consp (soap-port-binding port))
- (stringp (soap-port-binding port)))
+ "Replace names in PORT with the referenced objects in the WSDL.
+This is a generic function, called by `soap-resolve-references',
+you should use that function instead.
+
+See also `soap-wsdl-resolve-references'."
+ (when (soap-name-p (soap-port-binding port))
(setf (soap-port-binding port)
(soap-wsdl-get (soap-port-binding port) wsdl 'soap-binding-p))))
;; Install resolvers for our types
(progn
- (put (aref (make-soap-simple-type) 0) 'soap-resolve-references
- 'soap-resolve-references-for-simple-type)
- (put (aref (make-soap-sequence-type) 0) 'soap-resolve-references
- 'soap-resolve-references-for-sequence-type)
- (put (aref (make-soap-array-type) 0) 'soap-resolve-references
- 'soap-resolve-references-for-array-type)
(put (aref (make-soap-message) 0) 'soap-resolve-references
'soap-resolve-references-for-message)
(put (aref (make-soap-operation) 0) 'soap-resolve-references
@@ -745,312 +2307,173 @@ traverse an element tree."
(soap-wsdl-add-alias nstag (soap-namespace-name ns) wsdl)
(throw 'done t)))))
- (maphash (lambda (name element)
+ (maphash (lambda (_name element)
(cond ((soap-element-p element) ; skip links
(incf nprocessed)
- (soap-resolve-references-for-element element wsdl)
- (setf (soap-element-namespace-tag element) nstag))
+ (soap-resolve-references element wsdl))
((listp element)
(dolist (e element)
(when (soap-element-p e)
(incf nprocessed)
- (soap-resolve-references-for-element e wsdl)
- (setf (soap-element-namespace-tag e) nstag))))))
+ (soap-resolve-references e wsdl))))))
(soap-namespace-elements ns)))))
- wsdl)
+ wsdl)
;;;;; Loading WSDL from XML documents
-(defun soap-load-wsdl-from-url (url)
- "Load a WSDL document from URL and return it.
-The returned WSDL document needs to be used for `soap-invoke'
-calls."
- (let ((url-request-method "GET")
+(defun soap-parse-server-response ()
+ "Error-check and parse the XML contents of the current buffer."
+ (let ((mime-part (mm-dissect-buffer t t)))
+ (unless mime-part
+ (error "Failed to decode response from server"))
+ (unless (equal (car (mm-handle-type mime-part)) "text/xml")
+ (error "Server response is not an XML document"))
+ (with-temp-buffer
+ (mm-insert-part mime-part)
+ (prog1
+ (car (xml-parse-region (point-min) (point-max)))
+ (kill-buffer)
+ (mm-destroy-part mime-part)))))
+
+(defun soap-fetch-xml-from-url (url wsdl)
+ "Load an XML document from URL and return it.
+The previously parsed URL is read from WSDL."
+ (message "Fetching from %s" url)
+ (let ((current-file (url-expand-file-name url (soap-wsdl-current-file wsdl)))
+ (url-request-method "GET")
(url-package-name "soap-client.el")
(url-package-version "1.0")
(url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5")
- (url-request-coding-system 'utf-8)
- (url-http-attempt-keepalives nil))
- (let ((buffer (url-retrieve-synchronously url)))
+ (url-http-attempt-keepalives t))
+ (setf (soap-wsdl-current-file wsdl) current-file)
+ (let ((buffer (url-retrieve-synchronously current-file)))
(with-current-buffer buffer
(declare (special url-http-response-status))
(if (> url-http-response-status 299)
(error "Error retrieving WSDL: %s" url-http-response-status))
- (let ((mime-part (mm-dissect-buffer t t)))
- (unless mime-part
- (error "Failed to decode response from server"))
- (unless (equal (car (mm-handle-type mime-part)) "text/xml")
- (error "Server response is not an XML document"))
- (with-temp-buffer
- (mm-insert-part mime-part)
- (let ((wsdl-xml (car (xml-parse-region (point-min) (point-max)))))
- (prog1
- (let ((wsdl (soap-parse-wsdl wsdl-xml)))
- (setf (soap-wsdl-origin wsdl) url)
- wsdl)
- (kill-buffer buffer)))))))))
-
-(defun soap-load-wsdl (file)
- "Load a WSDL document from FILE and return it."
- (with-temp-buffer
- (insert-file-contents file)
- (let ((xml (car (xml-parse-region (point-min) (point-max)))))
- (let ((wsdl (soap-parse-wsdl xml)))
- (setf (soap-wsdl-origin wsdl) file)
- wsdl))))
-
-(defun soap-parse-wsdl (node)
- "Construct a WSDL structure from NODE, which is an XML document."
+ (soap-parse-server-response)))))
+
+(defun soap-fetch-xml-from-file (file wsdl)
+ "Load an XML document from FILE and return it.
+The previously parsed file is read from WSDL."
+ (let* ((current-file (soap-wsdl-current-file wsdl))
+ (expanded-file (expand-file-name file
+ (if current-file
+ (file-name-directory
current-file)
+ default-directory))))
+ (setf (soap-wsdl-current-file wsdl) expanded-file)
+ (with-temp-buffer
+ (insert-file-contents expanded-file)
+ (car (xml-parse-region (point-min) (point-max))))))
+
+(defun soap-fetch-xml (file-or-url wsdl)
+ "Load an XML document from FILE-OR-URL and return it.
+The previously parsed file or URL is read from WSDL."
+ (let ((current-file (or (soap-wsdl-current-file wsdl) file-or-url)))
+ (if (or (and current-file (file-exists-p current-file))
+ (file-exists-p file-or-url))
+ (soap-fetch-xml-from-file file-or-url wsdl)
+ (soap-fetch-xml-from-url file-or-url wsdl))))
+
+(defun soap-load-wsdl (file-or-url &optional wsdl)
+ "Load a document from FILE-OR-URL and return it.
+Build on WSDL if it is provided."
+ (let* ((wsdl (or wsdl (soap-make-wsdl file-or-url)))
+ (xml (soap-fetch-xml file-or-url wsdl)))
+ (soap-wsdl-resolve-references (soap-parse-wsdl xml wsdl))
+ wsdl))
+
+(defalias 'soap-load-wsdl-from-url 'soap-load-wsdl)
+
+(defun soap-parse-wsdl-phase-validate-node (node)
+ "Assert that NODE is valid."
(soap-with-local-xmlns node
+ (let ((node-name (soap-l2wk (xml-node-name node))))
+ (assert (eq node-name 'wsdl:definitions)
+ nil
+ "expecting wsdl:definitions node, got %s" node-name))))
- (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:definitions)
- nil
- "soap-parse-wsdl: expecting wsdl:definitions node, got %s"
- (soap-l2wk (xml-node-name node)))
-
- (let ((wsdl (make-soap-wsdl)))
-
- ;; Add the local alias table to the wsdl document -- it will be used for
- ;; all types in this document even after we finish parsing it.
- (setf (soap-wsdl-alias-table wsdl) soap-local-xmlns)
-
- ;; Add the XSD types to the wsdl document
- (let ((ns (soap-default-xsd-types)))
- (soap-wsdl-add-namespace ns wsdl)
- (soap-wsdl-add-alias "xsd" (soap-namespace-name ns) wsdl))
-
- ;; Add the soapenc types to the wsdl document
- (let ((ns (soap-default-soapenc-types)))
- (soap-wsdl-add-namespace ns wsdl)
- (soap-wsdl-add-alias "soapenc" (soap-namespace-name ns) wsdl))
-
- ;; Find all the 'xsd:schema nodes which are children of wsdl:types nodes
- ;; and build our type-library
-
- (let ((types (car (soap-xml-get-children1 node 'wsdl:types))))
- (dolist (node (xml-node-children types))
- ;; We cannot use (xml-get-children node (soap-wk2l 'xsd:schema))
- ;; because each node can install its own alias type so the schema
- ;; nodes might have a different prefix.
- (when (consp node)
- (soap-with-local-xmlns node
- (when (eq (soap-l2wk (xml-node-name node)) 'xsd:schema)
- (soap-wsdl-add-namespace (soap-parse-schema node) wsdl))))))
-
- (let ((ns (make-soap-namespace :name (soap-get-target-namespace node))))
- (dolist (node (soap-xml-get-children1 node 'wsdl:message))
- (soap-namespace-put (soap-parse-message node) ns))
-
- (dolist (node (soap-xml-get-children1 node 'wsdl:portType))
- (let ((port-type (soap-parse-port-type node)))
- (soap-namespace-put port-type ns)
- (soap-wsdl-add-namespace
- (soap-port-type-operations port-type) wsdl)))
-
- (dolist (node (soap-xml-get-children1 node 'wsdl:binding))
- (soap-namespace-put (soap-parse-binding node) ns))
-
- (dolist (node (soap-xml-get-children1 node 'wsdl:service))
- (dolist (node (soap-xml-get-children1 node 'wsdl:port))
- (let ((name (xml-get-attribute node 'name))
- (binding (xml-get-attribute node 'binding))
- (url (let ((n (car (soap-xml-get-children1
- node 'wsdlsoap:address))))
- (xml-get-attribute n 'location))))
- (let ((port (make-soap-port
- :name name :binding (soap-l2fq binding 'tns)
- :service-url url)))
- (soap-namespace-put port ns)
- (push port (soap-wsdl-ports wsdl))))))
-
- (soap-wsdl-add-namespace ns wsdl))
-
- (soap-wsdl-resolve-references wsdl)
-
- wsdl)))
-
-(defun soap-parse-schema (node)
- "Parse a schema NODE.
-Return a SOAP-NAMESPACE containing the elements."
+(defun soap-parse-wsdl-phase-fetch-imports (node wsdl)
+ "Fetch and load files imported by NODE into WSDL."
(soap-with-local-xmlns node
- (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:schema)
- nil
- "soap-parse-schema: expecting an xsd:schema node, got %s"
- (soap-l2wk (xml-node-name node)))
- (let ((ns (make-soap-namespace :name (soap-get-target-namespace node))))
- ;; NOTE: we only extract the complexTypes from the schema, we wouldn't
- ;; know how to handle basic types beyond the built in ones anyway.
- (dolist (node (soap-xml-get-children1 node 'xsd:simpleType))
- (soap-namespace-put (soap-parse-simple-type node) ns))
-
- (dolist (node (soap-xml-get-children1 node 'xsd:complexType))
- (soap-namespace-put (soap-parse-complex-type node) ns))
+ (dolist (node (soap-xml-get-children1 node 'wsdl:import))
+ (let ((location (xml-get-attribute-or-nil node 'location)))
+ (when location
+ (soap-load-wsdl location wsdl))))))
- (dolist (node (soap-xml-get-children1 node 'xsd:element))
- (soap-namespace-put (soap-parse-schema-element node) ns))
-
- ns)))
-
-(defun soap-parse-simple-type (node)
- "Parse NODE and construct a simple type from it."
- (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:simpleType)
- nil
- "soap-parse-complex-type: expecting xsd:simpleType node, got %s"
- (soap-l2wk (xml-node-name node)))
- (let ((name (xml-get-attribute-or-nil node 'name))
- type
- enumeration
- (restriction (car-safe
- (soap-xml-get-children1 node 'xsd:restriction))))
- (unless restriction
- (error "simpleType %s has no base type" name))
-
- (setq type (xml-get-attribute-or-nil restriction 'base))
- (dolist (e (soap-xml-get-children1 restriction 'xsd:enumeration))
- (push (xml-get-attribute e 'value) enumeration))
-
- (make-soap-simple-type :name name :kind type :enumeration enumeration)))
-
-(defun soap-parse-schema-element (node)
- "Parse NODE and construct a schema element from it."
- (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:element)
- nil
- "soap-parse-schema-element: expecting xsd:element node, got %s"
- (soap-l2wk (xml-node-name node)))
- (let ((name (xml-get-attribute-or-nil node 'name))
- type)
- ;; A schema element that contains an inline complex type --
- ;; construct the actual complex type for it.
- (let ((type-node (soap-xml-get-children1 node 'xsd:complexType)))
- (when (> (length type-node) 0)
- (assert (= (length type-node) 1)) ; only one complex type
- ; definition per element
- (setq type (soap-parse-complex-type (car type-node)))))
- (setf (soap-element-name type) name)
- type))
-
-(defun soap-parse-complex-type (node)
- "Parse NODE and construct a complex type from it."
- (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:complexType)
- nil
- "soap-parse-complex-type: expecting xsd:complexType node, got %s"
- (soap-l2wk (xml-node-name node)))
- (let ((name (xml-get-attribute-or-nil node 'name))
- ;; Use a dummy type for the complex type, it will be replaced
- ;; with the real type below, except when the complex type node
- ;; is empty...
- (type (make-soap-sequence-type :elements nil)))
- (dolist (c (xml-node-children node))
- (when (consp c) ; skip string nodes, which are whitespace
- (let ((node-name (soap-l2wk (xml-node-name c))))
- (cond
- ;; The difference between xsd:all and xsd:sequence is that fields
- ;; in xsd:all are not ordered and they can occur only once. We
- ;; don't care about that difference in soap-client.el
- ((or (eq node-name 'xsd:sequence)
- (eq node-name 'xsd:all))
- (setq type (soap-parse-complex-type-sequence c)))
- ((eq node-name 'xsd:complexContent)
- (setq type (soap-parse-complex-type-complex-content c)))
- ((eq node-name 'xsd:attribute)
- ;; The name of this node comes from an attribute tag
- (let ((n (xml-get-attribute-or-nil c 'name)))
- (setq name n)))
- (t
- (error "Unknown node type %s" node-name))))))
- (setf (soap-element-name type) name)
- type))
-
-(defun soap-parse-sequence (node)
- "Parse NODE and a list of sequence elements that it defines.
-NODE is assumed to be an xsd:sequence node. In that case, each
-of its children is assumed to be a sequence element. Each
-sequence element is parsed constructing the corresponding type.
-A list of these types is returned."
- (assert (let ((n (soap-l2wk (xml-node-name node))))
- (memq n '(xsd:sequence xsd:all)))
- nil
- "soap-parse-sequence: expecting xsd:sequence or xsd:all node, got %s"
- (soap-l2wk (xml-node-name node)))
- (let (elements)
- (dolist (e (soap-xml-get-children1 node 'xsd:element))
- (let ((name (xml-get-attribute-or-nil e 'name))
- (type (xml-get-attribute-or-nil e 'type))
- (nillable? (or (equal (xml-get-attribute-or-nil e 'nillable)
"true")
- (let ((e (xml-get-attribute-or-nil e 'minOccurs)))
- (and e (equal e "0")))))
- (multiple? (let ((e (xml-get-attribute-or-nil e 'maxOccurs)))
- (and e (not (equal e "1"))))))
- (if type
- (setq type (soap-l2fq type 'tns))
-
- ;; The node does not have a type, maybe it has a complexType
- ;; defined inline...
- (let ((type-node (soap-xml-get-children1 e 'xsd:complexType)))
- (when (> (length type-node) 0)
- (assert (= (length type-node) 1)
- nil
- "only one complex type definition per element
supported")
- (setq type (soap-parse-complex-type (car type-node))))))
-
- (push (make-soap-sequence-element
- :name (intern name) :type type :nillable? nillable?
- :multiple? multiple?)
- elements)))
- (nreverse elements)))
-
-(defun soap-parse-complex-type-sequence (node)
- "Parse NODE as a sequence type."
- (let ((elements (soap-parse-sequence node)))
- (make-soap-sequence-type :elements elements)))
-
-(defun soap-parse-complex-type-complex-content (node)
- "Parse NODE as a xsd:complexContent node.
-A sequence or an array type is returned depending on the actual
-contents."
- (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:complexContent)
- nil
- "soap-parse-complex-type-complex-content: expecting
xsd:complexContent node, got %s"
- (soap-l2wk (xml-node-name node)))
- (let (array? parent elements)
- (let ((extension (car-safe (soap-xml-get-children1 node 'xsd:extension)))
- (restriction (car-safe
- (soap-xml-get-children1 node 'xsd:restriction))))
- ;; a complex content node is either an extension or a restriction
- (cond (extension
- (setq parent (xml-get-attribute-or-nil extension 'base))
- (setq elements (soap-parse-sequence
- (car (soap-xml-get-children1
- extension 'xsd:sequence)))))
- (restriction
- (let ((base (xml-get-attribute-or-nil restriction 'base)))
- (assert (equal base (soap-wk2l "soapenc:Array"))
- nil
- "restrictions supported only for soapenc:Array types,
this is a %s"
- base))
- (setq array? t)
- (let ((attribute (car (soap-xml-get-children1
- restriction 'xsd:attribute))))
- (let ((array-type (soap-xml-get-attribute-or-nil1
- attribute 'wsdl:arrayType)))
- (when (string-match "^\\(.*\\)\\[\\]$" array-type)
- (setq parent (match-string 1 array-type))))))
-
- (t
- (error "Unknown complex type"))))
-
- (if parent
- (setq parent (soap-l2fq parent 'tns)))
+(defun soap-parse-wsdl-phase-parse-schema (node wsdl)
+ "Load types found in NODE into WSDL."
+ (soap-with-local-xmlns node
+ ;; Find all the 'xsd:schema nodes which are children of wsdl:types nodes
and
+ ;; build our type-library.
+ (let ((types (car (soap-xml-get-children1 node 'wsdl:types))))
+ (dolist (node (xml-node-children types))
+ ;; We cannot use (xml-get-children node (soap-wk2l 'xsd:schema))
because
+ ;; each node can install its own alias type so the schema nodes might
+ ;; have a different prefix.
+ (when (consp node)
+ (soap-with-local-xmlns
+ node
+ (when (eq (soap-l2wk (xml-node-name node)) 'xsd:schema)
+ (soap-wsdl-add-namespace (soap-parse-schema node wsdl)
+ wsdl))))))))
+
+(defun soap-parse-wsdl-phase-fetch-schema (node wsdl)
+ "Fetch and load schema imports defined by NODE into WSDL."
+ (soap-with-local-xmlns node
+ (while (soap-wsdl-xmlschema-imports wsdl)
+ (let* ((import (pop (soap-wsdl-xmlschema-imports wsdl)))
+ (xml (soap-fetch-xml import wsdl)))
+ (soap-wsdl-add-namespace (soap-parse-schema xml wsdl) wsdl)))))
- (if array?
- (make-soap-array-type :element-type parent)
- (make-soap-sequence-type :parent parent :elements elements))))
+(defun soap-parse-wsdl-phase-finish-parsing (node wsdl)
+ "Finish parsing NODE into WSDL."
+ (soap-with-local-xmlns node
+ (let ((ns (make-soap-namespace :name (soap-get-target-namespace node))))
+ (dolist (node (soap-xml-get-children1 node 'wsdl:message))
+ (soap-namespace-put (soap-parse-message node) ns))
+
+ (dolist (node (soap-xml-get-children1 node 'wsdl:portType))
+ (let ((port-type (soap-parse-port-type node)))
+ (soap-namespace-put port-type ns)
+ (soap-wsdl-add-namespace
+ (soap-port-type-operations port-type) wsdl)))
+
+ (dolist (node (soap-xml-get-children1 node 'wsdl:binding))
+ (soap-namespace-put (soap-parse-binding node) ns))
+
+ (dolist (node (soap-xml-get-children1 node 'wsdl:service))
+ (dolist (node (soap-xml-get-children1 node 'wsdl:port))
+ (let ((name (xml-get-attribute node 'name))
+ (binding (xml-get-attribute node 'binding))
+ (url (let ((n (car (soap-xml-get-children1
+ node 'wsdlsoap:address))))
+ (xml-get-attribute n 'location))))
+ (let ((port (make-soap-port
+ :name name :binding (soap-l2fq binding 'tns)
+ :service-url url)))
+ (soap-namespace-put port ns)
+ (push port (soap-wsdl-ports wsdl))))))
+
+ (soap-wsdl-add-namespace ns wsdl))))
+
+(defun soap-parse-wsdl (node wsdl)
+ "Construct from NODE a WSDL structure, which is an XML document."
+ ;; Break this into phases to allow for asynchronous parsing.
+ (soap-parse-wsdl-phase-validate-node node)
+ ;; Makes synchronous calls.
+ (soap-parse-wsdl-phase-fetch-imports node wsdl)
+ (soap-parse-wsdl-phase-parse-schema node wsdl)
+ ;; Makes synchronous calls.
+ (soap-parse-wsdl-phase-fetch-schema node wsdl)
+ (soap-parse-wsdl-phase-finish-parsing node wsdl)
+ wsdl)
(defun soap-parse-message (node)
"Parse NODE as a wsdl:message and return the corresponding type."
(assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:message)
nil
- "soap-parse-message: expecting wsdl:message node, got %s"
+ "expecting wsdl:message node, got %s"
(soap-l2wk (xml-node-name node)))
(let ((name (xml-get-attribute-or-nil node 'name))
parts)
@@ -1062,97 +2485,111 @@ contents."
(when type
(setq type (soap-l2fq type 'tns)))
- (when element
- (setq element (soap-l2fq element 'tns)))
+ (if element
+ (setq element (soap-l2fq element 'tns))
+ ;; else
+ (setq element (make-soap-xs-element
+ :name name
+ :namespace-tag soap-target-xmlns
+ :type^ type)))
- (push (cons name (or type element)) parts)))
+ (push (cons name element) parts)))
(make-soap-message :name name :parts (nreverse parts))))
(defun soap-parse-port-type (node)
"Parse NODE as a wsdl:portType and return the corresponding port."
(assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:portType)
nil
- "soap-parse-port-type: expecting wsdl:portType node got %s"
+ "expecting wsdl:portType node got %s"
(soap-l2wk (xml-node-name node)))
- (let ((ns (make-soap-namespace
- :name (concat "urn:" (xml-get-attribute node 'name)))))
+ (let* ((soap-target-xmlns (concat "urn:" (xml-get-attribute node 'name)))
+ (ns (make-soap-namespace :name soap-target-xmlns)))
(dolist (node (soap-xml-get-children1 node 'wsdl:operation))
(let ((o (soap-parse-operation node)))
(let ((other-operation (soap-namespace-get
- (soap-element-name o) ns 'soap-operation-p)))
+ (soap-element-name o) ns 'soap-operation-p)))
(if other-operation
;; Unfortunately, the Confluence WSDL defines two operations
;; named "search" which differ only in parameter names...
(soap-warning "Discarding duplicate operation: %s"
- (soap-element-name o))
+ (soap-element-name o))
- (progn
- (soap-namespace-put o ns)
+ (progn
+ (soap-namespace-put o ns)
- ;; link all messages from this namespace, as this namespace
- ;; will be used for decoding the response.
- (destructuring-bind (name . message) (soap-operation-input o)
- (soap-namespace-put-link name message ns))
+ ;; link all messages from this namespace, as this namespace
+ ;; will be used for decoding the response.
+ (destructuring-bind (name . message) (soap-operation-input o)
+ (soap-namespace-put-link name message ns))
- (destructuring-bind (name . message) (soap-operation-output o)
- (soap-namespace-put-link name message ns))
+ (destructuring-bind (name . message) (soap-operation-output o)
+ (soap-namespace-put-link name message ns))
- (dolist (fault (soap-operation-faults o))
- (destructuring-bind (name . message) fault
- (soap-namespace-put-link name message ns 'replace)))
+ (dolist (fault (soap-operation-faults o))
+ (destructuring-bind (name . message) fault
+ (soap-namespace-put-link name message ns)))
- )))))
+ )))))
(make-soap-port-type :name (xml-get-attribute node 'name)
- :operations ns)))
+ :operations ns)))
(defun soap-parse-operation (node)
"Parse NODE as a wsdl:operation and return the corresponding type."
(assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:operation)
nil
- "soap-parse-operation: expecting wsdl:operation node, got %s"
+ "expecting wsdl:operation node, got %s"
(soap-l2wk (xml-node-name node)))
(let ((name (xml-get-attribute node 'name))
(parameter-order (split-string
- (xml-get-attribute node 'parameterOrder)))
- input output faults)
+ (xml-get-attribute node 'parameterOrder)))
+ input output faults input-action output-action)
(dolist (n (xml-node-children node))
(when (consp n) ; skip string nodes which are whitespace
(let ((node-name (soap-l2wk (xml-node-name n))))
(cond
- ((eq node-name 'wsdl:input)
- (let ((message (xml-get-attribute n 'message))
- (name (xml-get-attribute n 'name)))
- (setq input (cons name (soap-l2fq message 'tns)))))
- ((eq node-name 'wsdl:output)
- (let ((message (xml-get-attribute n 'message))
- (name (xml-get-attribute n 'name)))
- (setq output (cons name (soap-l2fq message 'tns)))))
- ((eq node-name 'wsdl:fault)
- (let ((message (xml-get-attribute n 'message))
- (name (xml-get-attribute n 'name)))
- (push (cons name (soap-l2fq message 'tns)) faults)))))))
+ ((eq node-name 'wsdl:input)
+ (let ((message (xml-get-attribute n 'message))
+ (name (xml-get-attribute n 'name))
+ (action (soap-xml-get-attribute-or-nil1 n 'wsaw:Action)))
+ (setq input (cons name (soap-l2fq message 'tns)))
+ (setq input-action action)))
+ ((eq node-name 'wsdl:output)
+ (let ((message (xml-get-attribute n 'message))
+ (name (xml-get-attribute n 'name))
+ (action (soap-xml-get-attribute-or-nil1 n 'wsaw:Action)))
+ (setq output (cons name (soap-l2fq message 'tns)))
+ (setq output-action action)))
+ ((eq node-name 'wsdl:fault)
+ (let ((message (xml-get-attribute n 'message))
+ (name (xml-get-attribute n 'name)))
+ (push (cons name (soap-l2fq message 'tns)) faults)))))))
(make-soap-operation
:name name
+ :namespace-tag soap-target-xmlns
:parameter-order parameter-order
:input input
:output output
- :faults (nreverse faults))))
+ :faults (nreverse faults)
+ :input-action input-action
+ :output-action output-action)))
(defun soap-parse-binding (node)
"Parse NODE as a wsdl:binding and return the corresponding type."
(assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:binding)
nil
- "soap-parse-binding: expecting wsdl:binding node, got %s"
+ "expecting wsdl:binding node, got %s"
(soap-l2wk (xml-node-name node)))
(let ((name (xml-get-attribute node 'name))
(type (xml-get-attribute node 'type)))
(let ((binding (make-soap-binding :name name
- :port-type (soap-l2fq type 'tns))))
+ :port-type (soap-l2fq type 'tns))))
(dolist (wo (soap-xml-get-children1 node 'wsdl:operation))
(let ((name (xml-get-attribute wo 'name))
soap-action
+ soap-headers
+ soap-body
use)
(dolist (so (soap-xml-get-children1 wo 'wsdlsoap:operation))
(setq soap-action (xml-get-attribute-or-nil so 'soapAction)))
@@ -1163,9 +2600,24 @@ contents."
;; "use"-s for each of them...
(dolist (i (soap-xml-get-children1 wo 'wsdl:input))
- (dolist (b (soap-xml-get-children1 i 'wsdlsoap:body))
- (setq use (or use
- (xml-get-attribute-or-nil b 'use)))))
+
+ ;; There can be multiple headers ...
+ (dolist (h (soap-xml-get-children1 i 'wsdlsoap:header))
+ (let ((message (soap-l2fq (xml-get-attribute-or-nil h 'message)))
+ (part (xml-get-attribute-or-nil h 'part))
+ (use (xml-get-attribute-or-nil h 'use)))
+ (when (and message part)
+ (push (list message part use) soap-headers))))
+
+ ;; ... but only one body
+ (let ((body (car (soap-xml-get-children1 i 'wsdlsoap:body))))
+ (setq soap-body (xml-get-attribute-or-nil body 'parts))
+ (when soap-body
+ (setq soap-body
+ (mapcar #'intern (split-string soap-body
+ nil
+ 'omit-nulls))))
+ (setq use (xml-get-attribute-or-nil body 'use))))
(unless use
(dolist (i (soap-xml-get-children1 wo 'wsdl:output))
@@ -1173,9 +2625,12 @@ contents."
(setq use (or use
(xml-get-attribute-or-nil b 'use))))))
- (puthash name (make-soap-bound-operation :operation name
- :soap-action soap-action
- :use (and use (intern use)))
+ (puthash name (make-soap-bound-operation
+ :operation name
+ :soap-action soap-action
+ :soap-headers (nreverse soap-headers)
+ :soap-body soap-body
+ :use (and use (intern use)))
(soap-binding-operations binding))))
binding)))
@@ -1191,10 +2646,6 @@ SOAP response.")
This is a dynamically bound variable used during decoding the
SOAP response.")
-(defvar soap-current-wsdl nil
- "The current WSDL document used when decoding the SOAP response.
-This is a dynamically bound variable.")
-
(defun soap-decode-type (type node)
"Use TYPE (an xsd type) to decode the contents of NODE.
@@ -1212,7 +2663,8 @@ decode function to perform the actual decoding."
(when decoded
(throw 'done decoded)))
- (string-match "^#\\(.*\\)$" href) ; TODO: check that it matched
+ (unless (string-match "^#\\(.*\\)$" href)
+ (error "Invalid multiRef: %s" href))
(let ((id (match-string 1 href)))
(dolist (mr soap-multi-refs)
@@ -1227,38 +2679,53 @@ decode function to perform the actual decoding."
(soap-with-local-xmlns node
(if (equal (soap-xml-get-attribute-or-nil1 node 'xsi:nil) "true")
nil
- (let ((decoder (get (aref type 0) 'soap-decoder)))
- (assert decoder nil "no soap-decoder for %s type"
- (aref type 0))
- (funcall decoder type node))))))))
+ ;; Handle union types.
+ (cond ((listp type)
+ (catch 'done
+ (dolist (union-member type)
+ (let* ((decoder (get (aref union-member 0)
+ 'soap-decoder))
+ (result (ignore-errors
+ (funcall decoder
+ union-member node))))
+ (when result (throw 'done result))))))
+ (t
+ (let ((decoder (get (aref type 0) 'soap-decoder)))
+ (assert decoder nil
+ "no soap-decoder for %s type" (aref type 0))
+ (funcall decoder type node))))))))))
(defun soap-decode-any-type (node)
"Decode NODE using type information inside it."
;; If the NODE has type information, we use that...
(let ((type (soap-xml-get-attribute-or-nil1 node 'xsi:type)))
+ (when type
+ (setq type (soap-l2fq type)))
(if type
- (let ((wtype (soap-wsdl-get type soap-current-wsdl 'soap-type-p)))
+ (let ((wtype (soap-wsdl-get type soap-current-wsdl 'soap-xs-type-p)))
(if wtype
(soap-decode-type wtype node)
- ;; The node has type info encoded in it, but we don't know how
- ;; to decode it...
- (error "Soap-decode-any-type: node has unknown type: %s" type)))
-
- ;; No type info in the node...
-
- (let ((contents (xml-node-children node)))
- (if (and (= (length contents) 1) (stringp (car contents)))
- ;; contents is just a string
- (car contents)
-
- ;; we assume the NODE is a sequence with every element a
- ;; structure name
- (let (result)
- (dolist (element contents)
- (let ((key (xml-node-name element))
- (value (soap-decode-any-type element)))
- (push (cons key value) result)))
- (nreverse result)))))))
+ ;; The node has type info encoded in it, but we don't know how
+ ;; to decode it...
+ (error "Node has unknown type: %s" type)))
+
+ ;; No type info in the node...
+
+ (let ((contents (xml-node-children node)))
+ (if (and (= (length contents) 1) (stringp (car contents)))
+ ;; contents is just a string
+ (car contents)
+
+ ;; we assume the NODE is a sequence with every element a
+ ;; structure name
+ (let (result)
+ (dolist (element contents)
+ ;; skip any string contents, assume they are whitespace
+ (unless (stringp element)
+ (let ((key (xml-node-name element))
+ (value (soap-decode-any-type element)))
+ (push (cons key value) result))))
+ (nreverse result)))))))
(defun soap-decode-array (node)
"Decode NODE as an Array using type information inside it."
@@ -1267,90 +2734,23 @@ decode function to perform the actual decoding."
(contents (xml-node-children node))
result)
(when type
- ;; Type is in the format "someType[NUM]" where NUM is the number of
- ;; elements in the array. We discard the [NUM] part.
- (setq type (replace-regexp-in-string "\\[[0-9]+\\]\\'" "" type))
- (setq wtype (soap-wsdl-get type soap-current-wsdl 'soap-type-p))
- (unless wtype
- ;; The node has type info encoded in it, but we don't know how to
- ;; decode it...
- (error "Soap-decode-array: node has unknown type: %s" type)))
+ ;; Type is in the format "someType[NUM]" where NUM is the number of
+ ;; elements in the array. We discard the [NUM] part.
+ (setq type (replace-regexp-in-string "\\[[0-9]+\\]\\'" "" type))
+ (setq wtype (soap-wsdl-get (soap-l2fq type)
+ soap-current-wsdl 'soap-xs-type-p))
+ (unless wtype
+ ;; The node has type info encoded in it, but we don't know how to
+ ;; decode it...
+ (error "Soap-decode-array: node has unknown type: %s" type)))
(dolist (e contents)
(when (consp e)
(push (if wtype
(soap-decode-type wtype e)
- (soap-decode-any-type e))
+ (soap-decode-any-type e))
result)))
(nreverse result)))
-(defun soap-decode-basic-type (type node)
- "Use TYPE to decode the contents of NODE.
-TYPE is a `soap-basic-type' struct, and NODE is an XML document.
-A LISP value is returned based on the contents of NODE and the
-type-info stored in TYPE."
- (let ((contents (xml-node-children node))
- (type-kind (soap-basic-type-kind type)))
-
- (if (null contents)
- nil
- (ecase type-kind
- ((string anyURI) (car contents))
- (dateTime (car contents)) ; TODO: convert to a date time
- ((long int integer unsignedInt byte float double) (string-to-number
(car contents)))
- (boolean (string= (downcase (car contents)) "true"))
- (base64Binary (base64-decode-string (car contents)))
- (anyType (soap-decode-any-type node))
- (Array (soap-decode-array node))))))
-
-(defun soap-decode-sequence-type (type node)
- "Use TYPE to decode the contents of NODE.
-TYPE is assumed to be a sequence type and an ALIST with the
-contents of the NODE is returned."
- (let ((result nil)
- (parent (soap-sequence-type-parent type)))
- (when parent
- (setq result (nreverse (soap-decode-type parent node))))
- (dolist (element (soap-sequence-type-elements type))
- (let ((instance-count 0)
- (e-name (soap-sequence-element-name element))
- (e-type (soap-sequence-element-type element)))
- (dolist (node (xml-get-children node e-name))
- (incf instance-count)
- (push (cons e-name (soap-decode-type e-type node)) result))
- ;; Do some sanity checking
- (cond ((and (= instance-count 0)
- (not (soap-sequence-element-nillable? element)))
- (soap-warning "While decoding %s: missing non-nillable slot %s"
- (soap-element-name type) e-name))
- ((and (> instance-count 1)
- (not (soap-sequence-element-multiple? element)))
- (soap-warning "While decoding %s: multiple slots named %s"
- (soap-element-name type) e-name)))))
- (nreverse result)))
-
-(defun soap-decode-array-type (type node)
- "Use TYPE to decode the contents of NODE.
-TYPE is assumed to be an array type. Arrays are decoded as lists.
-This is because it is easier to work with list results in LISP."
- (let ((result nil)
- (element-type (soap-array-type-element-type type)))
- (dolist (node (xml-node-children node))
- (when (consp node)
- (push (soap-decode-type element-type node) result)))
- (nreverse result)))
-
-(progn
- (put (aref (make-soap-basic-type) 0)
- 'soap-decoder 'soap-decode-basic-type)
- ;; just use the basic type decoder for the simple type -- we accept any
- ;; value and don't do any validation on it.
- (put (aref (make-soap-simple-type) 0)
- 'soap-decoder 'soap-decode-basic-type)
- (put (aref (make-soap-sequence-type) 0)
- 'soap-decoder 'soap-decode-sequence-type)
- (put (aref (make-soap-array-type) 0)
- 'soap-decoder 'soap-decode-array-type))
-
;;;; Soap Envelope parsing
(define-error 'soap-error "SOAP error")
@@ -1362,40 +2762,44 @@ WSDL is used to decode the NODE"
(soap-with-local-xmlns node
(assert (eq (soap-l2wk (xml-node-name node)) 'soap:Envelope)
nil
- "soap-parse-envelope: expecting soap:Envelope node, got %s"
+ "expecting soap:Envelope node, got %s"
(soap-l2wk (xml-node-name node)))
- (let ((body (car (soap-xml-get-children1 node 'soap:Body))))
+ (let ((headers (soap-xml-get-children1 node 'soap:Header))
+ (body (car (soap-xml-get-children1 node 'soap:Body))))
(let ((fault (car (soap-xml-get-children1 body 'soap:Fault))))
(when fault
(let ((fault-code (let ((n (car (xml-get-children
- fault 'faultcode))))
+ fault 'faultcode))))
(car-safe (xml-node-children n))))
(fault-string (let ((n (car (xml-get-children
fault 'faultstring))))
(car-safe (xml-node-children n))))
(detail (xml-get-children fault 'detail)))
- (while t
- (signal 'soap-error (list fault-code fault-string detail))))))
+ (while t
+ (signal 'soap-error (list fault-code fault-string detail))))))
;; First (non string) element of the body is the root node of he
;; response
(let ((response (if (eq (soap-bound-operation-use operation) 'literal)
;; For 'literal uses, the response is the actual body
body
- ;; ...otherwise the first non string element
- ;; of the body is the response
- (catch 'found
- (dolist (n (xml-node-children body))
- (when (consp n)
- (throw 'found n)))))))
- (soap-parse-response response operation wsdl body)))))
-
-(defun soap-parse-response (response-node operation wsdl soap-body)
+ ;; ...otherwise the first non string element
+ ;; of the body is the response
+ (catch 'found
+ (dolist (n (xml-node-children body))
+ (when (consp n)
+ (throw 'found n)))))))
+ (soap-parse-response response operation wsdl headers body)))))
+
+(defun soap-parse-response (response-node operation wsdl soap-headers
soap-body)
"Parse RESPONSE-NODE and return the result as a LISP value.
OPERATION is the WSDL operation for which we expect the response,
WSDL is used to decode the NODE.
+SOAP-HEADERS is a list of the headers of the SOAP envelope or nil
+if there are no headers.
+
SOAP-BODY is the body of the SOAP envelope (of which
RESPONSE-NODE is a sub-node). It is used in case RESPONSE-NODE
reference multiRef parts which are external to RESPONSE-NODE."
@@ -1409,7 +2813,7 @@ reference multiRef parts which are external to
RESPONSE-NODE."
(when (eq use 'encoded)
(let* ((received-message-name (soap-l2fq (xml-node-name
response-node)))
(received-message (soap-wsdl-get
- received-message-name wsdl 'soap-message-p)))
+ received-message-name wsdl 'soap-message-p)))
(unless (eq received-message message)
(error "Unexpected message: got %s, expecting %s"
received-message-name
@@ -1426,42 +2830,52 @@ reference multiRef parts which are external to
RESPONSE-NODE."
(setq node
(cond
- ((eq use 'encoded)
- (car (xml-get-children response-node tag)))
-
- ((eq use 'literal)
- (catch 'found
- (let* ((ns-aliases (soap-wsdl-alias-table wsdl))
- (ns-name (cdr (assoc
- (soap-element-namespace-tag type)
- ns-aliases)))
- (fqname (cons ns-name (soap-element-name type))))
- (dolist (c (xml-node-children response-node))
- (when (consp c)
- (soap-with-local-xmlns c
- (when (equal (soap-l2fq (xml-node-name c))
- fqname)
- (throw 'found c))))))))))
+ ((eq use 'encoded)
+ (car (xml-get-children response-node tag)))
+
+ ((eq use 'literal)
+ (catch 'found
+ (let* ((ns-aliases (soap-wsdl-alias-table wsdl))
+ (ns-name (cdr (assoc
+ (soap-element-namespace-tag type)
+ ns-aliases)))
+ (fqname (cons ns-name (soap-element-name type))))
+ (dolist (c (append (mapcar (lambda (header)
+ (car (xml-node-children
+ header)))
+ soap-headers)
+ (xml-node-children response-node)))
+ (when (consp c)
+ (soap-with-local-xmlns c
+ (when (equal (soap-l2fq (xml-node-name c))
+ fqname)
+ (throw 'found c))))))))))
(unless node
(error "Soap-parse-response(%s): cannot find message part %s"
(soap-element-name op) tag))
- (push (soap-decode-type type node) decoded-parts)))
+ (let ((decoded-value (soap-decode-type type node)))
+ (when decoded-value
+ (push decoded-value decoded-parts)))))
decoded-parts))))
;;;; SOAP type encoding
-(defvar soap-encoded-namespaces nil
- "A list of namespace tags used during encoding a message.
-This list is populated by `soap-encode-value' and used by
-`soap-create-envelope' to add aliases for these namespace to the
-XML request.
+(defun soap-encode-attributes (value type)
+ "Encode XML attributes for VALUE according to TYPE.
+This is a generic function which determines the attribute encoder
+for the type and calls that specialized function to do the work.
-This variable is dynamically bound in `soap-create-envelope'.")
+Attributes are inserted in the current buffer at the current
+position."
+ (let ((attribute-encoder (get (aref type 0) 'soap-attribute-encoder)))
+ (assert attribute-encoder nil
+ "no soap-attribute-encoder for %s type" (aref type 0))
+ (funcall attribute-encoder value type)))
-(defun soap-encode-value (xml-tag value type)
- "Encode inside an XML-TAG the VALUE using TYPE.
+(defun soap-encode-value (value type)
+ "Encode the VALUE using TYPE.
The resulting XML data is inserted in the current buffer
at (point)/
@@ -1471,190 +2885,24 @@ encoder function based on TYPE and calls that encoder
to do the
work."
(let ((encoder (get (aref type 0) 'soap-encoder)))
(assert encoder nil "no soap-encoder for %s type" (aref type 0))
- ;; XML-TAG can be a string or a symbol, but we pass only string's to the
- ;; encoders
- (when (symbolp xml-tag)
- (setq xml-tag (symbol-name xml-tag)))
- (funcall encoder xml-tag value type))
- (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag type)))
-
-(defun soap-encode-basic-type (xml-tag value type)
- "Encode inside XML-TAG the LISP VALUE according to TYPE.
-Do not call this function directly, use `soap-encode-value'
-instead."
- (let ((xsi-type (soap-element-fq-name type))
- (basic-type (soap-basic-type-kind type)))
-
- ;; try to classify the type based on the value type and use that type when
- ;; encoding
- (when (eq basic-type 'anyType)
- (cond ((stringp value)
- (setq xsi-type "xsd:string" basic-type 'string))
- ((integerp value)
- (setq xsi-type "xsd:int" basic-type 'int))
- ((memq value '(t nil))
- (setq xsi-type "xsd:boolean" basic-type 'boolean))
- (t
- (error
- "Soap-encode-basic-type(%s, %s, %s): cannot classify anyType
value"
- xml-tag value xsi-type))))
+ (funcall encoder value type))
+ (when (soap-element-namespace-tag type)
+ (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag type))))
- (insert "<" xml-tag " xsi:type=\"" xsi-type "\"")
-
- ;; We have some ambiguity here, as a nil value represents "false" when the
- ;; type is boolean, we will never have a "nil" boolean type...
-
- (if (or value (eq basic-type 'boolean))
- (progn
- (insert ">")
- (case basic-type
- ((string anyURI)
- (unless (stringp value)
- (error "Soap-encode-basic-type(%s, %s, %s): not a string value"
- xml-tag value xsi-type))
- (insert (url-insert-entities-in-string value)))
-
- (dateTime
- (cond ((and (consp value) ; is there a time-value-p ?
- (>= (length value) 2)
- (numberp (nth 0 value))
- (numberp (nth 1 value)))
- ;; Value is a (current-time) style value, convert
- ;; to a string
- (insert (format-time-string "%Y-%m-%dT%H:%M:%S" value)))
- ((stringp value)
- (insert (url-insert-entities-in-string value)))
- (t
- (error
- "Soap-encode-basic-type(%s, %s, %s): not a dateTime value"
- xml-tag value xsi-type))))
-
- (boolean
- (unless (memq value '(t nil))
- (error "Soap-encode-basic-type(%s, %s, %s): not a boolean value"
- xml-tag value xsi-type))
- (insert (if value "true" "false")))
-
- ((long int integer byte unsignedInt)
- (unless (integerp value)
- (error "Soap-encode-basic-type(%s, %s, %s): not an integer
value"
- xml-tag value xsi-type))
- (when (and (eq basic-type 'unsignedInt) (< value 0))
- (error "Soap-encode-basic-type(%s, %s, %s): not a positive
integer"
- xml-tag value xsi-type))
- (insert (number-to-string value)))
-
- ((float double)
- (unless (numberp value)
- (error "Soap-encode-basic-type(%s, %s, %s): not a number"
- xml-tag value xsi-type))
- (insert (number-to-string value)))
-
- (base64Binary
- (unless (stringp value)
- (error "Soap-encode-basic-type(%s, %s, %s): not a string value"
- xml-tag value xsi-type))
- (insert (base64-encode-string value)))
-
- (otherwise
- (error
- "Soap-encode-basic-type(%s, %s, %s): don't know how to encode"
- xml-tag value xsi-type))))
-
- (insert " xsi:nil=\"true\">"))
- (insert "</" xml-tag ">\n")))
-
-(defun soap-encode-simple-type (xml-tag value type)
- "Encode inside XML-TAG the LISP VALUE according to TYPE."
-
- ;; Validate VALUE against the simple type's enumeration, than just encode it
- ;; using `soap-encode-basic-type'
-
- (let ((enumeration (soap-simple-type-enumeration type)))
- (unless (and (> (length enumeration) 1)
- (member value enumeration))
- (error "soap-encode-simple-type(%s, %s, %s): bad value, should be one of
%s"
- xml-tag value (soap-element-fq-name type) enumeration)))
-
- (soap-encode-basic-type xml-tag value type))
-
-(defun soap-encode-sequence-type (xml-tag value type)
- "Encode inside XML-TAG the LISP VALUE according to TYPE.
-Do not call this function directly, use `soap-encode-value'
-instead."
- (let ((xsi-type (soap-element-fq-name type)))
- (insert "<" xml-tag " xsi:type=\"" xsi-type "\"")
- (if value
- (progn
- (insert ">\n")
- (let ((parents (list type))
- (parent (soap-sequence-type-parent type)))
-
- (while parent
- (push parent parents)
- (setq parent (soap-sequence-type-parent parent)))
-
- (dolist (type parents)
- (dolist (element (soap-sequence-type-elements type))
- (let ((instance-count 0)
- (e-name (soap-sequence-element-name element))
- (e-type (soap-sequence-element-type element)))
- (dolist (v value)
- (when (equal (car v) e-name)
- (incf instance-count)
- (soap-encode-value e-name (cdr v) e-type)))
-
- ;; Do some sanity checking
- (cond ((and (= instance-count 0)
- (not (soap-sequence-element-nillable? element)))
- (soap-warning
- "While encoding %s: missing non-nillable slot %s"
- (soap-element-name type) e-name))
- ((and (> instance-count 1)
- (not (soap-sequence-element-multiple? element)))
- (soap-warning
- "While encoding %s: multiple slots named %s"
- (soap-element-name type) e-name))))))))
- (insert " xsi:nil=\"true\">"))
- (insert "</" xml-tag ">\n")))
-
-(defun soap-encode-array-type (xml-tag value type)
- "Encode inside XML-TAG the LISP VALUE according to TYPE.
-Do not call this function directly, use `soap-encode-value'
-instead."
- (unless (vectorp value)
- (error "Soap-encode: %s(%s) expects a vector, got: %s"
- xml-tag (soap-element-fq-name type) value))
- (let* ((element-type (soap-array-type-element-type type))
- (array-type (concat (soap-element-fq-name element-type)
- "[" (format "%s" (length value)) "]")))
- (insert "<" xml-tag
- " soapenc:arrayType=\"" array-type "\" "
- " xsi:type=\"soapenc:Array\">\n")
- (loop for i below (length value)
- do (soap-encode-value xml-tag (aref value i) element-type))
- (insert "</" xml-tag ">\n")))
-
-(progn
- (put (aref (make-soap-basic-type) 0)
- 'soap-encoder 'soap-encode-basic-type)
- (put (aref (make-soap-simple-type) 0)
- 'soap-encoder 'soap-encode-simple-type)
- (put (aref (make-soap-sequence-type) 0)
- 'soap-encoder 'soap-encode-sequence-type)
- (put (aref (make-soap-array-type) 0)
- 'soap-encoder 'soap-encode-array-type))
-
-(defun soap-encode-body (operation parameters wsdl)
+(defun soap-encode-body (operation parameters &optional service-url)
"Create the body of a SOAP request for OPERATION in the current buffer.
PARAMETERS is a list of parameters supplied to the OPERATION.
The OPERATION and PARAMETERS are encoded according to the WSDL
-document."
+document. SERVICE-URL should be provided when WS-Addressing is
+being used."
(let* ((op (soap-bound-operation-operation operation))
(use (soap-bound-operation-use operation))
(message (cdr (soap-operation-input op)))
- (parameter-order (soap-operation-parameter-order op)))
+ (parameter-order (soap-operation-parameter-order op))
+ (param-table (loop for formal in parameter-order
+ for value in parameters
+ collect (cons formal value))))
(unless (= (length parameter-order) (length parameters))
(error "Wrong number of parameters for %s: expected %d, got %s"
@@ -1662,62 +2910,73 @@ document."
(length parameter-order)
(length parameters)))
+ (let ((headers (soap-bound-operation-soap-headers operation))
+ (input-action (soap-operation-input-action op)))
+ (when headers
+ (insert "<soap:Header>\n")
+ (when input-action
+ (add-to-list 'soap-encoded-namespaces "wsa")
+ (insert "<wsa:Action>" input-action "</wsa:Action>\n")
+ (insert "<wsa:To>" service-url "</wsa:To>\n"))
+ (dolist (h headers)
+ (let* ((message (nth 0 h))
+ (part (assq (nth 1 h) (soap-message-parts message)))
+ (value (cdr (assoc (car part) (car parameters))))
+ (use (nth 2 h))
+ (element (cdr part)))
+ (when (eq use 'encoded)
+ (when (soap-element-namespace-tag element)
+ (add-to-list 'soap-encoded-namespaces
+ (soap-element-namespace-tag element)))
+ (insert "<" (soap-element-fq-name element) ">\n"))
+ (soap-encode-value value element)
+ (when (eq use 'encoded)
+ (insert "</" (soap-element-fq-name element) ">\n"))))
+ (insert "</soap:Header>\n")))
+
(insert "<soap:Body>\n")
(when (eq use 'encoded)
- (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag op))
+ (when (soap-element-namespace-tag op)
+ (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag op)))
(insert "<" (soap-element-fq-name op) ">\n"))
- (let ((param-table (loop for formal in parameter-order
- for value in parameters
- collect (cons formal value))))
- (dolist (part (soap-message-parts message))
- (let* ((param-name (car part))
- (type (cdr part))
- (tag-name (if (eq use 'encoded)
- param-name
- (soap-element-name type)))
- (value (cdr (assoc param-name param-table)))
- (start-pos (point)))
- (soap-encode-value tag-name value type)
- (when (eq use 'literal)
- ;; hack: add the xmlns attribute to the tag, the only way
- ;; ASP.NET web services recognize the namespace of the
- ;; element itself...
- (save-excursion
- (goto-char start-pos)
- (when (re-search-forward " ")
- (let* ((ns (soap-element-namespace-tag type))
- (namespace (cdr (assoc ns
- (soap-wsdl-alias-table wsdl)))))
- (when namespace
- (insert "xmlns=\"" namespace "\" ")))))))))
+ (dolist (part (soap-message-parts message))
+ (let* ((param-name (car part))
+ (element (cdr part))
+ (value (cdr (assoc param-name param-table))))
+ (when (or (null (soap-bound-operation-soap-body operation))
+ (member param-name
+ (soap-bound-operation-soap-body operation)))
+ (soap-encode-value value element))))
(when (eq use 'encoded)
(insert "</" (soap-element-fq-name op) ">\n"))
(insert "</soap:Body>\n")))
-(defun soap-create-envelope (operation parameters wsdl)
+(defun soap-create-envelope (operation parameters wsdl &optional service-url)
"Create a SOAP request envelope for OPERATION using PARAMETERS.
-WSDL is the wsdl document used to encode the PARAMETERS."
+WSDL is the wsdl document used to encode the PARAMETERS.
+SERVICE-URL should be provided when WS-Addressing is being used."
(with-temp-buffer
(let ((soap-encoded-namespaces '("xsi" "soap" "soapenc"))
(use (soap-bound-operation-use operation)))
;; Create the request body
- (soap-encode-body operation parameters wsdl)
+ (soap-encode-body operation parameters service-url)
;; Put the envelope around the body
(goto-char (point-min))
(insert "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<soap:Envelope\n")
(when (eq use 'encoded)
- (insert "
soapenc:encodingStyle=\"http://schemas.xmlsoap.org/soap/encoding/\"\n";))
+ (insert " soapenc:encodingStyle=\"\
+http://schemas.xmlsoap.org/soap/encoding/\"\n";))
(dolist (nstag soap-encoded-namespaces)
(insert " xmlns:" nstag "=\"")
(let ((nsname (cdr (assoc nstag soap-well-known-xmlns))))
(unless nsname
(setq nsname (cdr (assoc nstag (soap-wsdl-alias-table wsdl)))))
(insert nsname)
- (insert "\"\n")))
+ (insert "\"\n")))
(insert ">\n")
(goto-char (point-max))
(insert "</soap:Envelope>\n"))
@@ -1731,6 +2990,86 @@ WSDL is the wsdl document used to encode the PARAMETERS."
:type 'boolean
:group 'soap-client)
+(defun soap-invoke-internal (callback cbargs wsdl service operation-name
+ &rest parameters)
+ "Implement `soap-invoke' and `soap-invoke-async'.
+If CALLBACK is non-nil, operate asynchronously, then call CALLBACK as (apply
+CALLBACK RESPONSE CBARGS), where RESPONSE is the SOAP invocation result.
+If CALLBACK is nil, operate synchronously. WSDL, SERVICE,
+OPERATION-NAME and PARAMETERS are as described in `soap-invoke'."
+ (let ((port (catch 'found
+ (dolist (p (soap-wsdl-ports wsdl))
+ (when (equal service (soap-element-name p))
+ (throw 'found p))))))
+ (unless port
+ (error "Unknown SOAP service: %s" service))
+
+ (let* ((binding (soap-port-binding port))
+ (operation (gethash operation-name
+ (soap-binding-operations binding))))
+ (unless operation
+ (error "No operation %s for SOAP service %s" operation-name service))
+
+ (let ((url-request-method "POST")
+ (url-package-name "soap-client.el")
+ (url-package-version "1.0")
+ (url-request-data
+ ;; url-request-data expects a unibyte string already encoded...
+ (encode-coding-string
+ (soap-create-envelope operation parameters wsdl
+ (soap-port-service-url port))
+ 'utf-8))
+ (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5")
+ (url-http-attempt-keepalives t)
+ (url-request-extra-headers
+ (list
+ (cons "SOAPAction"
+ (concat "\"" (soap-bound-operation-soap-action
+ operation) "\""))
+ (cons "Content-Type"
+ "text/xml; charset=utf-8"))))
+ (if callback
+ (url-retrieve
+ (soap-port-service-url port)
+ (lambda (status)
+ (let ((data-buffer (current-buffer)))
+ (unwind-protect
+ (let ((error-status (plist-get status :error)))
+ (if error-status
+ (signal (car error-status) (cdr error-status))
+ (apply callback
+ (soap-parse-envelope
+ (soap-parse-server-response)
+ operation wsdl)
+ cbargs)))
+ ;; Ensure the url-retrieve buffer is not leaked.
+ (and (buffer-live-p data-buffer)
+ (kill-buffer data-buffer))))))
+ (let ((buffer (url-retrieve-synchronously
+ (soap-port-service-url port))))
+ (condition-case err
+ (with-current-buffer buffer
+ (declare (special url-http-response-status))
+ (if (null url-http-response-status)
+ (error "No HTTP response from server"))
+ (if (and soap-debug (> url-http-response-status 299))
+ ;; This is a warning because some SOAP errors come
+ ;; back with a HTTP response 500 (internal server
+ ;; error)
+ (warn "Error in SOAP response: HTTP code %s"
+ url-http-response-status))
+ (soap-parse-envelope (soap-parse-server-response)
+ operation wsdl))
+ (soap-error
+ ;; Propagate soap-errors -- they are error replies of the
+ ;; SOAP protocol and don't indicate a communication
+ ;; problem or a bug in this code.
+ (signal (car err) (cdr err)))
+ (error
+ (when soap-debug
+ (pop-to-buffer buffer))
+ (error (error-message-string err))))))))))
+
(defun soap-invoke (wsdl service operation-name &rest parameters)
"Invoke a SOAP operation and return the result.
@@ -1749,72 +3088,18 @@ NOTE: The SOAP service provider should document the
available
operations and their parameters for the service. You can also
use the `soap-inspect' function to browse the available
operations in a WSDL document."
- (let ((port (catch 'found
- (dolist (p (soap-wsdl-ports wsdl))
- (when (equal service (soap-element-name p))
- (throw 'found p))))))
- (unless port
- (error "Unknown SOAP service: %s" service))
-
- (let* ((binding (soap-port-binding port))
- (operation (gethash operation-name
- (soap-binding-operations binding))))
- (unless operation
- (error "No operation %s for SOAP service %s" operation-name service))
-
- (let ((url-request-method "POST")
- (url-package-name "soap-client.el")
- (url-package-version "1.0")
- (url-http-version "1.0")
- (url-request-data
- ;; url-request-data expects a unibyte string already encoded...
- (encode-coding-string
- (soap-create-envelope operation parameters wsdl)
- 'utf-8))
- (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5")
- (url-request-coding-system 'utf-8)
- (url-http-attempt-keepalives t)
- (url-request-extra-headers (list
- (cons "SOAPAction"
- (soap-bound-operation-soap-action
- operation))
- (cons "Content-Type"
- "text/xml; charset=utf-8"))))
- (let ((buffer (url-retrieve-synchronously
- (soap-port-service-url port))))
- (condition-case err
- (with-current-buffer buffer
- (declare (special url-http-response-status))
- (if (null url-http-response-status)
- (error "No HTTP response from server"))
- (if (and soap-debug (> url-http-response-status 299))
- ;; This is a warning because some SOAP errors come
- ;; back with a HTTP response 500 (internal server
- ;; error)
- (warn "Error in SOAP response: HTTP code %s"
- url-http-response-status))
- (let ((mime-part (mm-dissect-buffer t t)))
- (unless mime-part
- (error "Failed to decode response from server"))
- (unless (equal (car (mm-handle-type mime-part)) "text/xml")
- (error "Server response is not an XML document"))
- (with-temp-buffer
- (mm-insert-part mime-part)
- (let ((response (car (xml-parse-region
- (point-min) (point-max)))))
- (prog1
- (soap-parse-envelope response operation wsdl)
- (kill-buffer buffer)
- (mm-destroy-part mime-part))))))
- (soap-error
- ;; Propagate soap-errors -- they are error replies of the
- ;; SOAP protocol and don't indicate a communication
- ;; problem or a bug in this code.
- (signal (car err) (cdr err)))
- (error
- (when soap-debug
- (pop-to-buffer buffer))
- (error (error-message-string err)))))))))
+ (apply #'soap-invoke-internal nil nil wsdl service operation-name
parameters))
+
+(defun soap-invoke-async (callback cbargs wsdl service operation-name
+ &rest parameters)
+ "Like `soap-invoke', but call CALLBACK asynchronously with response.
+CALLBACK is called as (apply CALLBACK RESPONSE CBARGS), where
+RESPONSE is the SOAP invocation result. WSDL, SERVICE,
+OPERATION-NAME and PARAMETERS are as described in `soap-invoke'."
+ (unless callback
+ (error "Callback argument is nil"))
+ (apply #'soap-invoke-internal callback cbargs wsdl service operation-name
+ parameters))
(provide 'soap-client)
diff --git a/lisp/net/soap-inspect.el b/lisp/net/soap-inspect.el
index 2f9cdcb..7182b79 100644
--- a/lisp/net/soap-inspect.el
+++ b/lisp/net/soap-inspect.el
@@ -1,9 +1,10 @@
-;;;; soap-inspect.el -- Interactive inspector for soap WSDL structures
+;;;; soap-inspect.el -- Interactive WSDL inspector -*- lexical-binding: t
-*-
;; Copyright (C) 2010-2015 Free Software Foundation, Inc.
;; Author: Alexandru Harsanyi <address@hidden>
;; Created: October 2010
+;; Version: 3.0.0
;; Keywords: soap, web-services, comm, hypermedia
;; Package: soap-client
;; Homepage: http://code.google.com/p/emacs-soap-client
@@ -55,86 +56,153 @@ will be called."
(funcall sample-value type)
(error "Cannot provide sample value for type %s" (aref type 0)))))
-(defun soap-sample-value-for-basic-type (type)
- "Provide a sample value for TYPE which is a basic type.
-This is a specific function which should not be called directly,
-use `soap-sample-value' instead."
- (case (soap-basic-type-kind type)
- (string "a string value")
- (boolean t) ; could be nil as well
- ((long int) (random 4200))
- ;; TODO: we need better sample values for more types.
- (t (format "%s" (soap-basic-type-kind type)))))
-
-(defun soap-sample-value-for-simple-type (type)
- "Provide a sample value for TYPE which is a simple type.
-This is a specific function which should not be called directly,
-use `soap-sample-value' instead."
- (let ((enumeration (soap-simple-type-enumeration type)))
- (if (> (length enumeration) 1)
- (elt enumeration (random (length enumeration)))
- (soap-sample-value-for-basic-type type))))
-
-(defun soap-sample-value-for-seqence-type (type)
- "Provide a sample value for TYPE which is a sequence type.
-Values for sequence types are ALISTS of (slot-name . VALUE) for
-each sequence element.
-
-This is a specific function which should not be called directly,
-use `soap-sample-value' instead."
- (let ((sample-value nil))
- (dolist (element (soap-sequence-type-elements type))
- (push (cons (soap-sequence-element-name element)
- (soap-sample-value (soap-sequence-element-type element)))
- sample-value))
- (when (soap-sequence-type-parent type)
- (setq sample-value
- (append (soap-sample-value (soap-sequence-type-parent type))
- sample-value)))
- sample-value))
-
-(defun soap-sample-value-for-array-type (type)
- "Provide a sample value for TYPE which is an array type.
-Values for array types are LISP vectors of values which are
-array's element type.
-
-This is a specific function which should not be called directly,
-use `soap-sample-value' instead."
- (let* ((element-type (soap-array-type-element-type type))
- (sample1 (soap-sample-value element-type))
- (sample2 (soap-sample-value element-type)))
- ;; Our sample value is a vector of two elements, but any number of
- ;; elements are permissible
- (vector sample1 sample2 '&etc)))
+(defun soap-sample-value-for-xs-basic-type (type)
+ "Provide a sample value for TYPE, an xs-basic-type.
+This is a specialization of `soap-sample-value' for xs-basic-type
+objects."
+ (case (soap-xs-basic-type-kind type)
+ (string "a string")
+ (anyURI "an URI")
+ (QName "a QName")
+ (dateTime "a time-value-p or string")
+ (boolean "t or nil")
+ ((long int integer byte unsignedInt) 42)
+ ((float double) 3.14)
+ (base64Binary "a string")
+ (t (format "%s" (soap-xs-basic-type-kind type)))))
+
+(defun soap-sample-value-for-xs-element (element)
+ "Provide a sample value for ELEMENT, a WSDL element.
+This is a specialization of `soap-sample-value' for xs-element
+objects."
+ (if (soap-xs-element-name element)
+ (cons (intern (soap-xs-element-name element))
+ (soap-sample-value (soap-xs-element-type element)))
+ (soap-sample-value (soap-xs-element-type element))))
+
+(defun soap-sample-value-for-xs-attribute (attribute)
+ "Provide a sample value for ATTRIBUTE, a WSDL attribute.
+This is a specialization of `soap-sample-value' for
+soap-xs-attribute objects."
+ (if (soap-xs-attribute-name attribute)
+ (cons (intern (soap-xs-attribute-name attribute))
+ (soap-sample-value (soap-xs-attribute-type attribute)))
+ (soap-sample-value (soap-xs-attribute-type attribute))))
+
+(defun soap-sample-value-for-xs-attribute-group (attribute-group)
+ "Provide a sample value for ATTRIBUTE-GROUP, a WSDL attribute group.
+This is a specialization of `soap-sample-value' for
+soap-xs-attribute objects."
+ (let ((sample-values nil))
+ (dolist (attribute (soap-xs-attribute-group-attributes attribute-group))
+ (if (soap-xs-attribute-name attribute)
+ (setq sample-values
+ (append sample-values
+ (cons (intern (soap-xs-attribute-name attribute))
+ (soap-sample-value (soap-xs-attribute-type
+ attribute)))))
+ (setq sample-values
+ (append sample-values
+ (soap-sample-value
+ (soap-xs-attribute-type attribute))))))))
+
+(defun soap-sample-value-for-xs-simple-type (type)
+ "Provide a sample value for TYPE, a `soap-xs-simple-type'.
+This is a specialization of `soap-sample-value' for
+`soap-xs-simple-type' objects."
+ (append
+ (mapcar 'soap-sample-value-for-xs-attribute
+ (soap-xs-type-attributes type))
+ (cond
+ ((soap-xs-simple-type-enumeration type)
+ (let ((enumeration (soap-xs-simple-type-enumeration type)))
+ (nth (random (length enumeration)) enumeration)))
+ ((soap-xs-simple-type-pattern type)
+ (format "a string matching %s" (soap-xs-simple-type-pattern type)))
+ ((soap-xs-simple-type-length-range type)
+ (destructuring-bind (low . high) (soap-xs-simple-type-length-range type)
+ (cond
+ ((and low high)
+ (format "a string between %d and %d chars long" low high))
+ (low (format "a string at least %d chars long" low))
+ (high (format "a string at most %d chars long" high))
+ (t (format "a string OOPS")))))
+ ((soap-xs-simple-type-integer-range type)
+ (destructuring-bind (min . max) (soap-xs-simple-type-integer-range type)
+ (cond
+ ((and min max) (+ min (random (- max min))))
+ (min (+ min (random 10)))
+ (max (random max))
+ (t (random 100)))))
+ ((consp (soap-xs-simple-type-base type)) ; an union of values
+ (let ((base (soap-xs-simple-type-base type)))
+ (soap-sample-value (nth (random (length base)) base))))
+ ((soap-xs-basic-type-p (soap-xs-simple-type-base type))
+ (soap-sample-value (soap-xs-simple-type-base type))))))
+
+(defun soap-sample-value-for-xs-complex-type (type)
+ "Provide a sample value for TYPE, a `soap-xs-complex-type'.
+This is a specialization of `soap-sample-value' for
+`soap-xs-complex-type' objects."
+ (append
+ (mapcar 'soap-sample-value-for-xs-attribute
+ (soap-xs-type-attributes type))
+ (case (soap-xs-complex-type-indicator type)
+ (array
+ (let* ((element-type (soap-xs-complex-type-base type))
+ (sample1 (soap-sample-value element-type))
+ (sample2 (soap-sample-value element-type)))
+ ;; Our sample value is a vector of two elements, but any number of
+ ;; elements are permissible
+ (vector sample1 sample2 '&etc)))
+ ((sequence choice all)
+ (let ((base (soap-xs-complex-type-base type)))
+ (let ((value (append (and base (soap-sample-value base))
+ (mapcar #'soap-sample-value
+ (soap-xs-complex-type-elements type)))))
+ (if (eq (soap-xs-complex-type-indicator type) 'choice)
+ (cons '***choice-of*** value)
+ value)))))))
(defun soap-sample-value-for-message (message)
"Provide a sample value for a WSDL MESSAGE.
-This is a specific function which should not be called directly,
-use `soap-sample-value' instead."
+This is a specialization of `soap-sample-value' for
+`soap-message' objects."
;; NOTE: parameter order is not considered.
(let (sample-value)
(dolist (part (soap-message-parts message))
- (push (cons (car part)
- (soap-sample-value (cdr part)))
- sample-value))
+ (push (soap-sample-value (cdr part)) sample-value))
(nreverse sample-value)))
(progn
;; Install soap-sample-value methods for our types
- (put (aref (make-soap-basic-type) 0) 'soap-sample-value
- 'soap-sample-value-for-basic-type)
+ (put (aref (make-soap-xs-basic-type) 0)
+ 'soap-sample-value
+ 'soap-sample-value-for-xs-basic-type)
- (put (aref (make-soap-simple-type) 0) 'soap-sample-value
- 'soap-sample-value-for-simple-type)
+ (put (aref (make-soap-xs-element) 0)
+ 'soap-sample-value
+ 'soap-sample-value-for-xs-element)
- (put (aref (make-soap-sequence-type) 0) 'soap-sample-value
- 'soap-sample-value-for-seqence-type)
+ (put (aref (make-soap-xs-attribute) 0)
+ 'soap-sample-value
+ 'soap-sample-value-for-xs-attribute)
- (put (aref (make-soap-array-type) 0) 'soap-sample-value
- 'soap-sample-value-for-array-type)
+ (put (aref (make-soap-xs-attribute) 0)
+ 'soap-sample-value
+ 'soap-sample-value-for-xs-attribute-group)
- (put (aref (make-soap-message) 0) 'soap-sample-value
- 'soap-sample-value-for-message) )
+ (put (aref (make-soap-xs-simple-type) 0)
+ 'soap-sample-value
+ 'soap-sample-value-for-xs-simple-type)
+
+ (put (aref (make-soap-xs-complex-type) 0)
+ 'soap-sample-value
+ 'soap-sample-value-for-xs-complex-type)
+
+ (put (aref (make-soap-message) 0)
+ 'soap-sample-value
+ 'soap-sample-value-for-message))
@@ -184,7 +252,7 @@ entire WSDL can be inspected."
(define-button-type 'soap-client-describe-link
- 'face 'italic
+ 'face 'link
'help-echo "mouse-2, RET: describe item"
'follow-link t
'action (lambda (button)
@@ -193,10 +261,10 @@ entire WSDL can be inspected."
'skip t)
(define-button-type 'soap-client-describe-back-link
- 'face 'italic
+ 'face 'link
'help-echo "mouse-2, RET: browse the previous item"
'follow-link t
- 'action (lambda (button)
+ 'action (lambda (_button)
(let ((item (pop soap-inspect-previous-items)))
(when item
(setq soap-inspect-current-item nil)
@@ -210,52 +278,142 @@ entire WSDL can be inspected."
'type 'soap-client-describe-link
'item element))
-(defun soap-inspect-basic-type (basic-type)
- "Insert information about BASIC-TYPE into the current buffer."
- (insert "Basic type: " (soap-element-fq-name basic-type))
- (insert "\nSample value\n")
- (pp (soap-sample-value basic-type) (current-buffer)))
-
-(defun soap-inspect-simple-type (simple-type)
- "Insert information about SIMPLE-TYPE into the current buffer"
- (insert "Simple type: " (soap-element-fq-name simple-type) "\n")
- (insert "Base: " (symbol-name (soap-basic-type-kind simple-type)) "\n")
- (let ((enumeration (soap-simple-type-enumeration simple-type)))
- (when (> (length enumeration) 1)
- (insert "Valid values: ")
- (dolist (e enumeration)
- (insert "\"" e "\" ")))))
-
-(defun soap-inspect-sequence-type (sequence)
- "Insert information about SEQUENCE into the current buffer."
- (insert "Sequence type: " (soap-element-fq-name sequence) "\n")
- (when (soap-sequence-type-parent sequence)
- (insert "Parent: ")
- (soap-insert-describe-button
- (soap-sequence-type-parent sequence))
- (insert "\n"))
- (insert "Elements: \n")
- (dolist (element (soap-sequence-type-elements sequence))
- (insert "\t" (symbol-name (soap-sequence-element-name element))
- "\t")
- (soap-insert-describe-button
- (soap-sequence-element-type element))
- (when (soap-sequence-element-multiple? element)
- (insert " multiple"))
- (when (soap-sequence-element-nillable? element)
- (insert " optional"))
- (insert "\n"))
- (insert "Sample value:\n")
- (pp (soap-sample-value sequence) (current-buffer)))
-
-(defun soap-inspect-array-type (array)
- "Insert information about the ARRAY into the current buffer."
- (insert "Array name: " (soap-element-fq-name array) "\n")
- (insert "Element type: ")
- (soap-insert-describe-button
- (soap-array-type-element-type array))
+(defun soap-inspect-xs-basic-type (type)
+ "Insert information about TYPE, a soap-xs-basic-type, in the current buffer."
+ (insert "Basic type: " (soap-element-fq-name type))
+ (insert "\nSample value:\n")
+ (pp (soap-sample-value type) (current-buffer)))
+
+(defun soap-inspect-xs-element (element)
+ "Insert information about ELEMENT, a soap-xs-element, in the current buffer."
+ (insert "Element: " (soap-element-fq-name element))
+ (insert "\nType: ")
+ (soap-insert-describe-button (soap-xs-element-type element))
+ (insert "\nAttributes:")
+ (when (soap-xs-element-optional? element)
+ (insert " optional"))
+ (when (soap-xs-element-multiple? element)
+ (insert " multiple"))
+ (insert "\nSample value:\n")
+ (pp (soap-sample-value element) (current-buffer)))
+
+(defun soap-inspect-xs-attribute (attribute)
+ "Insert information about ATTRIBUTE, a soap-xs-attribute, in
+the current buffer."
+ (insert "Attribute: " (soap-element-fq-name attribute))
+ (insert "\nType: ")
+ (soap-insert-describe-button (soap-xs-attribute-type attribute))
(insert "\nSample value:\n")
- (pp (soap-sample-value array) (current-buffer)))
+ (pp (soap-sample-value attribute) (current-buffer)))
+
+(defun soap-inspect-xs-attribute-group (attribute-group)
+ "Insert information about ATTRIBUTE-GROUP, a
+soap-xs-attribute-group, in the current buffer."
+ (insert "Attribute group: " (soap-element-fq-name attribute-group))
+ (insert "\nSample values:\n")
+ (pp (soap-sample-value attribute-group) (current-buffer)))
+
+(defun soap-inspect-xs-simple-type (type)
+ "Insert information about TYPE, a soap-xs-simple-type, in the current
buffer."
+ (insert "Simple type: " (soap-element-fq-name type))
+ (insert "\nBase: " )
+ (if (listp (soap-xs-simple-type-base type))
+ (let ((first-time t))
+ (dolist (b (soap-xs-simple-type-base type))
+ (unless first-time
+ (insert ", ")
+ (setq first-time nil))
+ (soap-insert-describe-button b)))
+ (soap-insert-describe-button (soap-xs-simple-type-base type)))
+ (insert "\nAttributes: ")
+ (dolist (attribute (soap-xs-simple-type-attributes type))
+ (let ((name (or (soap-xs-attribute-name attribute) "*inline*"))
+ (type (soap-xs-attribute-type attribute)))
+ (insert "\n\t")
+ (insert name)
+ (insert "\t")
+ (soap-insert-describe-button type)))
+ (when (soap-xs-simple-type-enumeration type)
+ (insert "\nEnumeraton values: ")
+ (dolist (e (soap-xs-simple-type-enumeration type))
+ (insert "\n\t")
+ (pp e)))
+ (when (soap-xs-simple-type-pattern type)
+ (insert "\nPattern: " (soap-xs-simple-type-pattern type)))
+ (when (car (soap-xs-simple-type-length-range type))
+ (insert "\nMin length: "
+ (number-to-string (car (soap-xs-simple-type-length-range type)))))
+ (when (cdr (soap-xs-simple-type-length-range type))
+ (insert "\nMin length: "
+ (number-to-string (cdr (soap-xs-simple-type-length-range type)))))
+ (when (car (soap-xs-simple-type-integer-range type))
+ (insert "\nMin value: "
+ (number-to-string (car (soap-xs-simple-type-integer-range type)))))
+ (when (cdr (soap-xs-simple-type-integer-range type))
+ (insert "\nMin value: "
+ (number-to-string (cdr (soap-xs-simple-type-integer-range type)))))
+ (insert "\nSample value:\n")
+ (pp (soap-sample-value type) (current-buffer)))
+
+(defun soap-inspect-xs-complex-type (type)
+ "Insert information about TYPE in the current buffer.
+TYPE is a `soap-xs-complex-type'"
+ (insert "Complex type: " (soap-element-fq-name type))
+ (insert "\nKind: ")
+ (case (soap-xs-complex-type-indicator type)
+ ((sequence all)
+ (insert "a sequence ")
+ (when (soap-xs-complex-type-base type)
+ (insert "extending ")
+ (soap-insert-describe-button (soap-xs-complex-type-base type)))
+ (insert "\nAttributes: ")
+ (dolist (attribute (soap-xs-complex-type-attributes type))
+ (let ((name (or (soap-xs-attribute-name attribute) "*inline*"))
+ (type (soap-xs-attribute-type attribute)))
+ (insert "\n\t")
+ (insert name)
+ (insert "\t")
+ (soap-insert-describe-button type)))
+ (insert "\nElements: ")
+ (let ((name-width 0)
+ (type-width 0))
+ (dolist (element (soap-xs-complex-type-elements type))
+ (let ((name (or (soap-xs-element-name element) "*inline*"))
+ (type (soap-xs-element-type element)))
+ (setq name-width (max name-width (length name)))
+ (setq type-width
+ (max type-width (length (soap-element-fq-name type))))))
+ (setq name-width (+ name-width 2))
+ (setq type-width (+ type-width 2))
+ (dolist (element (soap-xs-complex-type-elements type))
+ (let ((name (or (soap-xs-element-name element) "*inline*"))
+ (type (soap-xs-element-type element)))
+ (insert "\n\t")
+ (insert name)
+ (insert (make-string (- name-width (length name)) ?\ ))
+ (soap-insert-describe-button type)
+ (insert
+ (make-string
+ (- type-width (length (soap-element-fq-name type))) ?\ ))
+ (when (soap-xs-element-multiple? element)
+ (insert " multiple"))
+ (when (soap-xs-element-optional? element)
+ (insert " optional"))))))
+ (choice
+ (insert "a choice ")
+ (when (soap-xs-complex-type-base type)
+ (insert "extending ")
+ (soap-insert-describe-button (soap-xs-complex-type-base type)))
+ (insert "\nElements: ")
+ (dolist (element (soap-xs-complex-type-elements type))
+ (insert "\n\t")
+ (soap-insert-describe-button element)))
+ (array
+ (insert "an array of ")
+ (soap-insert-describe-button (soap-xs-complex-type-base type))))
+ (insert "\nSample value:\n")
+ (pp (soap-sample-value type) (current-buffer)))
+
(defun soap-inspect-message (message)
"Insert information about MESSAGE into the current buffer."
@@ -281,10 +439,11 @@ entire WSDL can be inspected."
(insert "\n\nSample invocation:\n")
(let ((sample-message-value
- (soap-sample-value (cdr (soap-operation-input operation))))
- (funcall (list 'soap-invoke '*WSDL* "SomeService" (soap-element-name
operation))))
+ (soap-sample-value (cdr (soap-operation-input operation))))
+ (funcall (list 'soap-invoke '*WSDL* "SomeService"
+ (soap-element-name operation))))
(let ((sample-invocation
- (append funcall (mapcar 'cdr sample-message-value))))
+ (append funcall (mapcar 'cdr sample-message-value))))
(pp sample-invocation (current-buffer)))))
(defun soap-inspect-port-type (port-type)
@@ -350,17 +509,23 @@ entire WSDL can be inspected."
(progn
;; Install the soap-inspect methods for our types
- (put (aref (make-soap-basic-type) 0) 'soap-inspect
- 'soap-inspect-basic-type)
+ (put (aref (make-soap-xs-basic-type) 0) 'soap-inspect
+ 'soap-inspect-xs-basic-type)
+
+ (put (aref (make-soap-xs-element) 0) 'soap-inspect
+ 'soap-inspect-xs-element)
+
+ (put (aref (make-soap-xs-simple-type) 0) 'soap-inspect
+ 'soap-inspect-xs-simple-type)
- (put (aref (make-soap-simple-type) 0) 'soap-inspect
- 'soap-inspect-simple-type)
+ (put (aref (make-soap-xs-complex-type) 0) 'soap-inspect
+ 'soap-inspect-xs-complex-type)
- (put (aref (make-soap-sequence-type) 0) 'soap-inspect
- 'soap-inspect-sequence-type)
+ (put (aref (make-soap-xs-attribute) 0) 'soap-inspect
+ 'soap-inspect-xs-attribute)
- (put (aref (make-soap-array-type) 0) 'soap-inspect
- 'soap-inspect-array-type)
+ (put (aref (make-soap-xs-attribute-group) 0) 'soap-inspect
+ 'soap-inspect-xs-attribute-group)
(put (aref (make-soap-message) 0) 'soap-inspect
'soap-inspect-message)
@@ -376,7 +541,7 @@ entire WSDL can be inspected."
(put (aref (make-soap-port) 0) 'soap-inspect
'soap-inspect-port)
- (put (aref (make-soap-wsdl) 0) 'soap-inspect
+ (put (aref (soap-make-wsdl "origin") 0) 'soap-inspect
'soap-inspect-wsdl))
(provide 'soap-inspect)
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] master 069a0e4: Sync with soap-client repository, version 3.0.0,
Thomas Fitzsimmons <=