commit 0afbc5b2a2cda9fe12246bf62567162ae2577160 (HEAD, refs/remotes/origin/master) Author: Paul Eggert Date: Sun Oct 25 00:29:42 2015 -0700 Revert commit that broke 'make bootstrap' * lisp/custom.el (custom-declare-variable): Revert commit 79fac080d277fed07b3c192890ad59d36d9f83b6. custom.el needs to work even when pcase has not been defined yet, when doing bootstrapping. diff --git a/lisp/custom.el b/lisp/custom.el index cc284ef..c5d0e65 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -155,29 +155,40 @@ set to nil, as the value is no longer rogue." (unless (memq :group args) (custom-add-to-group (custom-current-group) symbol 'custom-variable)) (while args - (let ((keyword (pop args))) - (unless (symbolp keyword) - (error "Junk in args %S" (cons keyword args))) - (unless args - (error "Keyword %s is missing an argument" keyword)) - (let ((value (pop args))) - (pcase keyword - (`:initialize (setq initialize value)) - (`:set (put symbol 'custom-set value)) - (`:get (put symbol 'custom-get value)) - (`:require (push value requests)) - (`:risky (put symbol 'risky-local-variable value)) - (`:safe (put symbol 'safe-local-variable value)) - (`:type (put symbol 'custom-type (purecopy value))) - (`:options (if (get symbol 'custom-options) - ;; Slow safe code to avoid duplicates. - (mapc (lambda (option) - (custom-add-option symbol option)) - value) - ;; Fast code for the common case. - (put symbol 'custom-options (copy-sequence value)))) - (_ (custom-handle-keyword symbol keyword value - 'custom-variable)))))) + (let ((arg (car args))) + (setq args (cdr args)) + (unless (symbolp arg) + (error "Junk in args %S" args)) + (let ((keyword arg) + (value (car args))) + (unless args + (error "Keyword %s is missing an argument" keyword)) + (setq args (cdr args)) + (cond ((eq keyword :initialize) + (setq initialize value)) + ((eq keyword :set) + (put symbol 'custom-set value)) + ((eq keyword :get) + (put symbol 'custom-get value)) + ((eq keyword :require) + (push value requests)) + ((eq keyword :risky) + (put symbol 'risky-local-variable value)) + ((eq keyword :safe) + (put symbol 'safe-local-variable value)) + ((eq keyword :type) + (put symbol 'custom-type (purecopy value))) + ((eq keyword :options) + (if (get symbol 'custom-options) + ;; Slow safe code to avoid duplicates. + (mapc (lambda (option) + (custom-add-option symbol option)) + value) + ;; Fast code for the common case. + (put symbol 'custom-options (copy-sequence value)))) + (t + (custom-handle-keyword symbol keyword value + 'custom-variable)))))) (put symbol 'custom-requests requests) ;; Do the actual initialization. (unless custom-dont-initialize commit d8589ad4e3cf2ed6759836f28081d96748360915 Author: Paul Eggert Date: Sat Oct 24 23:51:19 2015 -0700 Port recent inline functions fix to Standard C * src/lisp.h (LISP_MACRO_DEFUN, LISP_MACRO_DEFUN_VOID): Remove. All uses rewritten to define the function directly rather than to use a macro to define the function. This conforms to Standard C, which does not allow stray semicolons at the top level. I hope it also avoids the problems with TAGS. Those macros, though clever, were pretty confusing anyway, and it wasn’t clear they were worth the aggravation even without the TAGS problem. diff --git a/src/lisp.h b/src/lisp.h index e2b7b67..a1409d1 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -258,7 +258,7 @@ enum Lisp_Bits /* The maximum value that can be stored in a EMACS_INT, assuming all bits other than the type bits contribute to a nonnegative signed value. - This can be used in #if, e.g., '#if USB_TAG' below expands to an + This can be used in #if, e.g., '#if USE_LSB_TAG' below expands to an expression involving VAL_MAX. */ #define VAL_MAX (EMACS_INT_MAX >> (GCTYPEBITS - 1)) @@ -301,10 +301,6 @@ error !; and/or via a function definition like this: - LISP_MACRO_DEFUN (OP, Lisp_Object, (Lisp_Object x), (x)) - - which macro-expands to this: - Lisp_Object (OP) (Lisp_Object x) { return lisp_h_OP (x); } without worrying about the implementations diverging, since @@ -318,15 +314,7 @@ error !; Bug#11935. Commentary for these macros can be found near their corresponding - functions, below. - - Note: Each use of LISP_MACRO_DEFUN should have a semi-colon ; at - its end, although the expansion of that macro doesn't require that. - That's because any inline function defined immediately after the - use of that macro will otherwise be missed by 'etags' (because - 'etags' works on un-preprocessed source, and treats the invocation - of LISP_MACRO_DEFUN as some kind of data type), and will not end up - in TAGS. */ + functions, below. */ #if CHECK_LISP_OBJECT_TYPE # define lisp_h_XLI(o) ((o).i) @@ -416,17 +404,6 @@ error !; # endif #endif -/* Define NAME as a lisp.h inline function that returns TYPE and has - arguments declared as ARGDECLS and passed as ARGS. ARGDECLS and - ARGS should be parenthesized. Implement the function by calling - lisp_h_NAME ARGS. */ -#define LISP_MACRO_DEFUN(name, type, argdecls, args) \ - INLINE type (name) argdecls { return lisp_h_##name args; } - -/* like LISP_MACRO_DEFUN, except NAME returns void. */ -#define LISP_MACRO_DEFUN_VOID(name, argdecls, args) \ - INLINE void (name) argdecls { lisp_h_##name args; } - /* Define the fundamental Lisp data structures. */ @@ -759,8 +736,18 @@ struct Lisp_Symbol /* Convert a Lisp_Object to the corresponding EMACS_INT and vice versa. At the machine level, these operations are no-ops. */ -LISP_MACRO_DEFUN (XLI, EMACS_INT, (Lisp_Object o), (o)); -LISP_MACRO_DEFUN (XIL, Lisp_Object, (EMACS_INT i), (i)); + +INLINE EMACS_INT +(XLI) (Lisp_Object o) +{ + return lisp_h_XLI (o); +} + +INLINE Lisp_Object +(XIL) (EMACS_INT i) +{ + return lisp_h_XIL (i); +} /* In the size word of a vector, this bit means the vector has been marked. */ @@ -836,12 +823,41 @@ DEFINE_GDB_SYMBOL_END (VALMASK) #if USE_LSB_TAG -LISP_MACRO_DEFUN (make_number, Lisp_Object, (EMACS_INT n), (n)); -LISP_MACRO_DEFUN (XINT, EMACS_INT, (Lisp_Object a), (a)); -LISP_MACRO_DEFUN (XFASTINT, EMACS_INT, (Lisp_Object a), (a)); -LISP_MACRO_DEFUN (XSYMBOL, struct Lisp_Symbol *, (Lisp_Object a), (a)); -LISP_MACRO_DEFUN (XTYPE, enum Lisp_Type, (Lisp_Object a), (a)); -LISP_MACRO_DEFUN (XUNTAG, void *, (Lisp_Object a, int type), (a, type)); +INLINE Lisp_Object +(make_number) (EMACS_INT n) +{ + return lisp_h_make_number (n); +} + +INLINE EMACS_INT +(XINT) (Lisp_Object a) +{ + return lisp_h_XINT (a); +} + +INLINE EMACS_INT +(XFASTINT) (Lisp_Object a) +{ + return lisp_h_XFASTINT (a); +} + +INLINE struct Lisp_Symbol * +(XSYMBOL) (Lisp_Object a) +{ + return lisp_h_XSYMBOL (a); +} + +INLINE enum Lisp_Type +(XTYPE) (Lisp_Object a) +{ + return lisp_h_XTYPE (a); +} + +INLINE void * +(XUNTAG) (Lisp_Object a, int type) +{ + return lisp_h_XUNTAG (a, type); +} #else /* ! USE_LSB_TAG */ @@ -932,7 +948,12 @@ XUINT (Lisp_Object a) /* Return A's (Lisp-integer sized) hash. Happens to be like XUINT right now, but XUINT should only be applied to objects we know are integers. */ -LISP_MACRO_DEFUN (XHASH, EMACS_INT, (Lisp_Object a), (a)); + +INLINE EMACS_INT +(XHASH) (Lisp_Object a) +{ + return lisp_h_XHASH (a); +} /* Like make_number (N), but may be faster. N must be in nonnegative range. */ INLINE Lisp_Object @@ -944,7 +965,12 @@ make_natnum (EMACS_INT n) } /* Return true if X and Y are the same object. */ -LISP_MACRO_DEFUN (EQ, bool, (Lisp_Object x, Lisp_Object y), (x, y)); + +INLINE bool +(EQ) (Lisp_Object x, Lisp_Object y) +{ + return lisp_h_EQ (x, y); +} /* Value is true if I doesn't fit into a Lisp fixnum. It is written this way so that it also works if I is of unsigned @@ -962,7 +988,11 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper) /* Extract a value or address from a Lisp_Object. */ -LISP_MACRO_DEFUN (XCONS, struct Lisp_Cons *, (Lisp_Object a), (a)); +INLINE struct Lisp_Cons * +(XCONS) (Lisp_Object a) +{ + return lisp_h_XCONS (a); +} INLINE struct Lisp_Vector * XVECTOR (Lisp_Object a) @@ -1135,9 +1165,11 @@ make_pointer_integer (void *p) /* Type checking. */ -LISP_MACRO_DEFUN_VOID (CHECK_TYPE, - (int ok, Lisp_Object predicate, Lisp_Object x), - (ok, predicate, x)); +INLINE void +(CHECK_TYPE) (int ok, Lisp_Object predicate, Lisp_Object x) +{ + lisp_h_CHECK_TYPE (ok, predicate, x); +} /* See the macros in intervals.h. */ @@ -1177,8 +1209,18 @@ xcdr_addr (Lisp_Object c) } /* Use these from normal code. */ -LISP_MACRO_DEFUN (XCAR, Lisp_Object, (Lisp_Object c), (c)); -LISP_MACRO_DEFUN (XCDR, Lisp_Object, (Lisp_Object c), (c)); + +INLINE Lisp_Object +(XCAR) (Lisp_Object c) +{ + return lisp_h_XCAR (c); +} + +INLINE Lisp_Object +(XCDR) (Lisp_Object c) +{ + return lisp_h_XCDR (c); +} /* Use these to set the fields of a cons cell. @@ -1715,7 +1757,11 @@ verify (offsetof (struct Lisp_Sub_Char_Table, contents) /* Value is name of symbol. */ -LISP_MACRO_DEFUN (SYMBOL_VAL, Lisp_Object, (struct Lisp_Symbol *sym), (sym)); +INLINE Lisp_Object +(SYMBOL_VAL) (struct Lisp_Symbol *sym) +{ + return lisp_h_SYMBOL_VAL (sym); +} INLINE struct Lisp_Symbol * SYMBOL_ALIAS (struct Lisp_Symbol *sym) @@ -1736,8 +1782,11 @@ SYMBOL_FWD (struct Lisp_Symbol *sym) return sym->val.fwd; } -LISP_MACRO_DEFUN_VOID (SET_SYMBOL_VAL, - (struct Lisp_Symbol *sym, Lisp_Object v), (sym, v)); +INLINE void +(SET_SYMBOL_VAL) (struct Lisp_Symbol *sym, Lisp_Object v) +{ + lisp_h_SET_SYMBOL_VAL (sym, v); +} INLINE void SET_SYMBOL_ALIAS (struct Lisp_Symbol *sym, struct Lisp_Symbol *v) @@ -1784,7 +1833,11 @@ SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (Lisp_Object sym) value cannot be changed (there is an exception for keyword symbols, whose value can be set to the keyword symbol itself). */ -LISP_MACRO_DEFUN (SYMBOL_CONSTANT_P, int, (Lisp_Object sym), (sym)); +INLINE int +(SYMBOL_CONSTANT_P) (Lisp_Object sym) +{ + return lisp_h_SYMBOL_CONSTANT_P (sym); +} /* Placeholder for make-docfile to process. The actual symbol definition is done by lread.c's defsym. */ @@ -2454,7 +2507,11 @@ enum char_bits /* Data type checking. */ -LISP_MACRO_DEFUN (NILP, bool, (Lisp_Object x), (x)); +INLINE bool +(NILP) (Lisp_Object x) +{ + return lisp_h_NILP (x); +} INLINE bool NUMBERP (Lisp_Object x) @@ -2478,13 +2535,41 @@ RANGED_INTEGERP (intmax_t lo, Lisp_Object x, intmax_t hi) && (TYPE_SIGNED (type) ? TYPE_MINIMUM (type) <= XINT (x) : 0 <= XINT (x)) \ && XINT (x) <= TYPE_MAXIMUM (type)) -LISP_MACRO_DEFUN (CONSP, bool, (Lisp_Object x), (x)); -LISP_MACRO_DEFUN (FLOATP, bool, (Lisp_Object x), (x)); -LISP_MACRO_DEFUN (MISCP, bool, (Lisp_Object x), (x)); -LISP_MACRO_DEFUN (SYMBOLP, bool, (Lisp_Object x), (x)); -LISP_MACRO_DEFUN (INTEGERP, bool, (Lisp_Object x), (x)); -LISP_MACRO_DEFUN (VECTORLIKEP, bool, (Lisp_Object x), (x)); -LISP_MACRO_DEFUN (MARKERP, bool, (Lisp_Object x), (x)); +INLINE bool +(CONSP) (Lisp_Object x) +{ + return lisp_h_CONSP (x); +} +INLINE bool +(FLOATP) (Lisp_Object x) +{ + return lisp_h_FLOATP (x); +} +INLINE bool +(MISCP) (Lisp_Object x) +{ + return lisp_h_MISCP (x); +} +INLINE bool +(SYMBOLP) (Lisp_Object x) +{ + return lisp_h_SYMBOLP (x); +} +INLINE bool +(INTEGERP) (Lisp_Object x) +{ + return lisp_h_INTEGERP (x); +} +INLINE bool +(VECTORLIKEP) (Lisp_Object x) +{ + return lisp_h_VECTORLIKEP (x); +} +INLINE bool +(MARKERP) (Lisp_Object x) +{ + return lisp_h_MARKERP (x); +} INLINE bool STRINGP (Lisp_Object x) @@ -2635,9 +2720,23 @@ CHECK_LIST (Lisp_Object x) CHECK_TYPE (CONSP (x) || NILP (x), Qlistp, x); } -LISP_MACRO_DEFUN_VOID (CHECK_LIST_CONS, (Lisp_Object x, Lisp_Object y), (x, y)); -LISP_MACRO_DEFUN_VOID (CHECK_SYMBOL, (Lisp_Object x), (x)); -LISP_MACRO_DEFUN_VOID (CHECK_NUMBER, (Lisp_Object x), (x)); +INLINE void +(CHECK_LIST_CONS) (Lisp_Object x, Lisp_Object y) +{ + lisp_h_CHECK_LIST_CONS (x, y); +} + +INLINE void +(CHECK_SYMBOL) (Lisp_Object x) +{ + lisp_h_CHECK_SYMBOL (x); +} + +INLINE void +(CHECK_NUMBER) (Lisp_Object x) +{ + lisp_h_CHECK_NUMBER (x); +} INLINE void CHECK_STRING (Lisp_Object x) commit 816f78c2e8ec67a1e8c91ad2e9b0b8628e5584bf Author: Artur Malabarba Date: Sun Oct 25 01:52:01 2015 +0100 * lisp/isearch.el: Make character-fold search the default again diff --git a/lisp/isearch.el b/lisp/isearch.el index 2c031aa..3f8ff7a 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -220,7 +220,9 @@ It is nil if none yet.") Default value, nil, means edit the string instead." :type 'boolean) -(defcustom search-default-regexp-mode nil +(autoload 'character-fold-to-regexp "character-fold") + +(defcustom search-default-regexp-mode #'character-fold-to-regexp "Default mode to use when starting isearch. Value is nil, t, or a function. @@ -842,8 +844,6 @@ See the command `isearch-forward-symbol' for more information." ;; isearch-forward-regexp isearch-backward-regexp) ;; "List of commands for which isearch-mode does not recursive-edit.") -(autoload 'character-fold-to-regexp "character-fold") - (defun isearch-mode (forward &optional regexp op-fun recursive-edit regexp-function) "Start Isearch minor mode. It is called by the function `isearch-forward' and other related functions. commit f5f18f95d459a4031eda4b7f43a151e12a386338 Author: Artur Malabarba Date: Sun Oct 25 01:43:23 2015 +0100 * lisp/character-fold.el: Many improvements (character-fold-search-forward, character-fold-search-backward): New command (character-fold-to-regexp): Remove lax-whitespace hack. (character-fold-search): Remove variable. Only isearch and query-replace use char-folding, and they both have their own variables to configure that. diff --git a/lisp/character-fold.el b/lisp/character-fold.el index 988a506..6b242f4 100644 --- a/lisp/character-fold.el +++ b/lisp/character-fold.el @@ -23,14 +23,6 @@ ;;; Code: -;;;###autoload -(defvar character-fold-search nil - "Non-nil if searches should fold similar characters. -This means some characters will match entire groups of characters. -For instance, \" will match all variants of double quotes, and -the letter a will match all of its accented versions (and then -some).") - (defconst character-fold-table (eval-when-compile (let* ((equiv (make-char-table 'character-fold-table)) @@ -110,21 +102,32 @@ some).") "Used for folding characters of the same group during search.") ;;;###autoload -(defun character-fold-to-regexp (string &optional lax) +(defun character-fold-to-regexp (string &optional _lax) "Return a regexp matching anything that character-folds into STRING. -If `character-fold-search' is nil, `regexp-quote' string. -Otherwise, any character in STRING that has an entry in +Any character in STRING that has an entry in `character-fold-table' is replaced with that entry (which is a -regexp) and other characters are `regexp-quote'd. -If LAX is non-nil, any single whitespace character is allowed to -match any number of times." - (if character-fold-search - (apply #'concat - (mapcar (lambda (c) (if (and lax (memq c '(?\s ?\t ?\r ?\n))) - "[ \t\n\r\xa0\x2002\x2d\x200a\x202f\x205f\x3000]+" - (or (aref character-fold-table c) - (regexp-quote (string c))))) - string)) - (regexp-quote string))) +regexp) and other characters are `regexp-quote'd." + (apply #'concat + (mapcar (lambda (c) (or (aref character-fold-table c) + (regexp-quote (string c)))) + string))) + + +;;; Commands provided for completeness. +(defun character-fold-search-forward (string &optional bound noerror count) + "Search forward for a character-folded version of STRING. +STRING is converted to a regexp with `character-fold-to-regexp', +which is searched for with `re-search-forward'. +BOUND NOERROR COUNT are passed to `re-search-forward'." + (interactive "sSearch: ") + (re-search-forward (character-fold-to-regexp string) bound noerror count)) + +(defun character-fold-search-backward (string &optional bound noerror count) + "Search backward for a character-folded version of STRING. +STRING is converted to a regexp with `character-fold-to-regexp', +which is searched for with `re-search-backward'. +BOUND NOERROR COUNT are passed to `re-search-backward'." + (interactive "sSearch: ") + (re-search-backward (character-fold-to-regexp string) bound noerror count)) ;;; character-fold.el ends here commit c5f9ccfce272e06be568182c2c088f628add4eaf Author: Artur Malabarba Date: Sun Oct 25 01:31:04 2015 +0100 * lisp/isearch.el: Generalize definition of regexp-function toggles (isearch-specify-regexp-function): New macro for specifying possible values of `isearch-regexp-function'. (isearch-toggle-character-fold, isearch-toggle-symbol) (isearch-toggle-word): Define with `isearch-specify-regexp-function'. diff --git a/lisp/isearch.el b/lisp/isearch.el index 1386473..2c031aa 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -521,10 +521,8 @@ This is like `describe-bindings', but displays only Isearch keys." (define-key map "\M-sc" 'isearch-toggle-case-fold) (define-key map "\M-si" 'isearch-toggle-invisible) (define-key map "\M-sr" 'isearch-toggle-regexp) - (define-key map "\M-sw" 'isearch-toggle-word) - (define-key map "\M-s_" 'isearch-toggle-symbol) (define-key map "\M-s " 'isearch-toggle-lax-whitespace) - (define-key map "\M-s'" #'isearch-toggle-character-fold) + ;; More toggles defined by `isearch-specify-regexp-function'. (define-key map [?\M-%] 'isearch-query-replace) (define-key map [?\C-\M-%] 'isearch-query-replace-regexp) @@ -845,7 +843,6 @@ See the command `isearch-forward-symbol' for more information." ;; "List of commands for which isearch-mode does not recursive-edit.") (autoload 'character-fold-to-regexp "character-fold") -(put 'character-fold-to-regexp 'isearch-message-prefix "char-fold ") (defun isearch-mode (forward &optional regexp op-fun recursive-edit regexp-function) "Start Isearch minor mode. @@ -1506,36 +1503,34 @@ Use `isearch-exit' to quit without signaling." (setq isearch-success t isearch-adjusted t) (isearch-update)) -(defun isearch-toggle-word () - "Toggle word searching on or off." - ;; The status stack is left unchanged. - (interactive) - (setq isearch-regexp-function - (if (memq isearch-regexp-function '(t word-search-regexp)) - nil #'word-search-regexp)) - (when isearch-regexp-function (setq isearch-regexp nil)) - (setq isearch-success t isearch-adjusted t) - (isearch-update)) - -(defun isearch-toggle-symbol () - "Toggle symbol searching on or off." - (interactive) - (setq isearch-regexp-function - (unless (eq isearch-regexp-function #'isearch-symbol-regexp) - 'isearch-symbol-regexp)) - (when isearch-regexp-function (setq isearch-regexp nil)) - (setq isearch-success t isearch-adjusted t) - (isearch-update)) - -(defun isearch-toggle-character-fold () - "Toggle character folding in searching on or off." - (interactive) - (setq isearch-regexp-function - (unless (eq isearch-regexp-function #'character-fold-to-regexp) - #'character-fold-to-regexp)) - (when isearch-regexp-function (setq isearch-regexp nil)) - (setq isearch-success t isearch-adjusted t) - (isearch-update)) +;;; Toggles for `isearch-regexp-function' and `search-default-regexp-mode'. +(defmacro isearch-specify-regexp-function (mode function key) + "Define a search MODE in which `isearch-regexp-function' is set to FUNCTION. +Define a command called `isearch-toggle-MODE' and bind it to +`isearch-mode-map' under `M-s KEY'. +Also set the `isearch-message-prefix' property of FUNCTION." + (let ((command-name (intern (format "isearch-toggle-%s" mode)))) + `(progn + (defun ,command-name () + ,(format "Toggle %s searching on or off." mode) + (interactive) + (setq isearch-regexp-function + (unless (eq isearch-regexp-function #',function) + #',function)) + (when isearch-regexp-function (setq isearch-regexp nil)) + (setq isearch-success t isearch-adjusted t) + (isearch-update)) + (define-key isearch-mode-map ,(concat "\M-s" key) #',command-name) + (put ',function 'isearch-message-prefix ,(format "%s " mode)) + (cl-callf (lambda (types) (cons 'choice + (cons '(const :tag ,(capitalize (format "%s search" mode)) ,function) + (cdr types)))) + (get 'search-default-regexp-mode 'custom-type))))) + +(isearch-specify-regexp-function word word-search-regexp "w") +(isearch-specify-regexp-function symbol isearch-symbol-regexp "_") +(isearch-specify-regexp-function character-fold character-fold-to-regexp "'") +(put 'character-fold-to-regexp 'isearch-message-prefix "char-fold ") (defun isearch-toggle-lax-whitespace () "Toggle whitespace matching in searching on or off. commit cfd9ef52b2adbb38d9ca84d2088a735e9e69dc40 Author: Artur Malabarba Date: Sun Oct 25 00:42:29 2015 +0100 * lisp/isearch.el (search-default-regexp-mode): New variable (isearch-mode): Use it. diff --git a/lisp/isearch.el b/lisp/isearch.el index 159c992..1386473 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -220,6 +220,25 @@ It is nil if none yet.") Default value, nil, means edit the string instead." :type 'boolean) +(defcustom search-default-regexp-mode nil + "Default mode to use when starting isearch. +Value is nil, t, or a function. + +If nil, default to literal searches (note that `case-fold-search' +and `isearch-lax-whitespace' may still be applied).\\ +If t, default to regexp searches (as if typing `\\[isearch-toggle-regexp]' during +isearch). + +If a function, use that function as an `isearch-regexp-function'. +Example functions are `word-search-regexp' \(`\\[isearch-toggle-word]'), +`isearch-symbol-regexp' \(`\\[isearch-toggle-symbol]'), and +`character-fold-to-regexp' \(`\\[isearch-toggle-character-fold]')." + ;; :type is set below by `isearch-specify-regexp-function'. + :type '(choice (const :tag "Literal search" nil) + (const :tag "Regexp search" t) + (function :tag "Other")) + :version "25.1") + ;;; isearch highlight customization. (defcustom search-highlight t @@ -827,7 +846,6 @@ See the command `isearch-forward-symbol' for more information." (autoload 'character-fold-to-regexp "character-fold") (put 'character-fold-to-regexp 'isearch-message-prefix "char-fold ") -(defvar character-fold-search) (defun isearch-mode (forward &optional regexp op-fun recursive-edit regexp-function) "Start Isearch minor mode. @@ -850,11 +868,13 @@ used to set the value of `isearch-regexp-function'." ;; Initialize global vars. (setq isearch-forward forward - isearch-regexp regexp + isearch-regexp (or regexp + (and (not regexp-function) + (eq search-default-regexp-mode t))) isearch-regexp-function (or regexp-function - (and character-fold-search + (and (functionp search-default-regexp-mode) (not regexp) - 'character-fold-to-regexp)) + search-default-regexp-mode)) isearch-op-fun op-fun isearch-last-case-fold-search isearch-case-fold-search isearch-case-fold-search case-fold-search commit fa647ecdf293c77b65cbf357d9e8c036185d43ed Author: Artur Malabarba Date: Sun Oct 25 00:11:37 2015 +0100 * lisp/isearch.el: Delete redundant :group entries (search-exit-option, search-slow-window-lines) (search-slow-speed, search-upper-case) (search-nonincremental-instead, search-whitespace-regexp) (search-invisible, isearch-hide-immediately) (isearch-resume-in-command-history, search-ring-max) (regexp-search-ring-max, search-ring-update, search-highlight) (isearch-fail): Delete :group entries. diff --git a/lisp/isearch.el b/lisp/isearch.el index 6b99da9..159c992 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -72,23 +72,20 @@ (defcustom search-exit-option t "Non-nil means random control characters terminate incremental search." - :type 'boolean - :group 'isearch) + :type 'boolean) (defcustom search-slow-window-lines 1 "Number of lines in slow search display windows. These are the short windows used during incremental search on slow terminals. Negative means put the slow search window at the top (normally it's at bottom) and the value is minus the number of lines." - :type 'integer - :group 'isearch) + :type 'integer) (defcustom search-slow-speed 1200 "Highest terminal speed at which to use \"slow\" style incremental search. This is the style where a one-line window is created to show the line that the search has reached." - :type 'integer - :group 'isearch) + :type 'integer) (defcustom search-upper-case 'not-yanks "If non-nil, upper case chars disable case fold searching. @@ -99,15 +96,13 @@ If this value is `not-yanks', text yanked into the search string in Isearch mode is always downcased." :type '(choice (const :tag "off" nil) (const not-yanks) - (other :tag "on" t)) - :group 'isearch) + (other :tag "on" t))) (defcustom search-nonincremental-instead t "If non-nil, do a nonincremental search instead of exiting immediately. Actually, `isearch-edit-string' is called to let you enter the search string, and RET terminates editing and does a nonincremental search." - :type 'boolean - :group 'isearch) + :type 'boolean) (defcustom search-whitespace-regexp (purecopy "\\s-+") "If non-nil, regular expression to match a sequence of whitespace chars. @@ -127,7 +122,6 @@ In the Customization buffer, that is `[' followed by a space, a tab, a carriage return (control-M), a newline, and `]+'." :type '(choice (const :tag "Match Spaces Literally" nil) regexp) - :group 'isearch :version "24.3") (defcustom search-invisible 'open @@ -147,8 +141,7 @@ See also `reveal-mode' if you want overlays to automatically be opened whenever point is in one of them." :type '(choice (const :tag "Match hidden text" t) (const :tag "Open overlays" open) - (const :tag "Don't match hidden text" nil)) - :group 'isearch) + (const :tag "Don't match hidden text" nil))) (defcustom isearch-hide-immediately t "If non-nil, re-hide an invisible match right away. @@ -156,15 +149,13 @@ This variable makes a difference when `search-invisible' is set to `open'. If nil then do not re-hide opened invisible text when the match moves. Whatever the value, all opened invisible text is hidden again after exiting the search." - :type 'boolean - :group 'isearch) + :type 'boolean) (defcustom isearch-resume-in-command-history nil "If non-nil, `isearch-resume' commands are added to the command history. This allows you to resume earlier Isearch sessions through the command history." - :type 'boolean - :group 'isearch) + :type 'boolean) (defvar isearch-mode-hook nil "Function(s) to call after starting up an incremental search.") @@ -212,12 +203,10 @@ displayed in the search message.") (defcustom search-ring-max 16 "Maximum length of search ring before oldest elements are thrown away." - :type 'integer - :group 'isearch) + :type 'integer) (defcustom regexp-search-ring-max 16 "Maximum length of regexp search ring before oldest elements are thrown away." - :type 'integer - :group 'isearch) + :type 'integer) (defvar search-ring-yank-pointer nil "Index in `search-ring' of last string reused. @@ -229,15 +218,13 @@ It is nil if none yet.") (defcustom search-ring-update nil "Non-nil if advancing or retreating in the search ring should cause search. Default value, nil, means edit the string instead." - :type 'boolean - :group 'isearch) + :type 'boolean) ;;; isearch highlight customization. (defcustom search-highlight t "Non-nil means incremental search highlights the current match." - :type 'boolean - :group 'isearch) + :type 'boolean) (defface isearch '((((class color) (min-colors 88) (background light)) @@ -269,8 +256,7 @@ Default value, nil, means edit the string instead." :foreground "grey") (t (:inverse-video t))) "Face for highlighting failed part in Isearch echo-area message." - :version "23.1" - :group 'isearch) + :version "23.1") (defcustom isearch-lazy-highlight t "Controls the lazy-highlighting during incremental search. commit 79fac080d277fed07b3c192890ad59d36d9f83b6 Author: Artur Malabarba Date: Sun Oct 25 01:37:17 2015 +0100 * lisp/custom.el (custom-declare-variable): Shorten code a bit diff --git a/lisp/custom.el b/lisp/custom.el index c5d0e65..cc284ef 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -155,40 +155,29 @@ set to nil, as the value is no longer rogue." (unless (memq :group args) (custom-add-to-group (custom-current-group) symbol 'custom-variable)) (while args - (let ((arg (car args))) - (setq args (cdr args)) - (unless (symbolp arg) - (error "Junk in args %S" args)) - (let ((keyword arg) - (value (car args))) - (unless args - (error "Keyword %s is missing an argument" keyword)) - (setq args (cdr args)) - (cond ((eq keyword :initialize) - (setq initialize value)) - ((eq keyword :set) - (put symbol 'custom-set value)) - ((eq keyword :get) - (put symbol 'custom-get value)) - ((eq keyword :require) - (push value requests)) - ((eq keyword :risky) - (put symbol 'risky-local-variable value)) - ((eq keyword :safe) - (put symbol 'safe-local-variable value)) - ((eq keyword :type) - (put symbol 'custom-type (purecopy value))) - ((eq keyword :options) - (if (get symbol 'custom-options) - ;; Slow safe code to avoid duplicates. - (mapc (lambda (option) - (custom-add-option symbol option)) - value) - ;; Fast code for the common case. - (put symbol 'custom-options (copy-sequence value)))) - (t - (custom-handle-keyword symbol keyword value - 'custom-variable)))))) + (let ((keyword (pop args))) + (unless (symbolp keyword) + (error "Junk in args %S" (cons keyword args))) + (unless args + (error "Keyword %s is missing an argument" keyword)) + (let ((value (pop args))) + (pcase keyword + (`:initialize (setq initialize value)) + (`:set (put symbol 'custom-set value)) + (`:get (put symbol 'custom-get value)) + (`:require (push value requests)) + (`:risky (put symbol 'risky-local-variable value)) + (`:safe (put symbol 'safe-local-variable value)) + (`:type (put symbol 'custom-type (purecopy value))) + (`:options (if (get symbol 'custom-options) + ;; Slow safe code to avoid duplicates. + (mapc (lambda (option) + (custom-add-option symbol option)) + value) + ;; Fast code for the common case. + (put symbol 'custom-options (copy-sequence value)))) + (_ (custom-handle-keyword symbol keyword value + 'custom-variable)))))) (put symbol 'custom-requests requests) ;; Do the actual initialization. (unless custom-dont-initialize commit b6c6629ebe570baac53ed2a737f54711f29f79ca Author: Juanma Barranquero Date: Sun Oct 25 00:58:08 2015 +0200 addpm.c: Silence some warnings. * nt/addpm.c (DdeCommand): Cast pData argument of DdeClientTransaction to LPBYTE. (add_registry): Pass NULL to optional lpClass argument of RegCreateKeyEx, not an empty string. diff --git a/nt/addpm.c b/nt/addpm.c index ee90cf8..8dfb4bd 100644 --- a/nt/addpm.c +++ b/nt/addpm.c @@ -62,7 +62,7 @@ DdeCallback (UINT uType, UINT uFmt, HCONV hconv, } #define DdeCommand(str) \ - DdeClientTransaction (str, strlen (str)+1, conversation, (HSZ)NULL, \ + DdeClientTransaction ((LPBYTE)str, strlen (str)+1, conversation, (HSZ)NULL, \ CF_TEXT, XTYP_EXECUTE, 30000, NULL) #define REG_ROOT "SOFTWARE\\GNU\\Emacs" @@ -116,7 +116,7 @@ add_registry (const char *path) affect the general operation of other installations of Emacs, and we are blindly overwriting the Start Menu entries already. */ - if (RegCreateKeyEx (HKEY_LOCAL_MACHINE, REG_APP_PATH, 0, "", + if (RegCreateKeyEx (HKEY_LOCAL_MACHINE, REG_APP_PATH, 0, NULL, REG_OPTION_NON_VOLATILE, KEY_WRITE, NULL, &hrootkey, NULL) == ERROR_SUCCESS) { commit 87a30649e791392656606422383e1683f6b5781e Author: Juanma Barranquero Date: Sun Oct 25 00:20:03 2015 +0200 addpm.c: Do not add obsolete GTK libraries to the path. * nt/addpm.c (REG_GTK, REG_RUNEMACS_PATH): Delete. (add_registry): Remove variables `size' and `gtk_key'. Do not add the GTK DLL directory to the library search path; it is confusing behavior (in particular, the same Emacs version with and without invoking addpm will use a different path), and the GTK image libraries are obsolete anyway. diff --git a/nt/addpm.c b/nt/addpm.c index caa3272..ee90cf8 100644 --- a/nt/addpm.c +++ b/nt/addpm.c @@ -66,11 +66,8 @@ DdeCallback (UINT uType, UINT uFmt, HCONV hconv, CF_TEXT, XTYP_EXECUTE, 30000, NULL) #define REG_ROOT "SOFTWARE\\GNU\\Emacs" -#define REG_GTK "SOFTWARE\\GTK\\2.0" #define REG_APP_PATH \ "SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\emacs.exe" -#define REG_RUNEMACS_PATH \ - "SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\runemacs.exe" static struct entry { @@ -109,7 +106,6 @@ add_registry (const char *path) { HKEY hrootkey = NULL; int i; - DWORD size; /* Record the location of Emacs to the App Paths key if we have sufficient permissions to do so. This helps Windows find emacs quickly @@ -126,54 +122,12 @@ add_registry (const char *path) { int len; char *emacs_path; - HKEY gtk_key = NULL; len = strlen (path) + 15; /* \bin\emacs.exe + terminator. */ emacs_path = (char *) alloca (len); sprintf (emacs_path, "%s\\bin\\emacs.exe", path); RegSetValueEx (hrootkey, NULL, 0, REG_EXPAND_SZ, emacs_path, len); - - /* Look for a GTK installation. If found, add it to the library search - path for Emacs so that the image libraries it provides are available - to Emacs regardless of whether it is in the path or not. */ - if (RegOpenKeyEx (HKEY_LOCAL_MACHINE, REG_GTK, 0, - KEY_READ, >k_key) == ERROR_SUCCESS) - { - if (RegQueryValueEx (gtk_key, "DllPath", NULL, NULL, - NULL, &size) == ERROR_SUCCESS) - { - char *gtk_path = (char *) alloca (size); - if (RegQueryValueEx (gtk_key, "DllPath", NULL, NULL, - gtk_path, &size) == ERROR_SUCCESS) - { - /* Make sure the emacs bin directory continues to be searched - first by including it as well. */ - char *dll_paths; - HKEY runemacs_key = NULL; - len = strlen (path) + 5 + size; - dll_paths = (char *) alloca (size + strlen (path) + 1); - sprintf (dll_paths, "%s\\bin;%s", path, gtk_path); - RegSetValueEx (hrootkey, "Path", 0, REG_EXPAND_SZ, - dll_paths, len); - - /* Set the same path for runemacs.exe, as the Explorer shell - looks this up, so the above does not take effect when - emacs.exe is spawned from runemacs.exe. */ - if (RegCreateKeyEx (HKEY_LOCAL_MACHINE, REG_RUNEMACS_PATH, - 0, "", REG_OPTION_NON_VOLATILE, - KEY_WRITE, NULL, &runemacs_key, NULL) - == ERROR_SUCCESS) - { - RegSetValueEx (runemacs_key, "Path", 0, REG_EXPAND_SZ, - dll_paths, len); - - RegCloseKey (runemacs_key); - } - } - } - RegCloseKey (gtk_key); - } RegCloseKey (hrootkey); } commit cbbea701c6956961b55ed754fbfe2ae6329f940b Author: Juanma Barranquero Date: Sat Oct 24 04:31:30 2015 +0200 addpm.c: Replace existing entries, but do not create new ones * nt/addpm.c (add_registry): If the Emacs registry key exists, replace existing values from previous versions, but do not add new ones; the key could exist for other reasons unrelated to old Emacsen, like X-style resources, or to set some environment variables like HOME or LANG, and in that case we don't want to populate it with obsolete values. diff --git a/nt/addpm.c b/nt/addpm.c index ba0eb36..caa3272 100644 --- a/nt/addpm.c +++ b/nt/addpm.c @@ -186,17 +186,20 @@ add_registry (const char *path) have any resources. */ if (RegOpenKeyEx (HKEY_LOCAL_MACHINE, REG_ROOT, 0, - KEY_WRITE, &hrootkey) != ERROR_SUCCESS + KEY_WRITE | KEY_QUERY_VALUE, &hrootkey) != ERROR_SUCCESS && RegOpenKeyEx (HKEY_CURRENT_USER, REG_ROOT, 0, - KEY_WRITE, &hrootkey) != ERROR_SUCCESS) + KEY_WRITE | KEY_QUERY_VALUE, &hrootkey) != ERROR_SUCCESS) return; for (i = 0; i < (sizeof (env_vars) / sizeof (env_vars[0])); i++) { const char * value = env_vars[i].value ? env_vars[i].value : path; - RegSetValueEx (hrootkey, env_vars[i].name, 0, REG_EXPAND_SZ, - value, lstrlen (value) + 1); + /* Replace only those settings that already exist. */ + if (RegQueryValueEx (hrootkey, env_vars[i].name, NULL, + NULL, NULL, NULL) == ERROR_SUCCESS) + RegSetValueEx (hrootkey, env_vars[i].name, 0, REG_EXPAND_SZ, + value, lstrlen (value) + 1); } RegCloseKey (hrootkey); commit 8c5747ea98e82b3f2112abf0b62a509649101903 Author: Juanma Barranquero Date: Sat Oct 24 04:01:22 2015 +0200 * nt/addpm.c (add_registry): Do not compute unused return value. diff --git a/nt/addpm.c b/nt/addpm.c index b2f0916..ba0eb36 100644 --- a/nt/addpm.c +++ b/nt/addpm.c @@ -104,12 +104,11 @@ env_vars[] = #endif }; -BOOL +void add_registry (const char *path) { HKEY hrootkey = NULL; int i; - BOOL ok = TRUE; DWORD size; /* Record the location of Emacs to the App Paths key if we have @@ -190,23 +189,17 @@ add_registry (const char *path) KEY_WRITE, &hrootkey) != ERROR_SUCCESS && RegOpenKeyEx (HKEY_CURRENT_USER, REG_ROOT, 0, KEY_WRITE, &hrootkey) != ERROR_SUCCESS) - { - return FALSE; - } + return; for (i = 0; i < (sizeof (env_vars) / sizeof (env_vars[0])); i++) { const char * value = env_vars[i].value ? env_vars[i].value : path; - if (RegSetValueEx (hrootkey, env_vars[i].name, - 0, REG_EXPAND_SZ, - value, lstrlen (value) + 1) != ERROR_SUCCESS) - ok = FALSE; + RegSetValueEx (hrootkey, env_vars[i].name, 0, REG_EXPAND_SZ, + value, lstrlen (value) + 1); } RegCloseKey (hrootkey); - - return (ok); } int commit 8a48f16de01eaa9f2c65baf43ab3168f68e0ad39 Author: Juanma Barranquero Date: Sat Oct 24 03:22:50 2015 +0200 addpm.c: Don't pass REG_OPTION_NON_VOLATILE to RegOpenKeyEx * nt/addpm.c (add_registry): Pass 0 to ulOptions argument of RegOpenKeyEx, not REG_OPTION_NON_VOLATILE. This doesn't change current behavior because REG_OPTION_NON_VOLATILE is defined to be 0L anyway, but that option is actually documented only for RegCreateKeyEx. diff --git a/nt/addpm.c b/nt/addpm.c index cd91a3e..b2f0916 100644 --- a/nt/addpm.c +++ b/nt/addpm.c @@ -138,7 +138,7 @@ add_registry (const char *path) /* Look for a GTK installation. If found, add it to the library search path for Emacs so that the image libraries it provides are available to Emacs regardless of whether it is in the path or not. */ - if (RegOpenKeyEx (HKEY_LOCAL_MACHINE, REG_GTK, REG_OPTION_NON_VOLATILE, + if (RegOpenKeyEx (HKEY_LOCAL_MACHINE, REG_GTK, 0, KEY_READ, >k_key) == ERROR_SUCCESS) { if (RegQueryValueEx (gtk_key, "DllPath", NULL, NULL, @@ -186,11 +186,9 @@ add_registry (const char *path) /* Check both the current user and the local machine to see if we have any resources. */ - if (RegOpenKeyEx (HKEY_LOCAL_MACHINE, REG_ROOT, - REG_OPTION_NON_VOLATILE, + if (RegOpenKeyEx (HKEY_LOCAL_MACHINE, REG_ROOT, 0, KEY_WRITE, &hrootkey) != ERROR_SUCCESS - && RegOpenKeyEx (HKEY_CURRENT_USER, REG_ROOT, - REG_OPTION_NON_VOLATILE, + && RegOpenKeyEx (HKEY_CURRENT_USER, REG_ROOT, 0, KEY_WRITE, &hrootkey) != ERROR_SUCCESS) { return FALSE; commit 478d9d9db39af654abdfeb793f2d9c2ecb71daf1 Author: Juanma Barranquero Date: Sun Oct 25 00:00:26 2015 +0200 * src/w32notify.c (Fw32notify_add_watch): Fix version check. diff --git a/src/w32notify.c b/src/w32notify.c index e822d95..de27ab8 100644 --- a/src/w32notify.c +++ b/src/w32notify.c @@ -525,7 +525,7 @@ generate notifications correctly, though. */) /* The underlying features are available only since XP. */ if (os_subtype == OS_9X - || (w32_major_version == 5 && w32_major_version < 1)) + || (w32_major_version == 5 && w32_minor_version < 1)) { errno = ENOSYS; report_file_notify_error ("Watching filesystem events is not supported", commit 9d6ec23f7d4f8fbbfdcea353c4b58e47f76a7342 Author: Eli Zaretskii Date: Sat Oct 24 18:54:15 2015 +0300 Update frame title when redisplay scrolls selected window * src/xdisp.c (redisplay_window): Reconsider the frame's title when the mode-line of the frame's selected window needs to be updated. diff --git a/src/xdisp.c b/src/xdisp.c index 0576712..bdf2d09 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -16854,7 +16854,8 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) finish_menu_bars: - /* When we reach a frame's selected window, redo the frame's menu bar. */ + /* When we reach a frame's selected window, redo the frame's menu + bar and the frame's title. */ if (update_mode_line && EQ (FRAME_SELECTED_WINDOW (f), window)) { @@ -16889,6 +16890,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) ignore_mouse_drag_p = true; #endif } + x_consider_frame_title (w->frame); #endif } commit 41518e5b6354cf6aa946de2e5b02b728f7b15b8c Author: Eli Zaretskii Date: Sat Oct 24 18:41:32 2015 +0300 Update frame title when scrolling the selected window * src/window.c (wset_update_mode_line): New function, sets either the window's update_mode_line flag or the global update_mode_lines variable. (Fset_window_start, set_window_buffer, window_scroll_pixel_based) (window_scroll_line_based): Call it instead of only setting the window's update_mode_line flag. diff --git a/src/window.c b/src/window.c index a8605ee..7c95ff9 100644 --- a/src/window.c +++ b/src/window.c @@ -205,6 +205,20 @@ wset_combination (struct window *w, bool horflag, Lisp_Object val) w->horizontal = horflag; } +static void +wset_update_mode_line (struct window *w) +{ + /* If this window is the selected window on its frame, set the + global variable update_mode_lines, so that x_consider_frame_title + will consider this frame's title for rtedisplay. */ + Lisp_Object fselected_window = XFRAME (WINDOW_FRAME (w))->selected_window; + + if (WINDOWP (fselected_window) && XWINDOW (fselected_window) == w) + update_mode_lines = 42; + else + w->update_mode_line = true; +} + /* True if leaf window W doesn't reflect the actual state of displayed buffer due to its text or overlays change. */ @@ -1666,7 +1680,7 @@ overriding motion of point in order to display at this exact start. */) w->start_at_line_beg = false; if (NILP (noforce)) w->force_start = true; - w->update_mode_line = true; + wset_update_mode_line (w); /* Bug#15957. */ w->window_end_valid = false; wset_redisplay (w); @@ -3271,14 +3285,8 @@ set_window_buffer (Lisp_Object window, Lisp_Object buffer, /* Maybe we could move this into the `if' but it's not obviously safe and I doubt it's worth the trouble. */ wset_redisplay (w); - /* If this window is the selected window on its frame, set the - global variable update_mode_lines, so that x_consider_frame_title - will consider this frame's title for rtedisplay. */ - Lisp_Object fselected_window = XFRAME (WINDOW_FRAME (w))->selected_window; - if (WINDOWP (fselected_window) && XWINDOW (fselected_window) == w) - update_mode_lines = 42; - else - w->update_mode_line = true; + + wset_update_mode_line (w); /* We must select BUFFER to run the window-scroll-functions and to look up the buffer-local value of Vwindow_point_insertion_type. */ @@ -4829,7 +4837,7 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror) set_marker_restricted (w->start, make_number (spos), w->contents); w->start_at_line_beg = true; - w->update_mode_line = true; + wset_update_mode_line (w); /* Set force_start so that redisplay_window will run the window-scroll-functions. */ w->force_start = true; @@ -4977,7 +4985,7 @@ window_scroll_pixel_based (Lisp_Object window, int n, bool whole, bool noerror) IT_BYTEPOS (it)); bytepos = marker_byte_position (w->start); w->start_at_line_beg = (pos == BEGV || FETCH_BYTE (bytepos - 1) == '\n'); - w->update_mode_line = true; + wset_update_mode_line (w); /* Set force_start so that redisplay_window will run the window-scroll-functions. */ w->force_start = true; @@ -5211,7 +5219,7 @@ window_scroll_line_based (Lisp_Object window, int n, bool whole, bool noerror) set_marker_restricted_both (w->start, w->contents, pos, pos_byte); w->start_at_line_beg = !NILP (bolp); - w->update_mode_line = true; + wset_update_mode_line (w); /* Set force_start so that redisplay_window will run the window-scroll-functions. */ w->force_start = true; commit 7a6968b45f2b93d984c5c3fcd5fce68d6e5b6ea9 Author: Eli Zaretskii Date: Sat Oct 24 17:58:34 2015 +0300 An even better fix for bug#21739 * src/window.c (set_window_buffer): If the window is the frame's selected window, set update_mode_lines, not the window's update_mode_line flag. (Bug#21739) * src/buffer.c (Fkill_buffer): Undo last change. (set_update_modelines_for_buf): Function deleted. diff --git a/src/buffer.c b/src/buffer.c index 8476876..380a7af 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -1611,19 +1611,6 @@ compact_buffer (struct buffer *buffer) } } -/* Set the global update_mode_lines variable non-zero if the buffer - was displayed in some window. This is needed to catch the - attention of redisplay to changes that might require redisplay of - the frame title (which uses the same variables as mode lines) when - the buffer object cannot be used for recording that fact, e.g. if - the buffer is killed. */ -static void -set_update_modelines_for_buf (bool disp) -{ - if (disp) - update_mode_lines = 42; -} - DEFUN ("kill-buffer", Fkill_buffer, Skill_buffer, 0, 1, "bKill buffer: ", doc: /* Kill the buffer specified by BUFFER-OR-NAME. The argument may be a buffer or the name of an existing buffer. @@ -1646,7 +1633,6 @@ cleaning up all windows currently displaying the buffer to be killed. */) struct buffer *b; Lisp_Object tem; struct Lisp_Marker *m; - bool buffer_was_displayed = false; if (NILP (buffer_or_name)) buffer = Fcurrent_buffer (); @@ -1661,8 +1647,6 @@ cleaning up all windows currently displaying the buffer to be killed. */) if (!BUFFER_LIVE_P (b)) return Qnil; - buffer_was_displayed = buffer_window_count (b); - /* Run hooks with the buffer to be killed the current buffer. */ { ptrdiff_t count = SPECPDL_INDEX (); @@ -1689,10 +1673,7 @@ cleaning up all windows currently displaying the buffer to be killed. */) /* If the hooks have killed the buffer, exit now. */ if (!BUFFER_LIVE_P (b)) - { - set_update_modelines_for_buf (buffer_was_displayed); - return unbind_to (count, Qt); - } + return unbind_to (count, Qt); /* Then run the hooks. */ run_hook (Qkill_buffer_hook); @@ -1701,10 +1682,7 @@ cleaning up all windows currently displaying the buffer to be killed. */) /* If the hooks have killed the buffer, exit now. */ if (!BUFFER_LIVE_P (b)) - { - set_update_modelines_for_buf (buffer_was_displayed); - return Qt; - } + return Qt; /* We have no more questions to ask. Verify that it is valid to kill the buffer. This must be done after the questions @@ -1732,10 +1710,7 @@ cleaning up all windows currently displaying the buffer to be killed. */) /* Exit if we now have killed the base buffer (Bug#11665). */ if (!BUFFER_LIVE_P (b)) - { - set_update_modelines_for_buf (buffer_was_displayed); - return Qt; - } + return Qt; } /* Run replace_buffer_in_windows before making another buffer current @@ -1746,10 +1721,7 @@ cleaning up all windows currently displaying the buffer to be killed. */) /* Exit if replacing the buffer in windows has killed our buffer. */ if (!BUFFER_LIVE_P (b)) - { - set_update_modelines_for_buf (buffer_was_displayed); - return Qt; - } + return Qt; /* Make this buffer not be current. Exit if it is the sole visible buffer. */ @@ -1778,10 +1750,7 @@ cleaning up all windows currently displaying the buffer to be killed. */) /* Killing buffer processes may run sentinels which may have killed our buffer. */ if (!BUFFER_LIVE_P (b)) - { - set_update_modelines_for_buf (buffer_was_displayed); - return Qt; - } + return Qt; /* These may run Lisp code and into infinite loops (if someone insisted on circular lists) so allow quitting here. */ @@ -1813,10 +1782,7 @@ cleaning up all windows currently displaying the buffer to be killed. */) /* Deleting an auto-save file could have killed our buffer. */ if (!BUFFER_LIVE_P (b)) - { - set_update_modelines_for_buf (buffer_was_displayed); - return Qt; - } + return Qt; if (b->base_buffer) { @@ -1915,7 +1881,6 @@ cleaning up all windows currently displaying the buffer to be killed. */) if (!NILP (Vrun_hooks)) call1 (Vrun_hooks, Qbuffer_list_update_hook); - set_update_modelines_for_buf (buffer_was_displayed); return Qt; } diff --git a/src/window.c b/src/window.c index 8ed0f32..a8605ee 100644 --- a/src/window.c +++ b/src/window.c @@ -3271,7 +3271,14 @@ set_window_buffer (Lisp_Object window, Lisp_Object buffer, /* Maybe we could move this into the `if' but it's not obviously safe and I doubt it's worth the trouble. */ wset_redisplay (w); - w->update_mode_line = true; + /* If this window is the selected window on its frame, set the + global variable update_mode_lines, so that x_consider_frame_title + will consider this frame's title for rtedisplay. */ + Lisp_Object fselected_window = XFRAME (WINDOW_FRAME (w))->selected_window; + if (WINDOWP (fselected_window) && XWINDOW (fselected_window) == w) + update_mode_lines = 42; + else + w->update_mode_line = true; /* We must select BUFFER to run the window-scroll-functions and to look up the buffer-local value of Vwindow_point_insertion_type. */ commit 59a2ad3e75442f89f88e2cac304b09fb50e70cb6 Author: Eli Zaretskii Date: Sat Oct 24 17:16:14 2015 +0300 ; * src/xdisp.c (redisplay_internal): Improve commentary. diff --git a/src/xdisp.c b/src/xdisp.c index 297f789..0576712 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -13931,7 +13931,15 @@ redisplay_internal (void) if (sf->fonts_changed || sf->redisplay) { if (sf->redisplay) - windows_or_buffers_changed = 50; + { + /* Set this to force a more thorough redisplay. + Otherwise, we might immediately loop back to the + above "else-if" clause (since all the conditions that + led here might still be true), and we will then + infloop, because the selected-frame's redisplay flag + is not (and cannot be) reset. */ + windows_or_buffers_changed = 50; + } goto retry; } commit c88d85dcd7cc4c3dd89d9564938dcfbdc45f163f Author: Ken Brown Date: Sat Oct 24 10:12:01 2015 -0400 ; * src/xdisp.c: Fix typo. diff --git a/src/xdisp.c b/src/xdisp.c index 247aa28..297f789 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -453,7 +453,7 @@ static bool message_enable_multibyte; OTOH if it's non-zero we wil have to loop through all windows and then check the `redisplay' bit of the corresponding window, frame, and buffer, in order - to decide whether that window needs attention or not. Not that we can't + to decide whether that window needs attention or not. Note that we can't just look at the frame's redisplay bit to decide that the whole frame can be skipped, since even if the frame's redisplay bit is unset, some of its windows's redisplay bits may be set. commit 069a0e41f40822f3233333eee33ef6f15a640f0b Author: Thomas Fitzsimmons Date: Sat Oct 24 08:33:18 2015 -0400 Sync with soap-client repository, version 3.0.0 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 +;; Author: Thomas Fitzsimmons ;; 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 "\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: + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; Node: + ;; + ;; + ;; 1 + ;; + ;; + ;; soap-decode-type will be called below with: + ;; + ;; element = + ;; + ;; + ;; + ;; + ;; node = + ;; + ;; + ;; 1 + ;; + (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 "\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 "\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 "\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 "\n") + (when input-action + (add-to-list 'soap-encoded-namespaces "wsa") + (insert "" input-action "\n") + (insert "" service-url "\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 "\n")))) + (insert "\n"))) + (insert "\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 "\n")) (insert "\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 "\n\n") (goto-char (point-max)) (insert "\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 ;; 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) commit ab10d8825427714a2a7acd36adcc5b0b066ed6ca Author: Nicolas Petton Date: Sat Oct 24 13:35:11 2015 +0200 Update the new icon Move the E slightly to the right in the circle. * etc/images/icons/hicolor/128x128/apps/emacs.png: * etc/images/icons/hicolor/16x16/apps/emacs.png: * etc/images/icons/hicolor/24x24/apps/emacs.png: * etc/images/icons/hicolor/32x32/apps/emacs.png: * etc/images/icons/hicolor/48x48/apps/emacs.png: * etc/images/icons/hicolor/scalable/apps/emacs.svg: * nextstep/Cocoa/Emacs.base/Contents/Resources/Emacs.icns: * nt/icons/emacs.ico: New icom update. diff --git a/etc/images/icons/hicolor/128x128/apps/emacs.png b/etc/images/icons/hicolor/128x128/apps/emacs.png index 8e84a75..9ab43d7 100644 Binary files a/etc/images/icons/hicolor/128x128/apps/emacs.png and b/etc/images/icons/hicolor/128x128/apps/emacs.png differ diff --git a/etc/images/icons/hicolor/16x16/apps/emacs.png b/etc/images/icons/hicolor/16x16/apps/emacs.png index 9b5bfcd..eb6b402 100644 Binary files a/etc/images/icons/hicolor/16x16/apps/emacs.png and b/etc/images/icons/hicolor/16x16/apps/emacs.png differ diff --git a/etc/images/icons/hicolor/24x24/apps/emacs.png b/etc/images/icons/hicolor/24x24/apps/emacs.png index cd92ab5..7a8d8b6 100644 Binary files a/etc/images/icons/hicolor/24x24/apps/emacs.png and b/etc/images/icons/hicolor/24x24/apps/emacs.png differ diff --git a/etc/images/icons/hicolor/32x32/apps/emacs.png b/etc/images/icons/hicolor/32x32/apps/emacs.png index 432dd41..aea5afd 100644 Binary files a/etc/images/icons/hicolor/32x32/apps/emacs.png and b/etc/images/icons/hicolor/32x32/apps/emacs.png differ diff --git a/etc/images/icons/hicolor/48x48/apps/emacs.png b/etc/images/icons/hicolor/48x48/apps/emacs.png index 34ee4bc..bae23aa 100644 Binary files a/etc/images/icons/hicolor/48x48/apps/emacs.png and b/etc/images/icons/hicolor/48x48/apps/emacs.png differ diff --git a/etc/images/icons/hicolor/scalable/apps/emacs.svg b/etc/images/icons/hicolor/scalable/apps/emacs.svg index 2ef4b57..9de91c6 100644 --- a/etc/images/icons/hicolor/scalable/apps/emacs.svg +++ b/etc/images/icons/hicolor/scalable/apps/emacs.svg @@ -6,15 +6,43 @@ xmlns:svg="http://www.w3.org/2000/svg" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" - xml:space="preserve" - id="svg4768" - viewBox="0.171 0.201 512 512" - height="48" + xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd" + xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" + version="1.0" width="48" - version="1.0">image/svg+xml