;;; Code:
-(eval-when-compile (require 'cl))
(require 'cl-lib)
(require 'xml)
;; An element in an XML namespace, "things" stored in soap-xml-namespaces will
;; be derived from this object.
-(defstruct soap-element
+(cl-defstruct soap-element
name
;; The "well-known" namespace tag for the element. For example, while
;; parsing XML documents, we can have different tags for the XMLSchema
;; a namespace link stores an alias for an object in once namespace to a
;; "target" object possibly in a different namespace
-(defstruct (soap-namespace-link (:include soap-element))
+(cl-defstruct (soap-namespace-link (:include soap-element))
target)
;; A namespace is a collection of soap-element objects under a name (the name
;; of the namespace).
-(defstruct soap-namespace
+(cl-defstruct soap-namespace
(name nil :read-only t) ; e.g "http://xml.apache.org/xml-soap"
(elements (make-hash-table :test 'equal) :read-only t))
(setq name target))))))
;; by now, name should be valid
- (assert (and name (not (equal name "")))
- nil
- "Cannot determine name for namespace link")
+ (cl-assert (and name (not (equal name "")))
+ nil
+ "Cannot determine name for namespace link")
(push (make-soap-namespace-link :name name :target target)
(gethash name (soap-namespace-elements ns))))
DISCRIMINANT-PREDICATE is used to pick one of them. This allows
storing elements of different types (like a message type and a
binding) but the same name."
- (assert (stringp name))
+ (cl-assert (stringp name))
(let ((elements (gethash name (soap-namespace-elements ns))))
(cond (discriminant-predicate
(catch 'found
;; message exchange. We include here an XML schema model with a parser and
;; serializer/deserializer.
-(defstruct (soap-xs-type (:include soap-element))
+(cl-defstruct (soap-xs-type (:include soap-element))
id
attributes
attribute-groups)
;;;;; soap-xs-basic-type
-(defstruct (soap-xs-basic-type (:include soap-xs-type))
+(cl-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')
(when (or value (eq kind 'boolean))
(let ((value-string
- (case kind
+ (cl-case kind
((string anyURI QName ID IDREF language)
(unless (stringp value)
(error "Not a string value: %s" value))
;; string format in UTC.
(format-time-string
(concat
- (ecase kind
+ (cl-ecase kind
(dateTime "%Y-%m-%dT%H:%M:%S")
(time "%H:%M:%S")
(date "%Y-%m-%d")
(if (null contents)
nil
- (ecase kind
+ (cl-ecase kind
((string anyURI QName ID IDREF language) (car contents))
((dateTime time date gYearMonth gYear gMonthDay gDay gMonth)
(car contents))
;;;;; soap-xs-element
-(defstruct (soap-xs-element (:include soap-element))
+(cl-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?
(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)
+ (cl-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)))
(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))
+ (cl-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"))))
;;;;; soap-xs-attribute
-(defstruct (soap-xs-attribute (:include soap-element))
+(cl-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))
+(cl-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)))
+ (cl-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))
(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)
+ (cl-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))
(unless (stringp child)
;; Ignore optional annotation.
;; Ignore anyAttribute nodes.
- (case (soap-l2wk (xml-node-name child))
+ (cl-case (soap-l2wk (xml-node-name child))
(xsd:attribute
(push (soap-xs-parse-attribute child)
(soap-xs-type-attributes attribute-group)))
;;;;; soap-xs-simple-type
-(defstruct (soap-xs-simple-type (:include soap-xs-type))
+(cl-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
(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)))
+ (cl-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.
: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))
+ (cl-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))
(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)))
+ (cl-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))
+ (cl-case (soap-l2wk (xml-node-name r))
(xsd:enumeration
(push value (soap-xs-simple-type-enumeration type)))
(xsd:pattern
(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)))
+ (cl-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
(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)))
+ (cl-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
(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
+ (cl-case kind
((anyType Array byte[])
value)
(t
;;;;; soap-xs-complex-type
-(defstruct (soap-xs-complex-type (:include soap-xs-type))
+(cl-defstruct (soap-xs-complex-type (:include soap-xs-type))
indicator ; sequence, choice, all, array
base
elements
type
attributes
attribute-groups)
- (assert (memq node-name '(xsd:complexType xsd:complexContent xsd:group))
- nil "unexpected node: %s" node-name)
+ (cl-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))
+ (cl-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)
(xsd:complexContent
(dolist (def (xml-node-children def))
(when (consp def)
- (case (soap-l2wk (xml-node-name def))
+ (cl-case (soap-l2wk (xml-node-name def))
(xsd:attribute
(push (soap-xs-parse-attribute def) attributes))
(xsd:attributeGroup
(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)))
+ (cl-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))
+ (cl-ecase (soap-l2wk (xml-node-name node))
(xsd:sequence 'sequence)
(xsd:all 'all)
(xsd:choice 'choice)))
(dolist (r (xml-node-children node))
(unless (stringp r) ; skip the white space
- (case (soap-l2wk (xml-node-name r))
+ (cl-case (soap-l2wk (xml-node-name r))
((xsd:element xsd:group)
(push (soap-xs-parse-element r)
(soap-xs-complex-type-elements 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)))
+ (cl-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
(dolist (def (xml-node-children node))
(when (consp def) ; skip text nodes
- (case (soap-l2wk (xml-node-name def))
+ (cl-case (soap-l2wk (xml-node-name def))
((xsd:sequence xsd:choice xsd:all)
(setq type (soap-xs-parse-sequence def)))
(xsd:attribute
This is a specialization of `soap-encode-value' for
`soap-xs-complex-type' objects."
- (case (soap-xs-complex-type-indicator type)
+ (cl-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 ((e-name (intern e-name)))
(dolist (v value)
(when (equal (car v) e-name)
- (incf instance-count)
+ (cl-incf instance-count)
(soap-encode-value (cdr v) candidate))))
(if (soap-xs-complex-type-indicator type)
(let ((current-point (point)))
;; characters were inserted in the buffer.
(soap-encode-value value candidate)
(when (not (equal current-point (point)))
- (incf instance-count)))
+ (cl-incf instance-count)))
(dolist (v value)
(let ((current-point (point)))
(soap-encode-value v candidate)
(when (not (equal current-point (point)))
- (incf instance-count))))))))
+ (cl-incf instance-count))))))))
;; Do some sanity checking
(let* ((indicator (soap-xs-complex-type-indicator type))
(element-type (soap-xs-element-type element))
This is a specialization of `soap-decode-type' for
`soap-xs-basic-type' objects."
- (case (soap-xs-complex-type-indicator type)
+ (cl-case (soap-xs-complex-type-indicator type)
(array
(let ((result nil)
(element-type (soap-xs-complex-type-base type)))
(list node)))
(element-type (soap-xs-element-type element)))
(dolist (node children)
- (incf instance-count)
+ (cl-incf instance-count)
(let* ((attributes
(soap-decode-xs-attributes element-type node))
;; Attributes may specify xsi:type override.
;;;;; WSDL document elements
-(defstruct (soap-message (:include soap-element))
+(cl-defstruct (soap-message (:include soap-element))
parts ; ALIST of NAME => WSDL-TYPE name
)
-(defstruct (soap-operation (:include soap-element))
+(cl-defstruct (soap-operation (:include soap-element))
parameter-order
input ; (NAME . MESSAGE)
output ; (NAME . MESSAGE)
input-action ; WS-addressing action string
output-action) ; WS-addressing action string
-(defstruct (soap-port-type (:include soap-element))
+(cl-defstruct (soap-port-type (:include soap-element))
operations) ; a namespace of operations
;; A bound operation is an operation which has a soap action and a use
;; method attached -- these are attached as part of a binding and we
;; can have different bindings for the same operations.
-(defstruct soap-bound-operation
+(cl-defstruct soap-bound-operation
operation ; SOAP-OPERATION
soap-action ; value for SOAPAction HTTP header
soap-headers ; list of (message part use)
; http://www.w3.org/TR/wsdl#_soap:body
)
-(defstruct (soap-binding (:include soap-element))
+(cl-defstruct (soap-binding (:include soap-element))
port-type
(operations (make-hash-table :test 'equal) :readonly t))
-(defstruct (soap-port (:include soap-element))
+(cl-defstruct (soap-port (:include soap-element))
service-url
binding)
;;;;; The WSDL document
;; The WSDL data structure used for encoding/decoding SOAP messages
-(defstruct (soap-wsdl
- ;; NOTE: don't call this constructor, see `soap-make-wsdl'
- (:constructor soap-make-wsdl^)
- (:copier soap-copy-wsdl))
+(cl-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
"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)))
+ (cl-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))
+ (cl-case (soap-l2wk (xml-node-name def))
(xsd:import
;; Imports will be processed later
;; NOTE: we should expand the location now!
(message (cdr input)))
;; Name this part if it was not named
(when (or (null name) (equal name ""))
- (setq name (format "in%d" (incf counter))))
+ (setq name (format "in%d" (cl-incf counter))))
(when (soap-name-p message)
(setf (soap-operation-input operation)
(cons (intern name)
(let ((name (car output))
(message (cdr output)))
(when (or (null name) (equal name ""))
- (setq name (format "out%d" (incf counter))))
+ (setq name (format "out%d" (cl-incf counter))))
(when (soap-name-p message)
(setf (soap-operation-output operation)
(cons (intern name)
(let ((name (car fault))
(message (cdr fault)))
(when (or (null name) (equal name ""))
- (setq name (format "fault%d" (incf counter))))
+ (setq name (format "fault%d" (cl-incf counter))))
(if (soap-name-p message)
(push (cons (intern name)
(soap-wsdl-get message wsdl 'soap-message-p))
;; If this namespace does not have an alias, create one for it.
(catch 'done
(while t
- (setq nstag (format "ns%d" (incf nstag-id)))
+ (setq nstag (format "ns%d" (cl-incf nstag-id)))
(unless (assoc nstag alias-table)
(soap-wsdl-add-alias nstag (soap-namespace-name ns) wsdl)
(throw 'done t)))))
(maphash (lambda (_name element)
(cond ((soap-element-p element) ; skip links
- (incf nprocessed)
+ (cl-incf nprocessed)
(soap-resolve-references element wsdl))
((listp element)
(dolist (e element)
(when (soap-element-p e)
- (incf nprocessed)
+ (cl-incf nprocessed)
(soap-resolve-references e wsdl))))))
(soap-namespace-elements ns)))))
wsdl)
"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))))
+ (cl-assert (eq node-name 'wsdl:definitions)
+ nil
+ "expecting wsdl:definitions node, got %s" node-name))))
(defun soap-parse-wsdl-phase-fetch-imports (node wsdl)
"Fetch and load files imported by NODE into 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
- "expecting wsdl:message node, got %s"
- (soap-l2wk (xml-node-name node)))
+ (cl-assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:message)
+ nil
+ "expecting wsdl:message node, got %s"
+ (soap-l2wk (xml-node-name node)))
(let ((name (xml-get-attribute-or-nil node 'name))
parts)
(dolist (p (soap-xml-get-children1 node 'wsdl:part))
(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
- "expecting wsdl:portType node got %s"
- (soap-l2wk (xml-node-name node)))
+ (cl-assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:portType)
+ nil
+ "expecting wsdl:portType node got %s"
+ (soap-l2wk (xml-node-name node)))
(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))
;; link all messages from this namespace, as this namespace
;; will be used for decoding the response.
- (destructuring-bind (name . message) (soap-operation-input o)
+ (cl-destructuring-bind (name . message) (soap-operation-input o)
(soap-namespace-put-link name message ns))
- (destructuring-bind (name . message) (soap-operation-output o)
+ (cl-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
+ (cl-destructuring-bind (name . message) fault
(soap-namespace-put-link name message 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
- "expecting wsdl:operation node, got %s"
- (soap-l2wk (xml-node-name node)))
+ (cl-assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:operation)
+ nil
+ "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)))
(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
- "expecting wsdl:binding node, got %s"
- (soap-l2wk (xml-node-name node)))
+ (cl-assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:binding)
+ nil
+ "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
(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))
+ (cl-assert decoder nil
+ "no soap-decoder for %s type" (aref type 0))
(funcall decoder type node))))))))))
(defun soap-decode-any-type (node)
OPERATION is the WSDL operation for which we expect the response,
WSDL is used to decode the NODE"
(soap-with-local-xmlns node
- (assert (eq (soap-l2wk (xml-node-name node)) 'soap:Envelope)
- nil
- "expecting soap:Envelope node, got %s"
- (soap-l2wk (xml-node-name node)))
+ (cl-assert (eq (soap-l2wk (xml-node-name node)) 'soap:Envelope)
+ nil
+ "expecting soap:Envelope node, got %s"
+ (soap-l2wk (xml-node-name node)))
(let ((headers (soap-xml-get-children1 node 'soap:Header))
(body (car (soap-xml-get-children1 node 'soap:Body))))
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))
+ (cl-assert attribute-encoder nil
+ "no soap-attribute-encoder for %s type" (aref type 0))
(funcall attribute-encoder value type)))
(defun soap-encode-value (value type)
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))
+ (cl-assert encoder nil "no soap-encoder for %s type" (aref type 0))
(funcall encoder value type))
(when (soap-element-namespace-tag type)
(add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag type))))
(use (soap-bound-operation-use operation))
(message (cdr (soap-operation-input op)))
(parameter-order (soap-operation-parameter-order op))
- (param-table (loop for formal in parameter-order
- for value in parameters
- collect (cons formal value))))
+ (param-table (cl-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"
(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)))
+ (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)))))))))
+ (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.
\f
;;; Code:
-(eval-when-compile (require 'cl))
-
+(require 'cl-lib)
(require 'soap-client)
;;; sample-value
(let ((sample-value (get (aref type 0) 'soap-sample-value)))
(if sample-value
(funcall sample-value type)
- (error "Cannot provide sample value for type %s" (aref type 0)))))
+ (error "Cannot provide sample value for type %s" (aref type 0)))))
(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)
+ (cl-case (soap-xs-basic-type-kind type)
(string "a string")
(anyURI "an URI")
(QName "a QName")
(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))))
+ (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.
((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)
+ (cl-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")))))
+ ((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)
+ (cl-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)))))
+ ((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))))
(append
(mapcar 'soap-sample-value-for-xs-attribute
(soap-xs-type-attributes type))
- (case (soap-xs-complex-type-indicator type)
+ (cl-case (soap-xs-complex-type-indicator type)
(array
(let* ((element-type (soap-xs-complex-type-base type))
(sample1 (soap-sample-value element-type))
(define-button-type 'soap-client-describe-link
- 'face 'link
- 'help-echo "mouse-2, RET: describe item"
- 'follow-link t
- 'action (lambda (button)
- (let ((item (button-get button 'item)))
- (soap-inspect item)))
- 'skip t)
+ 'face 'link
+ 'help-echo "mouse-2, RET: describe item"
+ 'follow-link t
+ 'action (lambda (button)
+ (let ((item (button-get button 'item)))
+ (soap-inspect item)))
+ 'skip t)
(define-button-type 'soap-client-describe-back-link
- 'face 'link
- 'help-echo "mouse-2, RET: browse the previous item"
- 'follow-link t
- 'action (lambda (_button)
- (let ((item (pop soap-inspect-previous-items)))
- (when item
- (setq soap-inspect-current-item nil)
- (soap-inspect item))))
- 'skip t)
+ 'face 'link
+ 'help-echo "mouse-2, RET: browse the previous item"
+ 'follow-link t
+ 'action (lambda (_button)
+ (let ((item (pop soap-inspect-previous-items)))
+ (when item
+ (setq soap-inspect-current-item nil)
+ (soap-inspect item))))
+ 'skip t)
(defun soap-insert-describe-button (element)
"Insert a button to inspect ELEMENT when pressed."
(insert ", ")
(setq first-time nil))
(soap-insert-describe-button b)))
- (soap-insert-describe-button (soap-xs-simple-type-base type)))
+ (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 is a `soap-xs-complex-type'"
(insert "Complex type: " (soap-element-fq-name type))
(insert "\nKind: ")
- (case (soap-xs-complex-type-indicator type)
+ (cl-case (soap-xs-complex-type-indicator type)
((sequence all)
(insert "a sequence ")
(when (soap-xs-complex-type-base 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"))))))
+ (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 information about PORT-TYPE into the current buffer."
(insert "Port-type name: " (soap-element-fq-name port-type) "\n")
(insert "Operations:\n")
- (loop for o being the hash-values of
- (soap-namespace-elements (soap-port-type-operations port-type))
- do (progn
- (insert "\t")
- (soap-insert-describe-button (car o)))))
+ (cl-loop for o being the hash-values of
+ (soap-namespace-elements (soap-port-type-operations port-type))
+ do (progn
+ (insert "\t")
+ (soap-insert-describe-button (car o)))))
(defun soap-inspect-binding (binding)
"Insert information about BINDING into the current buffer."
(insert "\n")
(insert "Bound operations:\n")
(let* ((ophash (soap-binding-operations binding))
- (operations (loop for o being the hash-keys of ophash
- collect o))
+ (operations (cl-loop for o being the hash-keys of ophash
+ collect o))
op-name-width)
(setq operations (sort operations 'string<))
- (setq op-name-width (loop for o in operations maximizing (length o)))
+ (setq op-name-width (cl-loop for o in operations maximizing (length o)))
(dolist (op operations)
(let* ((bound-op (gethash op ophash))
projects / emacs.git / commitdiff