+(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-labels ((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 "Arrays of type soap-encode-xs-complex-type 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
+
+