diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/.gitignore | 2 | ||||
| -rw-r--r-- | lisp/ChangeLog | 126 | ||||
| -rw-r--r-- | lisp/allout-widgets.el | 2365 | ||||
| -rw-r--r-- | lisp/allout.el | 54 | ||||
| -rw-r--r-- | lisp/dired-x.el | 239 | ||||
| -rw-r--r-- | lisp/dired.el | 2 | ||||
| -rw-r--r-- | lisp/emacs-lisp/ert.el | 22 | ||||
| -rw-r--r-- | lisp/emacs-lisp/pcase.el | 9 | ||||
| -rw-r--r-- | lisp/gnus/ChangeLog | 78 | ||||
| -rw-r--r-- | lisp/gnus/auth-source.el | 332 | ||||
| -rw-r--r-- | lisp/gnus/gnus-sum.el | 3 | ||||
| -rw-r--r-- | lisp/gnus/gnus-util.el | 9 | ||||
| -rw-r--r-- | lisp/gnus/nnimap.el | 140 | ||||
| -rw-r--r-- | lisp/net/rcirc.el | 17 | ||||
| -rw-r--r-- | lisp/net/soap-client.el | 1741 | ||||
| -rw-r--r-- | lisp/net/soap-inspect.el | 357 | ||||
| -rw-r--r-- | lisp/play/doctor.el | 2 | ||||
| -rw-r--r-- | lisp/progmodes/prolog.el | 3 | ||||
| -rw-r--r-- | lisp/shell.el | 10 | ||||
| -rw-r--r-- | lisp/simple.el | 2 | ||||
| -rw-r--r-- | lisp/speedbar.el | 51 | ||||
| -rw-r--r-- | lisp/term.el | 51 | ||||
| -rw-r--r-- | lisp/term/sup-mouse.el | 7 | ||||
| -rw-r--r-- | lisp/term/x-win.el | 22 | ||||
| -rw-r--r-- | lisp/vc/vc.el | 3 |
25 files changed, 5207 insertions, 440 deletions
diff --git a/lisp/.gitignore b/lisp/.gitignore index d8ab5055b4a..6d5166e1349 100644 --- a/lisp/.gitignore +++ b/lisp/.gitignore @@ -4,5 +4,3 @@ loaddefs.el subdirs.el finder-inf.el cus-load.el - -# arch-tag: ab6e8f91-fb95-4efe-9c1b-68e21561e68a diff --git a/lisp/ChangeLog b/lisp/ChangeLog index a9adce5a3f5..8e850fb9409 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,129 @@ +2011-02-18 Stefan Monnier <monnier@iro.umontreal.ca> + + * emacs-lisp/pcase.el (pcase--u1): Understand non-linear patterns. + +2011-02-18 Christian Ohler <ohler@gnu.org> + + * emacs-lisp/ert.el (ert--setup-results-buffer) + (ert-results-pop-to-backtrace-for-test-at-point) + (ert-results-pop-to-messages-for-test-at-point) + (ert-results-pop-to-should-forms-for-test-at-point) + (ert-results-pop-to-timings): Revert parts of change 2011-02-02T17:59:44Z!sds@gnu.org that + were incorrect and unnecessary. This should make `make check' + pass again. + +2011-02-17 Ken Manheimer <ken.manheimer@gmail.com> + + * lisp/allout-widgets.el: (allout-widgets-icons-light-subdir) + (allout-widgets-icons-dark-subdir): Track relocations of icons + * lisp/allout.el: Remove commentary about remove encryption + passphrase mnemonic support and verification. + (allout-encrypt-string): (allout-encrypt-string): Recognize epg + failure to decrypt gpg2 armored text using gpg1, and indicate that + the gpg version *might* be the problem in the error message. + +2011-02-17 Deniz Dogan <deniz.a.m.dogan@gmail.com> + + * net/rcirc.el (rcirc-float-time): New function. + (rcirc-keepalive, rcirc-handler-ctcp-KEEPALIVE) + (rcirc-ctcp-sender-PING): Use it. + +2011-02-17 Glenn Morris <rgm@gnu.org> + + * speedbar.el (speedbar-ignored-modes, speedbar-file-unshown-regexp) + (speedbar-update-flag, speedbar-fetch-etags-command) + (speedbar-fetch-etags-arguments): + * term.el (term-buffer-maximum-size, term-input-chunk-size) + (term-completion-autolist, term-completion-addsuffix) + (term-completion-recexact, term-completion-fignore): + * term/sup-mouse.el (sup-mouse-fast-select-window): + * term/x-win.el (x-select-request-type): + Convert some defvars with "*" to defcustoms. + + * shell.el (shell-delimiter-argument-list): Set it to nil. (Bug#8027) + + * vc/vc.el (vc-default-previous-version): + Remove alias that points nowhere. (Bug#4496) + + * dired-x.el (dired-clean-up-after-deletion): + kill-buffer does not need save-excursion. + (dired-do-run-mail): Doc fix. + (dired-filename-at-point): Doc fix. + Use looking-at, and skip-chars rather than re search. + + * dired-x.el (dired-filename-at-point): Fix 8-year old typo. + +2011-02-16 Ken Manheimer <ken.manheimer@gmail.com> + + * allout-widgets.el: New allout extension that shows allout + outline structure with graphical widgets. 'allout-widgets' + customize group is an 'allout' subgroup, for easy discovery. + + * allout.el: Include PGP and GnuPG in Keywords, and other + commentary refinements. + (allout-abbreviate-flattened-numbering): Rename to + allout-flattened-numbering-abbreviation, and + define-obsolete-variable-alias the old name. + (allout-flattened-numbering-abbreviation): Rename from + allout-abbreviate-flattened-numbering. + (allout-mode-p): Include among autoloads, for use by other modes + with impunity. + (allout-listify-exposed): Use + allout-flattened-numbering-abbreviation. + (allout-encrypt-string): Use set-buffer-multibyte directly. + (allout-set-buffer-multibyte): Remove. + +2011-02-16 Deniz Dogan <deniz.a.m.dogan@gmail.com> + + * simple.el (just-one-space): Remove useless `or' call. + +2011-02-16 Alex Harsanyi <AlexHarsanyi@gmail.com> + + * soap-client.el (soap-well-known-xmlns, soap-local-xmlns) + (soap-default-xmlns, soap-target-xmlns, soap-multi-refs) + (soap-decoded-multi-refs, soap-current-wsdl) + (soap-encoded-namespaces): Rename CL-style *...* variables. + +2011-02-16 Michael Albinus <michael.albinus@gmx.de> + + * net/soap-client.el: Add "comm" and "hypermedia" to the + keywords. Reflow too long lines. + + * net/soap-inspect.el: Ditto. Require 'cl. + +2011-02-16 Bastien Guerry <bzg@altern.org> + + * play/doctor.el (doctor-mode): Bugfix: escape the "," character + in a `doctor-type' argument. + +2011-02-16 Alex Harsanyi <AlexHarsanyi@gmail.com> + + * net/soap-client.el: + * net/soap-inspect.el: New files. + +2011-02-16 Leo <sdl.web@gmail.com> + + * dired-x.el (dired-mode-map, dired-extra-startup): + Remove dired-copy-filename-as-kill since it's already in dired.el. + +2011-02-16 Glenn Morris <rgm@gnu.org> + + * dired-x.el (dired-bind-jump, dired-bind-man, dired-bind-info): + Doc fixes. Add :set property, replacing top-level calls. + (dired-vm-read-only-folders, dired-vm): Doc fix (drop v. old VM 4). + (dired-guess-shell-gnutar): Test tar version rather than system-type. + (dired-extra-startup, dired-man, dired-info): Doc fixes. + (dired-clean-up-after-deletion): Use when and dolist. + (dired-jump): Use unless and when. + (dired-virtual): Use line-end-position. + (dired-default-directory-alist): Rename from default-directory-alist. + (dired-default-directory): Update for above name change. + (dired-vm): Drop VM < 5 and simplify. + (dired-buffer-more-recently-used-p): Rewrite. + (dired-filename-at-point): Use when and or. + (dired-x-read-filename-at-point): Rename from read-filename-at-point. + Update callers. + 2011-02-15 Glenn Morris <rgm@gnu.org> * dired-x.el: Use easymenu for menu items. Fix item capitalization. diff --git a/lisp/allout-widgets.el b/lisp/allout-widgets.el new file mode 100644 index 00000000000..75e1e5882f6 --- /dev/null +++ b/lisp/allout-widgets.el @@ -0,0 +1,2365 @@ +;; allout-widgets.el --- Show allout outline structure with graphical widgets. + +;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011 Ken Manheimer + +;; Author: Ken Manheimer <ken dot manheimer at gmail dot com> +;; Maintainer: Ken Manheimer <ken dot manheimer at gmail dot com> +;; Version: 1.0 +;; Created: Dec 2005 +;; Version: 1.0 +;; Keywords: outlines +;; Website: http://myriadicity.net/Sundry/EmacsAllout + +;;; Commentary: + +;; This is an allout outline-mode add-on that highlights outline structure +;; with graphical widgets. +;; +;; To activate, customize `allout-widgets-auto-activation'. You can also +;; invoke allout-widgets-mode in a particular allout buffer. When +;; auto-enabled, you can inhibit widget operation in particular allout +;; buffers by setting the variable `allout-widgets-mode-inhibit' non-nil in +;; that file's buffer. Use emacs *file local variables* to generally +;; inhibit for a file. +;; +;; See the `allout-widgets-mode' docstring for more details. +;; +;; Info about allout and allout-widgets development are available at +;; http://myriadicity.net/Sundry/EmacsAllout +;; +;; The graphics include: +;; +;; - icons for item bullets, varying to distinguish whether the item either +;; lacks any subitems, the subitems are currently collapsed within the +;; item, or the item is currently expanded. +;; +;; - guide lines connecting item bullet-icons with those of their subitems. +;; +;; - cue area between the bullet-icon and the start of the body headline, +;; for item numbering, encryption indicator, and distinctive bullets. +;; +;; The bullet-icon and guide line graphics provide keybindings and mouse +;; bindings for easy outline navigation and exposure control, extending +;; outline hot-spot navigation (see `allout-mode' docstring for details). +;; +;; Developers note: Our use of emacs widgets is unconventional. We +;; decorate existing text rather than substituting for it, to +;; piggy-back on existing allout operation. This employs the C-coded +;; efficiencies of widget-apply, widget-get, and widget-put, along +;; with the basic object-oriented organization of widget-create, to +;; systematically couple overlays, graphics, and other features with +;; allout-governed text. + +;;;_: Code (structured with comments that delinieate an allout outline) + +;;;_ : General Environment +(require 'allout) +(require 'widget) +(require 'wid-edit) + +(eval-when-compile + (progn + (require 'overlay) + (require 'cl) + )) + +;;;_ : internal variables needed before user-customization variables +;;; In order to enable activation of allout-widgets-mode via customization, +;;; allout-widgets-auto-activation uses a setting function. That function +;;; is invoked when the customization variable definition is evaluated, +;;; during file load, so the involved code must reside above that +;;; definition in the file. +;;;_ = allout-widgets-mode +(defvar allout-widgets-mode nil + "Allout mode enhanced with graphical widgets.") +(make-variable-buffer-local 'allout-widgets-mode) + +;;;_ : USER CUSTOMIZATION VARIABLES and incidental functions: +;;;_ > defgroup allout-widgets +;;;###autoload +(defgroup allout-widgets nil + "Allout extension that highlights outline structure graphically. + +Customize `allout-widgets-auto-activation' to activate allout-widgets +with allout-mode." + :group 'allout) +;;;_ > defgroup allout-widgets-developer +(defgroup allout-widgets-developer nil + "Settings for development of allout widgets extension." + :group 'allout-widgets) +;;;_ ; some functions a bit early, for allout-auto-activation dependency: +;;;_ > allout-widgets-mode-enable +(defun allout-widgets-mode-enable () + "Enable allout-widgets-mode in allout-mode buffers. + +See `allout-widgets-mode-inhibit' for per-file/per-buffer +inhibition of allout-widgets-mode." + (add-hook 'allout-mode-off-hook 'allout-widgets-mode-off) + (add-hook 'allout-mode-on-hook 'allout-widgets-mode-on) + t) +;;;_ > allout-widgets-mode-disable +(defun allout-widgets-mode-disable () + "Disable allout-widgets-mode in allout-mode buffers. + +See `allout-widgets-mode-inhibit' for per-file/per-buffer +inhibition of allout-widgets-mode." + (remove-hook 'allout-mode-off-hook 'allout-widgets-mode-off) + (remove-hook 'allout-mode-on-hook 'allout-widgets-mode-on) + t) +;;;_ > allout-widgets-setup (varname value) +;;;###autoload +(defun allout-widgets-setup (varname value) + "Commission or decommision allout-widgets-mode along with allout-mode. + +Meant to be used by customization of `allout-widgets-auto-activation'." + (set-default varname value) + (if allout-widgets-auto-activation + (allout-widgets-mode-enable) + (allout-widgets-mode-disable))) +;;;_ = allout-widgets-auto-activation +;;;###autoload +(defcustom allout-widgets-auto-activation nil + "Activate to enable allout icon graphics wherever allout mode is active. + +Also enable `allout-auto-activation' for this to take effect upon +visiting an outline. + +When this is set you can disable allout widgets in select files +by setting `allout-widgets-mode-inhibit' + +Instead of setting `allout-widgets-auto-activation' you can +explicitly invoke `allout-widgets-mode' in allout buffers where +you want allout widgets operation. + +See `allout-widgets-mode' for allout widgets mode features." + :type 'boolean + :group 'allout-widgets + :set 'allout-widgets-setup + ) +;; ;;;_ = allout-widgets-allow-unruly-edits +;; (defcustom allout-widgets-allow-unruly-edits nil +;; "*Control whether manual edits are restricted to maintain outline integrity. + +;; When nil, manual edits must either be within an item's body or encompass +;; one or more items completely - eg, killing topics as entities, rather than +;; deleting from the middle of one to the middle of another. + +;; If you only occasionally need to make unrestricted change, you can set this +;; variable in the specific buffer using set-variable, or just deactivate +;; `allout-mode' temporarily. You can customize this to always allow unruly +;; edits, but you will be able to create outlines that are unnavigable in +;; principle, and not just for allout's navigation and exposure mechanisms." +;; :type 'boolean +;; :group allout-widgets) +;; (make-variable-buffer-local 'allout-widgets-allow-unruly-edits) +;;;_ = allout-widgets-auto-activation - below, for eval-order dependencies +;;;_ = allout-widgets-icons-dark-subdir +(defcustom allout-widgets-icons-dark-subdir "icons/allout-widgets/dark-bg/" + "Directory on `image-load-path' holding allout icons for dark backgrounds." + :type 'string + :group 'allout-widgets) +;;;_ = allout-widgets-icons-light-subdir +(defcustom allout-widgets-icons-light-subdir "icons/allout-widgets/light-bg/" + "Directory on `image-load-path' holding allout icons for light backgrounds." + :type 'string + :group 'allout-widgets) +;;;_ = allout-widgets-icon-types +(defcustom allout-widgets-icon-types '(xpm png) + "File extensions for the icon graphic format types, in order of preference." + :type '(repeat symbol) + :group 'allout-widgets) + +;;;_ . Decoration format +;;;_ = allout-widgets-theme-dark-background +(defcustom allout-widgets-theme-dark-background "allout-dark-bg" + "Identify the outline's icon theme to use with a dark background." + :type '(string) + :group 'allout-widgets) +;;;_ = allout-widgets-theme-light-background +(defcustom allout-widgets-theme-light-background "allout-light-bg" + "Identify the outline's icon theme to use with a light background." + :type '(string) + :group 'allout-widgets) +;;;_ = allout-widgets-item-image-properties-emacs +(defcustom allout-widgets-item-image-properties-emacs + '(:ascent center :mask (heuristic t)) + "*Default properties item widget images in mainline Emacs." + :type 'plist + :group 'allout-widgets) +;;;_ = allout-widgets-item-image-properties-xemacs +(defcustom allout-widgets-item-image-properties-xemacs + nil + "*Default properties item widget images in XEmacs." + :type 'plist + :group 'allout-widgets) +;;;_ . Developer +;;;_ = allout-widgets-run-unit-tests-on-load +(defcustom allout-widgets-run-unit-tests-on-load nil + "*When non-nil, unit tests will be run at end of loading allout-widgets. + +Generally, allout widgets code developers are the only ones who'll want to +set this. + +\(If set, this makes it an even better practice to exercise changes by +doing byte-compilation with a repeat count, so the file is loaded after +compilation.) + +See `allout-widgets-run-unit-tests' to see what's run." + :type 'boolean + :group 'allout-widgets-developer) +;;;_ = allout-widgets-time-decoration-activity +(defcustom allout-widgets-time-decoration-activity nil + "*Retain timing info of the last cooperative redecoration. + +The details are retained as the value of +`allout-widgets-last-decoration-timing'. + +Generally, allout widgets code developers are the only ones who'll want to +set this." + :type 'boolean + :group 'allout-widgets-developer) +;;;_ = allout-widgets-hook-error-post-time 0 +(defcustom allout-widgets-hook-error-post-time 0 + "*Amount of time to sit showing hook error messages. + +0 is minimal, or nil to not post to the message area. + +This is for debugging purposes." + :type 'integer + :group 'allout-widgets-developer) +;;;_ = allout-widgets-maintain-tally nil +(defcustom allout-widgets-maintain-tally nil + "*If non-nil, maintain a collection of widgets, `allout-widgets-tally'. + +This is for debugging purposes. + +The tally shows the total number of item widgets in the current +buffer, and tracking increases as new widgets are added and +decreases as obsolete widgets are garbage collected." + :type 'boolean + :group 'allout-widgets-developer) +(defvar allout-widgets-tally nil + "Hash-table of existing allout widgets, for debugging. + +Table is maintained iff `allout-widgets-maintain-tally' is non-nil. + +The table contents will be out of sync if any widgets are created +or deleted while this variable is nil.") +(make-variable-buffer-local 'allout-widgets-tally) +;;;_ > allout-widgets-tally-string +(defun allout-widgets-tally-string () + "Return a string giving the number of tracked widgets, or empty string if not tracking. + +The string is formed for appending to the allout-mode mode-line lighter. + +An empty string is also returned if tracking is inhibited or +widgets are locally inhibited. + +The number varies according to the evanescence of objects on a + hash table with weak keys, so tracking of widget erasures is often delayed." + (when (and allout-widgets-maintain-tally (not allout-widgets-mode-inhibit)) + (format ":%s" (hash-table-count allout-widgets-tally)))) +;;;_ = allout-widgets-track-decoration nil +(defcustom allout-widgets-track-decoration nil + "*If non-nil, show cursor position of each item decoration. + +This is for debugging purposes, and generally set at need in a +buffer rather than as a prevailing configuration \(but it's handy +to publicize it by making it a customization variable\)." + :type 'boolean + :group 'allout-widgets-developer) +(make-variable-buffer-local 'allout-widgets-track-decoration) + +;;;_ : Mode context - variables, hookup, and hooks +;;;_ . internal mode variables +;;;_ , Mode activation and environment +;;;_ = allout-widgets-version +(defvar allout-widgets-version "1.0" + "Version of currently loaded allout-widgets extension.") +;;;_ > allout-widgets-version +(defun allout-widgets-version (&optional here) + "Return string describing the loaded outline version." + (interactive "P") + (let ((msg (concat "Allout Outline Widgets Extension v " + allout-widgets-version))) + (if here (insert msg)) + (message "%s" msg) + msg)) +;;;_ = allout-widgets-mode-inhibit +(defvar allout-widgets-mode-inhibit nil + "Inhibit `allout-widgets-mode' from activating widgets. + +This also inhibits automatic adjustment of widgets to track allout outline +changes. + +You can use this as a file local variable setting to disable +allout widgets enhancements in selected buffers while generally +enabling widgets by customizing `allout-widgets-auto-activation'. + +In addition, you can invoked `allout-widgets-mode' allout-mode +buffers where this is set to enable and disable widget +enhancements, directly.") +;;;###autoload +(put 'allout-widgets-mode-inhibit 'safe-local-variable + (if (fboundp 'booleanp) 'booleanp '(lambda (x) (member x '(t nil))))) +(make-variable-buffer-local 'allout-widgets-mode-inhibit) +;;;_ = allout-inhibit-body-modification-hook +(defvar allout-inhibit-body-modification-hook nil + "Override de-escaping of text-prefixes in item bodies during specific changes. + +This is used by `allout-buffer-modification-handler' to signal such changes +to `allout-body-modification-handler', and is always reset by +`allout-post-command-business'.") +(make-variable-buffer-local 'allout-inhibit-body-modification-hook) +;;;_ = allout-widgets-icons-cache +(defvar allout-widgets-icons-cache nil + "Cache allout icon images, as an association list. + +`allout-fetch-icon-image' uses this cache transparently, keying +images with lists containing the name of the icon directory \(as +found on the `load-path') and the icon name. + +Set this variable to `nil' to empty the cache, and have it replenish from the +filesystem.") +;;;_ = allout-widgets-unset-inhibit-read-only +(defvar allout-widgets-unset-inhibit-read-only nil + "Tell `allout-widgets-post-command-business' to unset `inhibit-read-only'. + +Used by `allout-graphics-modification-handler'") +;;;_ = allout-widgets-reenable-before-change-handler +(defvar allout-widgets-reenable-before-change-handler nil + "Tell `allout-widgets-post-command-business' to reequip the handler. + +Necessary because the handler sometimes deliberately raises an +error, causing it to be disabled.") +;;;_ , State for hooks +;;;_ = allout-unresolved-body-mod-workroster +(defvar allout-unresolved-body-mod-workroster (make-hash-table :size 16) + "List of body-overlays that did before-change business but not after-change. + +See `allout-post-command-business' and `allout-body-modification-handler'.") +;;;_ = allout-structure-unruly-deletion-message +(defvar allout-structure-unruly-deletion-message + "Unruly edit prevented -- +To change the bullet character: \\[allout-rebullet-current-heading] +To promote this item: \\[allout-shift-out] +To demote it: \\[allout-shift-in] +To delete it and offspring: \\[allout-kill-topic] +See \\[describe-mode] for many more options." + "Informative message presented on improper editing of outline structure. + +The structure includes the guides lines, bullet, and bullet cue.") +;;;_ = allout-widgets-changes-record +(defvar allout-widgets-changes-record nil + "Record outline changes for processing by post-command hook. + +Entries on the list are lists whose first element is a symbol indicating +the change type and subsequent elements are data specific to that change +type. Specifically: + + 'exposure `allout-exposure-from' `allout-exposure-to' `allout-exposure-flag' + +The changes are recorded in reverse order, with new values pushed +onto the front.") +(make-variable-buffer-local 'allout-widgets-changes-record) +;;;_ = allout-widgets-undo-exposure-record +(defvar allout-widgets-undo-exposure-record nil + "Record outline undo traces for processing by post-command hook. + +The changes are recorded in reverse order, with new values pushed +onto the front.") +(make-variable-buffer-local 'allout-widgets-undo-exposure-record) +;;;_ = allout-widgets-last-hook-error +(defvar allout-widgets-last-hook-error nil + "String holding last error string, for debugging purposes.") +;;;_ = allout-widgets-adjust-message-length-threshold 100 +(defvar allout-widgets-adjust-message-length-threshold 100 + "Display \"Adjusting widgets\" message above this number of pending changes." + ) +;;;_ = allout-widgets-adjust-message-size-threshold 10000 +(defvar allout-widgets-adjust-message-size-threshold 10000 + "Display \"Adjusting widgets\" message above this size of pending changes." + ) +;;;_ = allout-doing-exposure-undo-processor nil +(defvar allout-undo-exposure-in-progress nil + "Maintained true during `allout-widgets-exposure-undo-processor'") +;;;_ , Widget-specific outline text format +;;;_ = allout-escaped-prefix-regexp +(defvar allout-escaped-prefix-regexp "" + "*Regular expression for body text that would look like an item prefix if +not altered with an escape sequence.") +(make-variable-buffer-local 'allout-escaped-prefix-regexp) +;;;_ , Widget element formatting +;;;_ = allout-item-icon-keymap +(defvar allout-item-icon-keymap + (let ((km (make-sparse-keymap))) + (dolist (digit '("0" "1" "2" "3" + "4" "5" "6" "7" "8" "9")) + (define-key km digit 'digit-argument)) + (define-key km "-" 'negative-argument) +;; (define-key km [(return)] 'allout-tree-expand-command) +;; (define-key km [(meta return)] 'allout-toggle-torso-command) +;; (define-key km [(down-mouse-1)] 'allout-item-button-click) +;; (define-key km [(down-mouse-2)] 'allout-toggle-torso-event-command) + ;; Override underlying mouse-1 and mouse-2 bindings in icon territory: + (define-key km [(mouse-1)] (lambda () (interactive) nil)) + (define-key km [(mouse-2)] (lambda () (interactive) nil)) + + ;; Catchall, handles actual keybindings, dynamically doing keymap lookups: + (define-key km [t] 'allout-item-icon-key-handler) + + km) + "General tree-node key bindings.") +;;;_ = allout-item-body-keymap +(defvar allout-item-body-keymap + (let ((km (make-sparse-keymap)) + (local-map (current-local-map))) +;; (define-key km [(control return)] 'allout-tree-expand-command) +;; (define-key km [(meta return)] 'allout-toggle-torso-command) + ;; XXX We need to reset this per buffer's mode; we do so in + ;; allout-widgets-mode. + (if local-map + (set-keymap-parent km local-map)) + + km) + "General key bindings for the text content of outline items.") +(make-variable-buffer-local 'allout-item-body-keymap) +;;;_ = allout-body-span-category +(defvar allout-body-span-category nil + "Symbol carrying allout body-text overlay properties.") +;;;_ = allout-cue-span-keymap +(defvar allout-cue-span-keymap + (let ((km (make-sparse-keymap))) + (set-keymap-parent km allout-item-icon-keymap) + km) + "Keymap used in the item cue area - the space between the icon and headline.") +;;;_ = allout-escapes-category +(defvar allout-escapes-category nil + "Symbol for category of text property used to hide escapes of prefix-like +text in allout item bodies.") +;;;_ = allout-guides-category +(defvar allout-guides-category nil + "Symbol carrying allout icon-guides overlay properties.") +;;;_ = allout-guides-span-category +(defvar allout-guides-span-category nil + "Symbol carrying allout icon and guide lines overlay properties.") +;;;_ = allout-icon-span-category +(defvar allout-icon-span-category nil + "Symbol carrying allout icon and guide lines overlay properties.") +;;;_ = allout-cue-span-category +(defvar allout-cue-span-category nil + "Symbol carrying common properties of the space following the outline icon. + +\(That space is used to convey selected cues indicating body qualities, +including things like: + - encryption '~' + - numbering '#' + - indirect reference '@' + - distinctive bullets - see `allout-distinctive-bullets-string'.\)") +;;;_ = allout-span-to-category +(defvar allout-span-to-category + '((:guides-span . allout-guides-span-category) + (:cue-span . allout-cue-span-category) + (:icon-span . allout-icon-span-category) + (:body-span . allout-body-span-category)) + "Association list mapping span identifier to category identifier.") +;;;_ = allout-trailing-category +(defvar allout-trailing-category nil + "Symbol carrying common properties of an overlay's trailing newline.") +;;;_ , Developer +(defvar allout-widgets-last-decoration-timing nil + "Timing details for the last cooperative decoration action. + +This is maintained when `allout-widgets-time-decoration-activity' is set. + +The value is a list containing two elements: + - the elapsed time as a number of seconds + - the list of changes processed, a la `allout-widgets-changes-record'. + +When active, the value is revised each time automatic decoration activity +happens in the buffer.") +(make-variable-buffer-local 'allout-widgets-last-decoration-timing) +;;;_ . mode hookup +;;;_ > define-minor-mode allout-widgets-mode (arg) +;;;###autoload +(define-minor-mode allout-widgets-mode + "Allout-mode extension, providing graphical decoration of outline structure. + +This is meant to operate along with allout-mode, via `allout-mode-hook'. + +If optional argument ARG is greater than 0, enable. +If optional argument ARG is less than 0, disable. +Anything else, toggle between active and inactive. + +The graphics include: + +- guide lines connecting item bullet-icons with those of their subitems. + +- icons for item bullets, varying to indicate whether or not the item + has subitems, and if so, whether or not the item is expanded. + +- cue area between the bullet-icon and the start of the body headline, + for item numbering, encryption indicator, and distinctive bullets. + +The bullet-icon and guide line graphics provide keybindings and mouse +bindings for easy outline navigation and exposure control, extending +outline hot-spot navigation \(see `allout-mode')." + + :lighter nil + :keymap nil + + ;; define-minor-mode handles any provided argument according to emacs + ;; minor-mode conventions - '(elisp) Minor Mode Conventions' - and sets + ;; allout-widgets-mode accordingly *before* running the body code, so we + ;; cue on that. + (if allout-widgets-mode + ;; Activating: + (progn + (allout-add-resumptions + ;; XXX user may need say in line-truncation/hscrolling - an option + ;; that abstracts mode. + ;; truncate text lines to keep guide lines intact: + '(truncate-lines t) + ;; and enable autoscrolling to ease view of text + '(auto-hscroll-mode t) + '(line-move-ignore-fields t) + '(widget-push-button-prefix "") + '(widget-push-button-suffix "") + ;; allout-escaped-prefix-regexp depends on allout-regexp: + (list 'allout-escaped-prefix-regexp (concat "\\(\\\\\\)" + "\\(" allout-regexp "\\)"))) + (allout-add-resumptions + (list 'allout-widgets-tally allout-widgets-tally) + (list 'allout-widgets-escapes-sanitization-regexp-pair + (list (concat "\\(\n\\|\\`\\)" + allout-escaped-prefix-regexp + ) + ;; Include everything but the escape symbol. + "\\1\\3")) + ) + + (add-hook 'after-change-functions 'allout-widgets-after-change-handler + nil t) + + (allout-setup-text-properties) + (add-to-invisibility-spec '(allout-torso . t)) + (add-to-invisibility-spec 'allout-escapes) + + (if (current-local-map) + (set-keymap-parent allout-item-body-keymap (current-local-map))) + + (add-hook 'allout-exposure-change-hook + 'allout-widgets-exposure-change-recorder nil 'local) + (add-hook 'allout-structure-added-hook + 'allout-widgets-additions-recorder nil 'local) + (add-hook 'allout-structure-deleted-hook + 'allout-widgets-deletions-recorder nil 'local) + (add-hook 'allout-structure-shifted-hook + 'allout-widgets-shifts-recorder nil 'local) + (add-hook 'allout-after-copy-or-kill-hook + 'allout-widgets-after-copy-or-kill-function nil 'local) + + (add-hook 'before-change-functions 'allout-widgets-before-change-handler + nil 'local) + (add-hook 'post-command-hook 'allout-widgets-post-command-business + nil 'local) + (add-hook 'pre-command-hook 'allout-widgets-pre-command-business + nil 'local) + + ;; init the widgets tally for debugging: + (if (not allout-widgets-tally) + (setq allout-widgets-tally (make-hash-table + :test 'eq :weakness 'key))) + ;; add tally count display on minor-mode-alist just after + ;; allout-mode entry. + ;; (we use ternary condition form to keep condition simple for deletion.) + (let* ((mode-line-entry '(allout-widgets-mode-inhibit "" + (:eval (allout-widgets-tally-string)))) + (associated (assoc (car mode-line-entry) minor-mode-alist)) + ;; need location for it only if not already present: + (after (and (not associated) + (memq (assq 'allout-mode minor-mode-alist) minor-mode-alist)))) + (if after + (rplacd after (cons mode-line-entry (cdr after))))) + (allout-widgets-prepopulate-buffer) + t) + ;; Deactivating: + (let ((inhibit-read-only t) + (was-modified (buffer-modified-p))) + + (allout-widgets-undecorate-region (point-min)(point-max)) + (remove-from-invisibility-spec '(allout-torso . t)) + (remove-from-invisibility-spec 'allout-escapes) + + (remove-hook 'after-change-functions + 'allout-widgets-after-change-handler 'local) + (remove-hook 'allout-exposure-change-hook + 'allout-widgets-exposure-change-recorder 'local) + (remove-hook 'allout-structure-added-hook + 'allout-widgets-additions-recorder 'local) + (remove-hook 'allout-structure-deleted-hook + 'allout-widgets-deletions-recorder 'local) + (remove-hook 'allout-structure-shifted-hook + 'allout-widgets-shifts-recorder 'local) + (remove-hook 'allout-after-copy-or-kill-hook + 'allout-widgets-after-copy-or-kill-function 'local) + (remove-hook 'before-change-functions + 'allout-widgets-before-change-handler 'local) + (remove-hook 'post-command-hook + 'allout-widgets-post-command-business 'local) + (remove-hook 'pre-command-hook + 'allout-widgets-pre-command-business 'local) + (assq-delete-all 'allout-widgets-mode-inhibit minor-mode-alist) + (set-buffer-modified-p was-modified)))) +;;;_ > allout-widgets-mode-off +(defun allout-widgets-mode-off () + "Explicitly disable allout-widgets-mode." + (allout-widgets-mode -1)) +;;;_ > allout-widgets-mode-off +(defun allout-widgets-mode-on () + "Explicitly disable allout-widgets-mode." + (allout-widgets-mode 1)) +;;;_ > allout-setup-text-properties () +(defun allout-setup-text-properties () + "Configure category and literal text properties." + + ;; XXX body - before-change, entry, keymap + + (setplist 'allout-guides-span-category nil) + (put 'allout-guides-span-category + 'modification-hooks '(allout-graphics-modification-handler)) + (put 'allout-guides-span-category 'local-map allout-item-icon-keymap) + (put 'allout-guides-span-category 'mouse-face widget-button-face) + (put 'allout-guides-span-category 'field 'structure) +;; (put 'allout-guides-span-category 'face 'widget-button) + + (setplist 'allout-icon-span-category + (allout-widgets-copy-list (symbol-plist + 'allout-guides-span-category))) + (put 'allout-icon-span-category 'field 'structure) + + ;; XXX for body text we're instead going to use the buffer-wide + ;; resources, like before/after-change-functions hooks and the + ;; buffer's key map. that way we won't have to do painful provisions + ;; to fixup things after edits, catch outlier interstitial + ;; characters, like newline and empty lines after hidden subitems, + ;; etc. + (setplist 'allout-body-span-category nil) + (put 'allout-body-span-category 'evaporate t) + (put 'allout-body-span-category 'local-map allout-item-body-keymap) + ;;(put 'allout-body-span-category + ;; 'modification-hooks '(allout-body-modification-handler)) + ;;(put 'allout-body-span-category 'field 'body) + + (setplist 'allout-cue-span-category nil) + (put 'allout-cue-span-category 'evaporate t) + (put 'allout-cue-span-category + 'modification-hooks '(allout-body-modification-handler)) + (put 'allout-cue-span-category 'local-map allout-cue-span-keymap) + (put 'allout-cue-span-category 'mouse-face widget-button-face) + (put 'allout-cue-span-category 'pointer 'arrow) + (put 'allout-cue-span-category 'field 'structure) + + (setplist 'allout-trailing-category nil) + (put 'allout-trailing-category 'evaporate t) + (put 'allout-trailing-category 'local-map allout-item-body-keymap) + + (setplist 'allout-escapes-category nil) + (put 'allout-escapes-category 'invisible 'allout-escapes) + (put 'allout-escapes-category 'evaporate t)) +;;;_ > allout-widgets-prepopulate-buffer () +(defun allout-widgets-prepopulate-buffer () + "Step over the current buffers exposed items to do initial widgetizing." + (if (not allout-widgets-mode-inhibit) + (save-excursion + (goto-char (point-min)) + (while (allout-next-visible-heading 1) + (when (not (widget-at (point))) + (allout-get-or-create-item-widget)))))) +;;;_ . settings context +;;;_ = allout-container-item +(defvar allout-container-item-widget nil + "A widget for the current outline's overarching container as an item. + +The item has settings \(of the file/connection\) and maybe a body, but no +icon/bullet.") +(make-variable-buffer-local 'allout-container-item-widget) +;;;_ . Hooks and hook helpers +;;;_ , major command-loop business: +;;;_ > allout-widgets-pre-command-business (&optional recursing) +(defun allout-widgets-pre-command-business (&optional recursing) + "Handle actions pending before allout-mode activity." +) +;;;_ > allout-widgets-post-command-business (&optional recursing) +(defun allout-widgets-post-command-business (&optional recursing) + "Handle actions pending after any allout-mode commands. + +Optional RECURSING is for internal use, to limit recursion." + ;; - check changed text for nesting discontinuities and escape anything + ;; that's: (1) asterisks at bol or (2) excessively nested. + (condition-case failure + + (when (and (boundp 'allout-mode) allout-mode) + + (if allout-widgets-unset-inhibit-read-only + (setq inhibit-read-only nil + allout-widgets-unset-inhibit-read-only nil)) + + (when allout-widgets-reenable-before-change-handler + (add-hook 'before-change-functions + 'allout-widgets-before-change-handler + nil 'local) + (setq allout-widgets-reenable-before-change-handler nil)) + + (when (or allout-widgets-undo-exposure-record + allout-widgets-changes-record) + (let* ((debug-on-signal t) + (debug-on-error t) + ;; inhibit recording new undo records when processing + ;; effects of undo-exposure: + (debugger 'allout-widgets-hook-error-handler) + (adjusting-message " Adjusting widgets...") + (replaced-message (allout-widgets-adjusting-message + adjusting-message)) + (start-time (current-time))) + + (if allout-widgets-undo-exposure-record + ;; inhibit undo recording iff undoing exposure stuff. + ;; XXX we might need to inhibit per respective + ;; change-record, rather than assuming that some undo + ;; activity during a command is all undo activity. + (let ((buffer-undo-list t)) + (allout-widgets-exposure-undo-processor) + (allout-widgets-changes-dispatcher)) + (allout-widgets-exposure-undo-processor) + (allout-widgets-changes-dispatcher)) + + (if allout-widgets-time-decoration-activity + (setq allout-widgets-last-decoration-timing + (list (allout-elapsed-time-seconds (current-time) + start-time) + allout-widgets-changes-record))) + + (setq allout-widgets-changes-record nil) + + (if replaced-message + (if (stringp replaced-message) + (message replaced-message) + (message ""))))) + + ;; Detect undecorated items, eg during isearch into previously + ;; unexposed topics, and decorate "economically". Some + ;; undecorated stuff is often exposed, to reduce lag, but the + ;; item containing the cursor is decorated. We constrain + ;; recursion to avoid being trapped by unexpectedly undecoratable + ;; items. + (when (and (not recursing) + (not (allout-current-decorated-p)) + (or (not (equal (allout-depth) 0)) + (not allout-container-item-widget))) + (let ((buffer-undo-list t)) + (allout-widgets-exposure-change-recorder + allout-recent-prefix-beginning allout-recent-prefix-end nil) + (allout-widgets-post-command-business 'recursing))) + + ;; Detect and rectify fouled outline structure - decorated item + ;; not at beginning of line. + (let ((this-widget (or (widget-at (point)) + ;; XXX we really should be checking across + ;; edited span, not just point and point+1 + (and (not (eq (point) (point-max))) + (widget-at (1+ (point)))))) + inserted-at) + (save-excursion + (if (and this-widget + (goto-char (widget-get this-widget :from)) + (not (bolp))) + (if (not + (condition-case err + (yes-or-no-p + (concat "Misplaced item won't be recognizable " + " as part of outline - rectify? ")) + (quit nil))) + (progn + (if (allout-hidden-p (max (1- (point)) 1)) + (save-excursion + (goto-char (max (1- (point)) 1)) + (allout-show-to-offshoot))) + (allout-widgets-undecorate-item this-widget)) + ;; expose any hidden intervening items, so resulting + ;; position is clear: + (setq inserted-at (point)) + (allout-unprotected (insert-before-markers "\n")) + (forward-char -1) + ;; ensure the inserted newline is visible: + (allout-flag-region inserted-at (1+ inserted-at) nil) + (allout-widgets-post-command-business 'recursing) + (message (concat "outline structure corrected - item" + " moved to beginning of new line")) + ;; preserve cursor position in some cases: + (if (and inserted-at + (> (point) inserted-at)) + (forward-char -1))))))) + + (error + ;; zero work list so we don't get stuck futily retrying. + ;; error recording done by allout-widgets-hook-error-handler. + (setq allout-widgets-changes-record nil)))) +;;;_ , major change handlers: +;;;_ > allout-widgets-before-change-handler +(defun allout-widgets-before-change-handler (beg end) + "Business to be done before changes in a widgetized allout outline." + ;; protect against unruly edits to structure: + (cond + (undo-in-progress (when (eq (get-text-property beg 'category) + 'allout-icon-span-category) + (save-excursion + (goto-char beg) + (let* ((item-widget (allout-get-item-widget))) + (if item-widget + (allout-widgets-exposure-undo-recorder + item-widget)))))) + (inhibit-read-only t) + ((not (and (boundp 'allout-mode) allout-mode)) t) + ((equal this-command 'quoted-insert) t) + ((not (text-property-any beg (if (equal end beg) + (min (1+ beg) (point-max)) + end) + 'field 'structure)) + t) + ((yes-or-no-p "Unruly edit of outline structure - allow? ") + (setq allout-widgets-unset-inhibit-read-only (not inhibit-read-only) + inhibit-read-only t)) + (t + ;; tell the allout-widgets-post-command-business to reestablish the hook: + (setq allout-widgets-reenable-before-change-handler t) + ;; and raise an error to prevent the edit (and disable the hook): + (error + (substitute-command-keys allout-structure-unruly-deletion-message))))) +;;;_ > allout-widgets-after-change-handler +(defun allout-widgets-after-change-handler (beg end prelength) + "Reconcile what needs to be reconciled for allout widgets after edits." + ) +;;;_ > allout-current-decorated-p () +(defun allout-current-decorated-p () + "True if the current item is not decorated" + (save-excursion + (if (allout-back-to-current-heading) + (if (> allout-recent-depth 0) + (and (allout-get-item-widget) t) + allout-container-item-widget)))) + +;;;_ > allout-widgets-hook-error-handler +(defun allout-widgets-hook-error-handler (mode args) + "Process errors which occurred in the course of command hook operation. + +We store a backtrace of the error information in the variable, +`allout-widgets-last-hook-error', unset the error handlers, and +reraise the error, so that processing continues to the +encompassing condition-case." + ;; first deconstruct special error environment so errors here propagate + ;; to encompassing condition-case: + (setq debugger 'debug + debug-on-error nil + debug-on-signal nil) + (let* ((bt (with-output-to-string (backtrace))) + (this "allout-widgets-hook-error-handler") + (header + (format "allout-widgets-last-hook-error stored, %s/%s %s %s" + this mode args + (format-time-string "%e-%b-%Y %r" (current-time))))) + ;; post to *Messages* then immediately replace with more compact notice: + (message "%s" (setq allout-widgets-last-hook-error + (format "%s:\n%s" header bt))) + (message header) (sit-for allout-widgets-hook-error-post-time) + ;; reraise the error, or one concerning this function if unexpected: + (if (equal mode 'error) + (apply 'signal args) + (error "%s: unexpected mode, %s %s" this mode args)))) +;;;_ > allout-widgets-changes-exceed-threshold-p () +(defun allout-widgets-adjusting-message (message) + "Post MESSAGE when pending are likely to make a big enough delay. + +If posting of the MESSAGE is warranted and there already is a +`current-message' in the minibuffer, the MESSAGE is appended to +the current one, and the previously pending `current-message' is +returned for later posting on completion. + +If posting of the MESSAGE is warranted, but no `current-message' +is pending, then t is returned to indicate that case. + +If posting of the MESSAGE is not warranted, then nil is returned. + +See `allout-widgets-adjust-message-length-threshold', +`allout-widgets-adjust-message-size-threshold' for message +posting threshold criteria." + (if (or (> (length allout-widgets-changes-record) + allout-widgets-adjust-message-length-threshold) + ;; for size, use distance from start of first to end of last: + (let ((min (point-max)) + (max 0) + first second) + (mapc (function (lambda (entry) + (if (eq :undone-exposure (car entry)) + nil + (setq first (cadr entry) + second (caddr entry)) + (if (< (min first second) min) + (setq min (min first second))) + (if (> (max first second) max) + (setq max (max first second)))))) + allout-widgets-changes-record) + (> (- max min) allout-widgets-adjust-message-size-threshold))) + (let ((prior (current-message))) + (message (if prior (concat prior " - " message) message)) + (or prior t)))) +;;;_ > allout-widgets-changes-dispatcher () +(defun allout-widgets-changes-dispatcher () + "Dispatch CHANGES-RECORD items to respective widgets change processors." + + (if (not allout-widgets-mode-inhibit) + (let* ((changes-record allout-widgets-changes-record) + (changes-pending (and changes-record t)) + entry + exposures + additions + deletions + shifts) + + (when changes-pending + (while changes-record + (setq entry (pop changes-record)) + (case (car entry) + (:exposed (push entry exposures)) + (:added (push entry additions)) + (:deleted (push entry deletions)) + (:shifted (push entry shifts)))) + + (if exposures + (allout-widgets-exposure-change-processor exposures)) + (if additions + (allout-widgets-additions-processor additions)) + (if deletions + (allout-widgets-deletions-processor deletions)) + (if shifts + (allout-widgets-shifts-processor shifts)))) + (when (not (equal allout-widgets-mode-inhibit 'undecorated)) + (allout-widgets-undecorate-region (point-min)(point-max)) + (setq allout-widgets-mode-inhibit 'undecorated)))) +;;;_ > allout-widgets-exposure-change-recorder (from to flag) +(defun allout-widgets-exposure-change-recorder (from to flag) + "Record allout exposure changes for tracking during post-command processing. + +Records changes in `allout-widgets-changes-record'." + (push (list :exposed from to flag) allout-widgets-changes-record)) +;;;_ > allout-widgets-exposure-change-processor (changes) +(defun allout-widgets-exposure-change-processor (changes) + "Widgetize and adjust item widgets tracking allout outline exposure changes. + +Generally invoked via `allout-exposure-change-hook'." + + (let ((changes (sort changes (function (lambda (this next) + (< (cadr this) (cadr next)))))) + ;; have to distinguish between concealing and exposing so that, eg, + ;; `allout-expose-topic's mix is handled properly. + handled-expose + handled-conceal + covered + deactivate-mark) + + (dolist (change changes) + (let (handling + (from (cadr change)) + bucket got + (to (caddr change)) + (flag (cadddr change)) + parent) + + ;; swap from and to: + (if (< to from) (setq bucket to + to from + from bucket)) + + ;; have we already handled exposure changes in this region? + (setq handling (if flag 'handled-conceal 'handled-expose) + got (allout-range-overlaps from to (symbol-value handling)) + covered (car got)) + (set handling (cadr got)) + + (when (not covered) + (save-excursion + (goto-char from) + (cond + + ;; collapsing: + (flag + (allout-widgets-undecorate-region from to) + (allout-beginning-of-current-line) + (let ((widget (allout-get-item-widget))) + (if (not widget) + (allout-get-or-create-item-widget) + (widget-apply widget :redecorate)))) + + ;; expanding: + (t + (while (< (point) to) + (allout-beginning-of-current-line) + (setq parent (allout-get-item-widget)) + (if (not parent) + (setq parent (allout-get-or-create-item-widget)) + (widget-apply parent :redecorate)) + (allout-next-visible-heading 1) + (if (widget-get parent :has-subitems) + (allout-redecorate-visible-subtree parent)) + (if (> (point) to) + ;; subtree may be well beyond to - incorporate in ranges: + (setq handled-expose + (allout-range-overlaps from (point) handled-expose) + covered (car handled-expose) + handled-expose (cadr handled-expose))) + (allout-next-visible-heading 1)))))))))) + +;;;_ > allout-widgets-additions-recorder (from to) +(defun allout-widgets-additions-recorder (from to) + "Record allout item additions for tracking during post-command processing. + +Intended for use on `allout-structure-added-hook'. + +FROM point at the start of the first new item and TO is point at the start +of the last one. + +Records changes in `allout-widgets-changes-record'." + (push (list :added from to) allout-widgets-changes-record)) +;;;_ > allout-widgets-additions-processor (changes) +(defun allout-widgets-additions-processor (changes) + "Widgetize and adjust items tracking allout outline structure additions. + +Dispatched by `allout-widgets-post-command-business' in response to +:added entries recorded by `allout-widgets-additions-recorder'." + (save-excursion + (let (handled + covered) + (dolist (change changes) + (let ((from (cadr change)) + bucket + (to (caddr change))) + (if (< to from) (setq bucket to to from from bucket)) + ;; have we already handled exposure changes in this region? + (setq handled (allout-range-overlaps from to handled) + covered (car handled) + handled (cadr handled)) + (when (not covered) + (goto-char from) + ;; Prior sibling and parent can both be affected. + (if (allout-ascend) + (allout-redecorate-visible-subtree + (allout-get-or-create-item-widget 'redecorate))) + (if (< (point) from) + (goto-char from)) + (while (and (< (point) to) (not (eobp))) + (allout-beginning-of-current-line) + (allout-redecorate-visible-subtree + (allout-get-or-create-item-widget)) + (allout-next-visible-heading 1)) + (if (> (point) to) + ;; subtree may be well beyond to - incorporate in ranges: + (setq handled (allout-range-overlaps from (point) handled) + covered (car handled) + handled (cadr handled))))))))) + +;;;_ > allout-widgets-deletions-recorder (depth from) +(defun allout-widgets-deletions-recorder (depth from) + "Record allout item deletions for tracking during post-command processing. + +Intended for use on `allout-structure-deleted-hook'. + +DEPTH is the depth of the deleted subtree, and FROM is the point from which +the subtree was deleted. + +Records changes in `allout-widgets-changes-record'." + (push (list :deleted depth from) allout-widgets-changes-record)) +;;;_ > allout-widgets-deletions-processor (changes) +(defun allout-widgets-deletions-processor (changes) + "Adjust items tracking allout outline structure deletions. + +Dispatched by `allout-widgets-post-command-business' in response to +:deleted entries recorded by `allout-widgets-deletions-recorder'." + (save-excursion + (dolist (change changes) + (let ((depth (cadr change)) + (from (caddr change))) + (goto-char from) + (when (allout-previous-visible-heading 1) + (if (> depth 1) + (allout-ascend-to-depth (1- depth))) + (allout-redecorate-visible-subtree + (allout-get-or-create-item-widget 'redecorate))))))) + +;;;_ > allout-widgets-shifts-recorder (shifted-amount at) +(defun allout-widgets-shifts-recorder (shifted-amount at) + "Record outline subtree shifts for tracking during post-command processing. + +Intended for use on `allout-structure-shifted-hook'. + +SHIFTED-AMOUNT is the depth change and AT is the point at the start of the +subtree that's been shifted. + +Records changes in `allout-widgets-changes-record'." + (push (list :shifted shifted-amount at) allout-widgets-changes-record)) +;;;_ > allout-widgets-shifts-processor (changes) +(defun allout-widgets-shifts-processor (changes) + "Widgetize and adjust items tracking allout outline structure additions. + +Dispatched by `allout-widgets-post-command-business' in response to +:shifted entries recorded by `allout-widgets-shifts-recorder'." + (save-excursion + (dolist (change changes) + (goto-char (caddr change)) + (allout-ascend) + (allout-redecorate-visible-subtree)))) +;;;_ > allout-widgets-after-copy-or-kill-function () +(defun allout-widgets-after-copy-or-kill-function () + "Do allout-widgets processing of text just placed in the kill ring. + +Intended for use on allout-after-copy-or-kill-hook." + (if (car kill-ring) + (setcar kill-ring (allout-widgets-undecorate-text (car kill-ring))))) + +;;;_ > allout-widgets-exposure-undo-recorder (widget from-state) +(defun allout-widgets-exposure-undo-recorder (widget) + "Record outline exposure undo for tracking during post-command processing. + +Intended for use by `allout-graphics-modification-handler'. + +WIDGET is the widget being changed. + +Records changes in `allout-widgets-changes-record'." + ;; disregard the events if we're currently processing them. + (if (not allout-undo-exposure-in-progress) + (push widget allout-widgets-undo-exposure-record))) +;;;_ > allout-widgets-exposure-undo-processor () +(defun allout-widgets-exposure-undo-processor () + "Adjust items tracking undo of allout outline structure exposure. + +Dispatched by `allout-widgets-post-command-business' in response to +:undone-exposure entries recorded by `allout-widgets-exposure-undo-recorder'." + (let* ((allout-undo-exposure-in-progress t) + ;; inhibit undo recording while twiddling exposure to track undo: + (widgets allout-widgets-undo-exposure-record) + widget widget-start-marker widget-end-marker + from-state icon-start-point to-state + handled covered) + (setq allout-widgets-undo-exposure-record nil) + (save-excursion + (dolist (widget widgets) + (setq widget-start-marker (widget-get widget :from) + widget-end-marker (widget-get widget :to) + from-state (widget-get widget :icon-state) + icon-start-point (widget-apply widget :actual-position + :icon-start) + to-state (get-text-property icon-start-point + :icon-state)) + (setq handled (allout-range-overlaps widget-start-marker + widget-end-marker + handled) + covered (car handled) + handled (cadr handled)) + (when (not covered) + (goto-char (widget-get widget :from)) + (when (not (allout-hidden-p)) + ;; adjust actual exposure to that of to-state viz from-state + (cond ((and (eq to-state 'closed) (eq from-state 'opened)) + (allout-hide-current-subtree) + (allout-decorate-item-and-context widget)) + ((and (eq to-state 'opened) (eq from-state 'closed)) + (save-excursion + (dolist + (expose-to (allout-chart-exposure-contour-by-icon)) + (goto-char expose-to) + (allout-show-to-offshoot))))))))))) +;;;_ > allout-chart-exposure-contour-by-icon (&optional from-depth) +(defun allout-chart-exposure-contour-by-icon (&optional from-depth) + "Return points of subtree items to which exposure should be extended. + +The qualifying items are ones with a widget icon that is in the closed or +empty state, or items with undecorated subitems. + +The resulting list of points is in reverse order. + +Optional FROM-DEPTH is for internal use." + ;; During internal recursion, we return a pair: (at-end . result) + ;; Otherwise we just return the result. + (let ((from-depth from-depth) + start-point + at-end level-depth + this-widget + got subgot) + (if from-depth + (setq level-depth (allout-depth)) + ;; at containing item: + (setq start-point (point)) + (setq from-depth (allout-depth)) + (setq at-end (not (allout-next-heading)) + level-depth allout-recent-depth)) + + ;; traverse the level, recursing on deeper levels: + (while (and (not at-end) + (> allout-recent-depth from-depth) + (setq this-widget (allout-get-item-widget))) + (if (< level-depth allout-recent-depth) + ;; recurse: + (progn + (setq subgot (allout-chart-exposure-contour-by-icon level-depth) + at-end (car subgot) + subgot (cdr subgot)) + (if subgot (setq got (append subgot got)))) + ;; progress at this level: + (when (memq (widget-get this-widget :icon-state) '(closed empty)) + (push (point) got) + (allout-end-of-subtree)) + (setq at-end (not (allout-next-heading))))) + + ;; tailor result depending on whether or not we're a recursion: + (if (not start-point) + (cons at-end got) + (goto-char start-point) + got))) +;;;_ > allout-range-overlaps (from to ranges) +(defun allout-range-overlaps (from to ranges) + "Return a pair indicating overlap of FROM and TO subtree range in RANGES. + +First element of result indicates whether candadate range FROM, TO +overlapped any of the existing ranges. + +Second element of result is a new version of RANGES incorporating the +candidate range with overlaps consolidated. + +FROM and TO must be in increasing order, as must be the pairs in RANGES." + ;; to append to the end: (rplacd next-to-last-cdr (list 'f)) + (let (new-ranges + entry + ;; the start of the range that includes the candidate from: + included-from + ;; the end of the range that includes the candidate to: + included-to + ;; the candidates were inserted: + done) + (while (and ranges (not done)) + (setq entry (car ranges) + ranges (cdr ranges)) + + (cond + + (included-from + ;; some entry included the candidate from. + (cond ((> (car entry) to) + ;; current entry exceeds end of candidate range - done. + (push (list included-from to) new-ranges) + (push entry new-ranges) + (setq included-to to + done t)) + ((>= (cadr entry) to) + ;; current entry includes end of candidate range - done. + (push (list included-from (cadr entry)) new-ranges) + (setq included-to (cadr entry) + done t)) + ;; current entry contained in candidate range - ditch, continue: + (t nil))) + + ((> (car entry) to) + ;; current entry start exceeds candidate end - done, placed as new entry + (push (list from to) new-ranges) + (push entry new-ranges) + (setq included-to to + done t)) + + ((>= (car entry) from) + ;; current entry start is above candidate start, but not above + ;; candidate end (by prior case). + (setq included-from from) + ;; now we have to check on whether this entry contains to, or continue: + (when (>= (cadr entry) to) + ;; current entry contains only candidate end - done: + (push (list included-from (cadr entry)) new-ranges) + (setq included-to (cadr entry) + done t)) + ;; otherwise, we will continue to look for placement of candidate end. + ) + + ((>= (cadr entry) to) + ;; current entry properly contains candidate range. + (push entry new-ranges) + (setq included-from (car entry) + included-to (cadr entry) + done t)) + + ((>= (cadr entry) from) + ;; current entry contains start of candidate range. + (setq included-from (car entry))) + + (t + ;; current entry is below the candidate range. + (push entry new-ranges)))) + + (cond ((and included-from included-to) + ;; candidates placed. + nil) + ((not (or included-from included-to)) + ;; candidates found no place, must be at the end: + (push (list from to) new-ranges)) + (included-from + ;; candidate start placed but end not: + (push (list included-from to) new-ranges)) + ;; might be included-to and not included-from, indicating new entry. + ) + (setq new-ranges (nreverse new-ranges)) + (if ranges (setq new-ranges (append new-ranges ranges))) + (list (if included-from t) new-ranges))) +;;;_ > allout-test-range-overlaps () +(defun allout-test-range-overlaps () + "allout-range-overlaps unit tests." + (let* (ranges + got + (try (lambda (from to) + (setq got (allout-range-overlaps from to ranges)) + (setq ranges (cadr got)) + got))) +;; ;; biggie: +;; (setq ranges nil) +;; ;; ~ .02 to .1 seconds for just repeated listing args instead of funcall +;; ;; ~ 13 seconds for doing repeated funcall +;; (message "time-trial: %s, resulting size %s" +;; (time-trial +;; '(let ((size 10000) +;; doing) +;; (random t) +;; (dotimes (count size) +;; (setq doing (random size)) +;; (funcall try doing (+ doing (random 5))) +;; ;;(list doing (+ doing (random 5))) +;; ))) +;; (length ranges)) +;; (sit-for 2) + + ;; fresh: + (setq ranges nil) + (assert (equal (funcall try 3 5) '(nil ((3 5))))) + ;; add range at end: + (assert (equal (funcall try 10 12) '(nil ((3 5) (10 12))))) + ;; add range at beginning: + (assert (equal (funcall try 1 2) '(nil ((1 2) (3 5) (10 12))))) + ;; insert range somewhere in the middle: + (assert (equal (funcall try 7 9) '(nil ((1 2) (3 5) (7 9) (10 12))))) + ;; consolidate some: + (assert (equal (funcall try 5 8) '(t ((1 2) (3 9) (10 12))))) + ;; add more: + (assert (equal (funcall try 15 17) '(nil ((1 2) (3 9) (10 12) (15 17))))) + ;; add more: + (assert (equal (funcall try 20 22) + '(nil ((1 2) (3 9) (10 12) (15 17) (20 22))))) + ;; encompass more: + (assert (equal (funcall try 4 11) '(t ((1 2) (3 12) (15 17) (20 22))))) + ;; encompass all: + (assert (equal (funcall try 2 25) '(t ((1 25))))) + + ;; fresh slate: + (setq ranges nil) + (assert (equal (funcall try 20 25) '(nil ((20 25))))) + (assert (equal (funcall try 30 35) '(nil ((20 25) (30 35))))) + (assert (equal (funcall try 26 28) '(nil ((20 25) (26 28) (30 35))))) + (assert (equal (funcall try 15 20) '(t ((15 25) (26 28) (30 35))))) + (assert (equal (funcall try 10 30) '(t ((10 35))))) + (assert (equal (funcall try 5 6) '(nil ((5 6) (10 35))))) + (assert (equal (funcall try 2 100) '(t ((2 100))))) + + (setq ranges nil) + )) +;;;_ > allout-widgetize-buffer (&optional doing) +(defun allout-widgetize-buffer (&optional doing) + "EXAMPLE FUNCTION. Widgetize items in buffer using allout-chart-subtree. + +We economize by just focusing on the first of local-maximum depth siblings. + +Optional DOING is for internal use - a chart of the current level, for +recursive operation." + + (interactive) + (if (not doing) + + (save-excursion + (goto-char (point-min)) + ;; Construct the chart by scanning the siblings: + (dolist (top-level-sibling (allout-chart-siblings)) + (goto-char top-level-sibling) + (let ((subchart (allout-chart-subtree))) + (if subchart + (allout-widgetize-buffer subchart))))) + + ;; save-excursion was done on recursion entry, not necessary here. + (let (have-sublists) + (dolist (sibling doing) + (when (listp sibling) + (setq have-sublists t) + (allout-widgetize-buffer sibling))) + (when (and (not have-sublists) (not (widget-at (car doing)))) + (goto-char (car doing)) + (allout-get-or-create-item-widget))))) + +;;;_ : Item widget and constructors + +;;;_ $ allout-item-widget +(define-widget 'allout-item-widget 'default + "A widget presenting an allout outline item." + + 'button nil + ;; widget-field-at respects this to get item if 'field is unused. + ;; we don't use field to avoid collision with end-of-line, etc, on which + ;; allout depends. + 'real-field nil + + ;; data fields: + + + ;; tailor the widget for a specific item + :create 'allout-decorate-item-and-context + :value-delete 'allout-widgets-undecorate-item + ;; Not Yet Converted (from original, tree-widget stab) + :expander 'allout-tree-event-dispatcher ; get children when nil :args + :expander-p 'identity ; always engage the :expander + :action 'allout-tree-widget-action + ;; :notify "when item changes" + + ;; force decoration of item but not context, unless already done this tick: + :redecorate 'allout-redecorate-item + :last-decorated-tick nil + ;; recognize the actual situation of the item's text: + :parse-item 'allout-parse-item-at-point + ;; decorate the entirety of the item, sans offspring: + :decorate-item-span 'allout-decorate-item-span + ;; decorate the various item elements: + :decorate-guides 'allout-decorate-item-guides + :decorate-icon 'allout-decorate-item-icon + :decorate-cue 'allout-decorate-item-cue + :decorate-body 'allout-decorate-item-body + :actual-position 'allout-item-actual-position + + ;; Layout parameters: + :is-container nil ; is this actually the encompassing file/connection? + + :from nil ; item beginning - marker + :to nil ; item end - marker + :span-overlay nil ; overlay by which actual postion is determined + + ;; also serves as guide-end: + :icon-start nil + :icon-end nil + :distinctive-start nil + ;; also serves as cue-start: + :distinctive-end nil + ;; also serves as cue-end: + :body-start nil + :body-end nil + :depth nil + :has-subitems nil + :was-has-subitems 'init + :expanded nil + :was-expanded 'init + :brief nil + :was-brief 'init + + :does-encrypt nil ; pending encryption when :is-encrypted false. + :is-encrypted nil + + ;; the actual location of the item text: + :location 'allout-item-location + + :button-keymap allout-item-icon-keymap ; XEmacs + :keymap allout-item-icon-keymap ; Emacs + + ;; Element regions: + :guides-span nil + :icon-span nil + :cue-span nil + :bullet nil + :was-bullet nil + :body-span nil + + :body-brevity-p 'allout-body-brevity-p + + ;; :guide-column-flags indicate (in reverse order) whether or not the + ;; item's ancestor at the depth corresponding to the column has a + ;; subsequent sibling - ie, whether or not the corresponding column needs + ;; a descender line to connect that ancestor with its sibling. + :guide-column-flags nil + :was-guide-column-flags 'init + + ;; ie, has subitems: + :populous-p 'allout-item-populous-p + :help-echo 'allout-tree-widget-help-echo + ) +;;;_ > allout-new-item-widget () +(defsubst allout-new-item-widget () + "create a new item widget, not yet situated anywhere." + (if allout-widgets-maintain-tally + ;; all the extra overhead is incurred only when doing the + ;; maintenance, except the condition, which can't be avoided. + (let ((widget (widget-convert 'allout-item-widget))) + (puthash widget nil allout-widgets-tally) + widget) + (widget-convert 'allout-item-widget))) +;;;_ : Item decoration +;;;_ > allout-decorate-item-and-context (item-widget &optional redecorate +;;; blank-container parent) +(defun allout-decorate-item-and-context (item-widget &optional redecorate + blank-container parent) + "Create or adjust widget decorations for ITEM-WIDGET and neighbors at point. + +The neighbors include its siblings and parent. + +ITEM-WIDGET can be a created or converted allout-item-widget. + +If you're only trying to get or create a widget for an item, use +`allout-get-or-create-item-widget'. If you have the item-widget, applying +:redecorate will do the right thing. + +Optional BLANK-CONTAINER is for internal use. It is used to fabricate a +container widget for an empty-bodied container, in the course of decorating +a proper \(non-container\) item which starts at the beginning of the file. + +Optional REDECORATE causes redecoration of the item-widget and +its siblings, even if already decorated in this cycle of the command loop. + +Optional PARENT, when provided, bypasses some navigation and computation +necessary to obtain the parent of the items being processed. + +We return the item-widget corresponding to the item at point." + + (when (or redecorate + (not (equal (widget-get item-widget :last-decorated-tick) + allout-command-counter))) + (let* ((allout-inhibit-body-modification-hook t) + (was-modified (buffer-modified-p)) + (was-point (point)) + prefix-start + (is-container (or blank-container + (not (setq prefix-start (allout-goto-prefix))) + (< was-point prefix-start))) + ;; steady-point (set in two steps) is reliable across parent + ;; widget-creation. + (steady-point (progn (if is-container (goto-char 1)) + (point-marker))) + (steady-point (progn (set-marker-insertion-type steady-point t) + steady-point)) + (parent (and (not is-container) + (allout-get-or-create-parent-widget))) + parent-flags parent-depth + successor-sibling + body + doing-item + sub-item-widget + depth + reverse-siblings-chart + (buffer-undo-list t)) + + ;; At this point the parent is decorated and parent-flags indicate + ;; its guide lines. We will iterate over the siblings according to a + ;; chart we create at the start, and going from last to first so we + ;; don't have to worry about text displacement caused by widgetizing. + + (if is-container + (progn (widget-put item-widget :is-container t) + (setq reverse-siblings-chart (list 1))) + (goto-char (widget-apply parent :actual-position :from)) + (if (widget-get parent :is-container) + ;; `allout-goto-prefix' will go to first non-container item: + (allout-goto-prefix) + (allout-next-heading)) + (setq depth (allout-recent-depth)) + (setq reverse-siblings-chart (list allout-recent-prefix-beginning)) + (while (allout-next-sibling) + (push allout-recent-prefix-beginning reverse-siblings-chart))) + + (dolist (doing-at reverse-siblings-chart) + (goto-char doing-at) + (when allout-widgets-track-decoration + (sit-for 0)) + + (setq doing-item (if (= doing-at steady-point) + item-widget + (or (allout-get-item-widget) + (allout-new-item-widget)))) + + (when (or redecorate (not (equal (widget-get doing-item + :last-decorated-tick) + allout-command-counter))) + (widget-apply doing-item :parse-item t blank-container) + (widget-apply doing-item :decorate-item-span) + + (widget-apply doing-item :decorate-guides + parent (and successor-sibling t)) + (widget-apply doing-item :decorate-icon) + (widget-apply doing-item :decorate-cue) + (widget-apply doing-item :decorate-body) + + (widget-put doing-item :last-decorated-tick allout-command-counter)) + + (setq successor-sibling doing-at)) + + (set-buffer-modified-p was-modified) + (goto-char steady-point) + ;; must null the marker or the buffer gets clogged with impedence: + (set-marker steady-point nil) + + item-widget))) +;;;_ > allout-redecorate-item (item) +(defun allout-redecorate-item (item-widget) + "Resituate ITEM-WIDGET decorations, disregarding context. + +Use this to redecorate only the item, when you know that it's +situation with respect to siblings, parent, and offspring is +unchanged from its last decoration. Use +`allout-decorate-item-and-context' instead to reassess and adjust +relevent context, when suitable." + (if (not (equal (widget-get item-widget :last-decorated-tick) + allout-command-counter)) + (let ((was-modified (buffer-modified-p)) + (buffer-undo-list t)) + (widget-apply item-widget :parse-item) + (widget-apply item-widget :decorate-guides) + (widget-apply item-widget :decorate-icon) + (widget-apply item-widget :decorate-cue) + (widget-apply item-widget :decorate-body) + (set-buffer-modified-p was-modified)))) +;;;_ > allout-redecorate-visible-subtree (&optional parent-widget +;;; depth chart) +(defun allout-redecorate-visible-subtree (&optional parent-widget depth chart) + "Redecorate all visible items in subtree at point. + +Optional PARENT-WIDGET is for optimization, when the parent +widget is already available. + +Optional DEPTH restricts the excursion depth of covered. + +Optional CHART is for internal recursion, to carry a chart of the +target items. + +Point is left at the last sibling in the visible subtree." + ;; using a treatment that takes care of all the siblings on a level, we + ;; only need apply it to the first sibling on the level, and we can + ;; collect and pass the parent of the lower levels to recursive calls as + ;; we go. + (let ((parent-widget + (if (and parent-widget (widget-apply parent-widget + :actual-position :from)) + (progn (goto-char (widget-apply parent-widget + :actual-position :from)) + parent-widget) + (let ((got (allout-get-item-widget))) + (if got + (allout-decorate-item-and-context got 'redecorate) + (allout-get-or-create-item-widget 'redecorate))))) + (pending-chart (or chart (allout-chart-subtree nil 'visible))) + item-widget + previous-sibling-point + previous-sibling + recent-sibling-point) + (setq pending-chart (nreverse pending-chart)) + (dolist (sibling-point pending-chart) + (cond ((integerp sibling-point) + (when (not previous-sibling-point) + (goto-char sibling-point) + (if (setq item-widget (allout-get-item-widget nil)) + (allout-decorate-item-and-context item-widget 'redecorate + nil parent-widget) + (allout-get-or-create-item-widget))) + (setq previous-sibling-point sibling-point + recent-sibling-point sibling-point)) + ((listp sibling-point) + (if (or (not depth) + (> depth 1)) + (allout-redecorate-visible-subtree + (if (not previous-sibling-point) + ;; containment discontinuity - sigh + parent-widget + (allout-get-or-create-item-widget 'redecorate)) + (if depth (1- depth)) + sibling-point))))) + (if (and recent-sibling-point (< (point) recent-sibling-point)) + (goto-char recent-sibling-point)))) +;;;_ > allout-parse-item-at-point (item-widget &optional at-beginning +;;; blank-container) +(defun allout-parse-item-at-point (item-widget &optional at-beginning + blank-container) + "Set widget ITEM-WIDGET layout parameters per item-at-point's actual layout. + +If optional AT-BEGINNING is t, then point is assumed to be at the start of +the item prefix. + +If optional BLANK-CONTAINER is true, then the parameters of a container +which has an empty body are set. \(Though the body is blank, the object +may have subitems.\)" + + ;; Uncomment this sit-for to notice where decoration is happening: +;; (sit-for .1) + (let* ((depth (allout-depth)) + (depth (if blank-container 0 depth)) + (is-container (or blank-container (zerop depth))) + + (does-encrypt (and (not is-container) + (allout-encrypted-type-prefix))) + (is-encrypted (and does-encrypt (allout-encrypted-topic-p))) + (icon-end allout-recent-prefix-end) + (icon-start (1- icon-end)) + body-start + body-end + bullet + has-subitems + (contents-depth (1+ depth)) + ) + (widget-put item-widget :depth depth) + (if is-container + + (progn + (widget-put item-widget :from (allout-set-boundary-marker + :from (point-min) + (widget-get item-widget :from))) + (widget-put item-widget :icon-end nil) + (widget-put item-widget :icon-start nil) + (setq body-start (widget-put item-widget :body-start 1))) + + ;; not container: + + (widget-put item-widget :from (allout-set-boundary-marker + :from (if at-beginning + (point) + allout-recent-prefix-beginning) + (widget-get item-widget :from))) + (widget-put item-widget :icon-start icon-start) + (widget-put item-widget :icon-end icon-end) + (when does-encrypt + (widget-put item-widget :does-encrypt t) + (widget-put item-widget :is-encrypted is-encrypted)) + + ;; cue area: + (setq body-start icon-end) + (widget-put item-widget :bullet (setq bullet (allout-get-bullet))) + (if (equal (char-after body-start) ? ) + (setq body-start (1+ body-start))) + (widget-put item-widget :body-start body-start) + ) + + ;; Both container and regular items: + + ;; :body-end (doesn't include a trailing blank line, if any) - + (widget-put item-widget :body-end (setq body-end + (if blank-container + 1 + (allout-end-of-entry)))) + + (widget-put item-widget :to (allout-set-boundary-marker + :to (if blank-container + (point-min) + (or (allout-pre-next-prefix) + (goto-char (point-max)))) + (widget-get item-widget :to))) + (widget-put item-widget :has-subitems + (setq has-subitems + (and + ;; has a subsequent item: + (not (= body-end (point-max))) + ;; subsequent item is deeper: + (< depth (setq contents-depth (allout-recent-depth)))))) + ;; note :expanded - true if widget item's content is currently visible? + (widget-put item-widget :expanded + (and has-subitems + ;; subsequent item is or isn't visible: + (save-excursion + (goto-char allout-recent-prefix-beginning) + (not (allout-hidden-p))))))) +;;;_ > allout-set-boundary-marker (boundary position &optional current-marker) +(defun allout-set-boundary-marker (boundary position &optional current-marker) + "Set or create item widget BOUNDARY type marker at POSITION. + +Optional CURRENT-MARKER is the marker currently being used for +the boundary, if any. + +BOUNDARY type is either :from or :to, determining the marker insertion type." + (if (not position) (setq position (point))) + (if current-marker + (set-marker current-marker position) + (let ((marker (make-marker))) + ;; XXX dang - would like for :from boundary to advance after inserted + ;; text, but that would omit new header prefixes when allout + ;; relevels, etc. this competes with ad-hoc edits, which would + ;; better be omitted + (set-marker-insertion-type marker nil) + (set-marker marker position)))) +;;;_ > allout-decorate-item-span (item-widget) +(defun allout-decorate-item-span (item-widget) + "Equip the item with a span, as an entirety. + +This span is implemented so it can be used to detect displacement +of the widget in absolute terms, and provides an offset bias for +the various element spans." + + (if (and (widget-get item-widget :is-container) + ;; the only case where the span could be empty. + (eq (widget-get item-widget :from) + (widget-get item-widget :to))) + nil + (allout-item-span item-widget + (widget-get item-widget :from) + (widget-get item-widget :to)))) +;;;_ > allout-decorate-item-guides (item-widget +;;; &optional parent-widget has-successor) +(defun allout-decorate-item-guides (item-widget + &optional parent-widget has-successor) + "Add ITEM-WIDGET guide icon-prefix descender and connector text properties. + +Optional arguments provide context for deriving the guides. In +their absence, the current guide column flags are used. + +Optional PARENT-WIDGET is the widget for the item's parent item. + +Optional HAS-SUCCESSOR is true iff the item is followed by a sibling. + +We also hide the header-prefix string. + +Guides are established according to the item-widget's :guide-column-flags, +when different than :was-guide-column-flags. Changing that property and +reapplying this method will rectify the glyphs." + + (when (not (widget-get item-widget :is-container)) + (let* ((depth (widget-get item-widget :depth)) + (parent-depth (and parent-widget + (widget-get parent-widget :depth))) + (parent-flags (and parent-widget + (widget-get parent-widget :guide-column-flags))) + (parent-flags-depth (length parent-flags)) + (extender-length (- depth (+ parent-flags-depth 2))) + (flags (or (and (> depth 1) + parent-widget + (widget-put item-widget :guide-column-flags + (append (list has-successor) + (if (< 0 extender-length) + (make-list extender-length + '-)) + parent-flags))) + (widget-get item-widget :guide-column-flags))) + (was-flags (widget-get item-widget :was-guide-column-flags)) + (guides-start (widget-get item-widget :from)) + (guides-end (widget-get item-widget :icon-start)) + (position guides-start) + (increment (length allout-header-prefix)) + reverse-flags + guide-name + extenders paint-extenders + (inhibit-read-only t)) + + (when (not (equal was-flags flags)) + + (setq reverse-flags (reverse flags)) + (while reverse-flags + (setq guide-name + (cond ((null (cdr reverse-flags)) + (if (car reverse-flags) + 'mid-connector + 'end-connector)) + ((eq (car reverse-flags) '-) + ;; accumulate extenders tally, to be painted on next + ;; non-extender flag, according to the flag type. + (setq extenders (1+ (or extenders 0))) + nil) + ((car reverse-flags) + 'through-descender) + (t 'skip-descender))) + (when guide-name + (put-text-property position (setq position (+ position increment)) + 'display (allout-fetch-icon-image guide-name)) + (if (> increment 1) (setq increment 1)) + (when extenders + ;; paint extenders after a connector, else leave spaces. + (dotimes (i extenders) + (put-text-property + position (setq position (1+ position)) + 'display (allout-fetch-icon-image + (if (memq guide-name '(mid-connector end-connector)) + 'extender-connector + 'skip-descender)))) + (setq extenders nil))) + (setq reverse-flags (cdr reverse-flags))) + (widget-put item-widget :was-guide-column-flags flags)) + + (allout-item-element-span-is item-widget :guides-span + guides-start guides-end)))) +;;;_ > allout-decorate-item-icon (item-widget) +(defun allout-decorate-item-icon (item-widget) + "Add item icon glyph and distinctive bullet text properties to ITEM-WIDGET." + + (when (not (widget-get item-widget :is-container)) + (let* ((icon-start (widget-get item-widget :icon-start)) + (icon-end (widget-get item-widget :icon-end)) + (bullet (widget-get item-widget :bullet)) + (use-bullet bullet) + (was-bullet (widget-get item-widget :was-bullet)) + (distinctive (allout-distinctive-bullet bullet)) + (distinctive-start (widget-get item-widget :distinctive-start)) + (distinctive-end (widget-get item-widget :distinctive-end)) + (does-encrypt (widget-get item-widget :does-encrypt)) + (is-encrypted (and does-encrypt (widget-get item-widget + :is-encrypted))) + (expanded (widget-get item-widget :expanded)) + (has-subitems (widget-get item-widget :has-subitems)) + (inhibit-read-only t) + icon-state) + + (when (not (and (equal (widget-get item-widget :was-expanded) expanded) + (equal (widget-get item-widget :was-has-subitems) + has-subitems) + (equal (widget-get item-widget :was-does-encrypt) + does-encrypt) + (equal (widget-get item-widget :was-is-encrypted) + is-encrypted))) + + (setq icon-state + (cond (does-encrypt (if is-encrypted + 'locked-encrypted + 'unlocked-encrypted)) + (expanded 'opened) + (has-subitems 'closed) + (t 'empty))) + (put-text-property icon-start (1+ icon-start) + 'display (allout-fetch-icon-image icon-state)) + (widget-put item-widget :was-expanded expanded) + (widget-put item-widget :was-has-subitems has-subitems) + (widget-put item-widget :was-does-encrypt does-encrypt) + (widget-put item-widget :was-is-encrypted is-encrypted) + ;; preserve as a widget property to track last known: + (widget-put item-widget :icon-state icon-state) + ;; preserve as a text property to track undo: + (put-text-property icon-start icon-end :icon-state icon-state)) + (allout-item-element-span-is item-widget :icon-span + icon-start icon-end) + (when (not (string= was-bullet bullet)) + (cond ((not distinctive) + ;; XXX we strip the prior properties without even checking if + ;; the prior bullet was distinctive, because the widget + ;; provisions to convey that info is disappearing, sigh. + (remove-text-properties icon-end (1+ icon-end) '(display)) + (setq distinctive-start icon-end distinctive-end icon-end) + (widget-put item-widget :distinctive-start distinctive-start) + (widget-put item-widget :distinctive-end distinctive-end)) + + ((not (string= bullet allout-numbered-bullet)) + (setq distinctive-start icon-end distinctive-end (+ icon-end 1))) + + (does-encrypt + (setq distinctive-start icon-end distinctive-end (+ icon-end 1))) + + (t + (goto-char icon-end) + (looking-at "[0-9]+") + (setq use-bullet (buffer-substring icon-end (match-end 0))) + (setq distinctive-start icon-end + distinctive-end (match-end 0)))) + (put-text-property distinctive-start distinctive-end 'display + use-bullet) + (widget-put item-widget :was-bullet bullet) + (widget-put item-widget :distinctive-start distinctive-start) + (widget-put item-widget :distinctive-end distinctive-end))))) +;;;_ > allout-decorate-item-cue (item-widget) +(defun allout-decorate-item-cue (item-widget) + "Incorporate space between bullet icon and body to the ITEM-WIDGET." + ;; NOTE: most of the cue-area + + (when (not (widget-get item-widget :is-container)) + (let* ((cue-start (or (widget-get item-widget :distinctive-end) + (widget-get item-widget :icon-end))) + (body-start (widget-get item-widget :body-start)) + (expanded (widget-get item-widget :expanded)) + (has-subitems (widget-get item-widget :has-subitems)) + (inhibit-read-only t)) + + (allout-item-element-span-is item-widget :cue-span cue-start body-start) + (put-text-property (1- body-start) body-start 'rear-nonsticky t)))) +;;;_ > allout-decorate-item-body (item-widget &optional force) +(defun allout-decorate-item-body (item-widget &optional force) + "Incorporate item body text as part the ITEM-WIDGET. + +Optional FORCE means force reassignment of the region property." + + (let* ((allout-inhibit-body-modification-hook t) + (body-start (widget-get item-widget :body-start)) + (body-end (widget-get item-widget :body-end)) + (body-text-end body-end) + (inhibit-read-only t)) + + (allout-item-element-span-is item-widget :body-span + body-start (min (1+ body-end) (point-max)) + force))) +;;;_ > allout-item-actual-position (item-widget field) +(defun allout-item-actual-position (item-widget field) + "Return ITEM-WIDGET FIELD position taking item displacement into account." + + ;; The item's sub-element positions (:icon-end, :body-start, etc) are + ;; accurate when the item is parsed, but some offsets from the start + ;; drift with text added in the body. + ;; + ;; Rather than reparse an item with every change (inefficient), or derive + ;; every position from a distinct field marker/overlay (prohibitive as + ;; the number of items grows), we use the displacement tracking of the + ;; :span-overlay's markers, against the registered :from or :body-end + ;; (depending on whether the requested field value is before or after the + ;; item body), to bias the registered values. + ;; + ;; This is not necessary/useful when the item is being decorated, because + ;; that always must be preceeded by a fresh item parse. + + (if (not (eq field :body-end)) + (widget-get item-widget :from) + + (let* ((span-overlay (widget-get item-widget :span-overlay)) + (body-end-position (widget-get item-widget :body-end)) + (ref-marker-position (and span-overlay + (overlay-end span-overlay))) + (offset (and body-end-position span-overlay + (- (or ref-marker-position 0) + body-end-position)))) + (+ (widget-get item-widget field) (or offset 0))))) +;;;_ : Item undecoration +;;;_ > allout-widgets-undecorate-region (start end) +(defun allout-widgets-undecorate-region (start end) + "Eliminate widgets and decorations for all items in region from START to END." + (let ((next start) + widget) + (save-excursion + (goto-char start) + (while (< (setq next (next-single-char-property-change next + 'display + (current-buffer) + end)) + end) + (goto-char next) + (when (setq widget (allout-get-item-widget)) + ;; if the next-property/overly progression got us to a widget: + (allout-widgets-undecorate-item widget t)))))) +;;;_ > allout-widgets-undecorate-text (text) +(defun allout-widgets-undecorate-text (text) + "Eliminate widgets and decorations for all items in TEXT." + (remove-text-properties 0 (length text) + '(display nil :icon-state nil rear-nonsticky nil + category nil button nil field nil) + text) + text) +;;;_ > allout-widgets-undecorate-item (item-widget &optional no-expose) +(defun allout-widgets-undecorate-item (item-widget &optional no-expose) + "Remove widget decorations from ITEM-WIDGET. + +Any concealed content head lines and item body is exposed, unless +optional NO-EXPOSE is non-nil." + (let ((from (widget-get item-widget :from)) + (to (widget-get item-widget :to)) + (text-properties-to-remove '(display nil + :icon-state nil + rear-nonsticky nil + category nil + button nil + field nil)) + (span-overlay (widget-get item-widget :span-overlay)) + (button-overlay (widget-get item-widget :button)) + (was-modified (buffer-modified-p)) + (buffer-undo-list t) + (inhibit-read-only t)) + (if (not no-expose) + (allout-flag-region from to nil)) + (allout-unprotected + (remove-text-properties from to text-properties-to-remove)) + (when span-overlay + (delete-overlay span-overlay) (widget-put item-widget :span-overlay nil)) + (when button-overlay + (delete-overlay button-overlay) (widget-put item-widget :button nil)) + (set-marker from nil) + (set-marker to nil) + (if (not was-modified) + (set-buffer-modified-p nil)))) + +;;;_ : Item decoration support +;;;_ > allout-item-span (item-widget &optional start end) +(defun allout-item-span (item-widget &optional start end) + "Return or register the location of an ITEM-WIDGET's actual START and END. + +If START and END are not passed in, return either a dotted pair +of the current span, if established, or nil if not yet set. + +When the START and END are passed, return the distance that the +start of the item moved. We return 0 if the span was not +previously established or is not moved." + (let ((overlay (widget-get item-widget :span-overlay)) + was-start was-end + changed) + (cond ((not overlay) (when start + (setq overlay (make-overlay start end nil t nil)) + (overlay-put overlay 'button item-widget) + (widget-put item-widget :span-overlay overlay) + t)) + ;; report: + ((not start) (cons (overlay-start overlay) (overlay-end overlay))) + ;; move: + ((or (not (equal (overlay-start overlay) start)) + (not (equal (overlay-end overlay) end))) + (move-overlay overlay start end) + t) + ;; specified span already set: + (t nil)))) +;;;_ > allout-item-element-span-is (item-widget element +;;; &optional start end force) +(defun allout-item-element-span-is (item-widget element + &optional start end force) + "Return or register the location of the indicated ITEM-WIDGET ELEMENT. + +ELEMENT is one of :guides-span, :icon-span, :cue-span, or :body-span. + +When optional START is specified, optional END must also be. + +START and END are the actual bounds of the region, if provided. + +If START and END are not passed in, we return either a dotted +pair of the current span, if established, or nil if not yet set. + +When the START and END are passed, we return t if the region +changed or nil if not. + +Optional FORCE means force assignment of the region's text +property, even if it's already set." + (let ((span (widget-get item-widget element))) + (cond ((or (not span) force) + (when start + (widget-put item-widget element (cons start end)) + (put-text-property start end 'category + (cdr (assoc element + allout-span-to-category))) + t)) + ;; report: + ((not start) span) + ;; move if necessary: + ((not (and (eq (car span) start) + (eq (cdr span) end))) + (widget-put item-widget element span) + t) + ;; specified span already set: + (t nil)))) +;;;_ : Item widget retrieval (/ high-level creation): +;;;_ > allout-get-item-widget (&optional container) +(defun allout-get-item-widget (&optional container) + "Return the widget for the item at point, or nil if no widget yet exists. + +Point must be situated *before* the start of the target item's +body, so we don't get an existing containing item when we're in +the process of creating an item in the middle of another. + +Optional CONTAINER is used to obtain the container item." + (if (or container (zerop (allout-depth))) + allout-container-item-widget + ;; allout-recent-* are calibrated by (allout-depth) if we got here. + (let ((got (widget-at allout-recent-prefix-beginning))) + (if (and got (listp got)) + (if (marker-position (widget-get got :from)) + (and + (>= (point) (widget-apply got :actual-position :from)) + (<= (point) (widget-apply got :actual-position :body-start)) + got) + ;; a wacky residual item - undecorate and disregard: + (allout-widgets-undecorate-item got) + nil))))) +;;;_ > allout-get-or-create-item-widget (&optional redecorate blank-container) +(defun allout-get-or-create-item-widget (&optional redecorate blank-container) + "Return a widget for the item at point, creating the widget if necessary. + +When creating a widget, we assume there has been a context change +and decorate its siblings and parent, as well. + +Optional BLANK-CONTAINER is for internal use, to fabricate a +meta-container item with an empty body when the first proper +\(non-container\) item starts at the beginning of the file. + +Optional REDECORATE, if non-nil, means to redecorate the widget +if it already exists." + (let ((widget (allout-get-item-widget blank-container)) + (buffer-undo-list t)) + (cond (widget (if redecorate + (allout-redecorate-item widget)) + widget) + ((or blank-container (zerop (allout-depth))) + (or allout-container-item-widget + (setq allout-container-item-widget + (allout-decorate-item-and-context + (widget-convert 'allout-item-widget) + nil blank-container)))) + ;; create a widget for a regular/non-container item: + (t (allout-decorate-item-and-context (widget-convert + 'allout-item-widget)))))) +;;;_ > allout-get-or-create-parent-widget (&optional redecorate) +(defun allout-get-or-create-parent-widget (&optional redecorate) + "Return widget for parent of item at point, decorating it if necessary. + +We return the container widget if we're above the first proper item in the +file. + +Optional REDECORATE, if non-nil, means to redecorate the widget if it +already exists. + +Point will wind up positioned on the beginning of the parent or beginning +of the buffer." + ;; use existing widget, if there, else establish it + (if (or (bobp) (and (not (allout-ascend)) + (looking-at allout-regexp))) + (allout-get-or-create-item-widget redecorate 'blank-container) + (allout-get-or-create-item-widget redecorate))) +;;;_ : X- Item ancillaries +;;;_ >X allout-body-modification-handler (beg end) +(defun allout-body-modification-handler (beg end) + "Do routine processing of body text before and after modification. + +Operation is inhibited by `allout-inhibit-body-modification-handler'." + +;; The primary duties are: +;; +;; - marking of escaped prefix-like text for delayed cleanup of escapes +;; - removal and replacement of the settings +;; - maintenance of beginning-of-line guide lines +;; +;; ?? Escapes removal \(before changes\) is not done when edits span multiple +;; items, recognizing that item structure is being preserved, including +;; escaping of item-prefix-like text within bodies. See +;; `allout-before-modification-handler' and +;; `allout-inhibit-body-modification-handler'. +;; +;; Adds the overlay to the `allout-unresolved-body-mod-workhash' during +;; before-change operation, and removes from that list during after-change +;; operation. + (cond (allout-inhibit-body-modification-hook nil))) +;;;_ >X allout-graphics-modification-handler (beg end) +(defun allout-graphics-modification-handler (beg end) + "Protect against incoherent deletion of decoration graphics. + +Deletes allowed only when inhibit-read-only is t." + (cond + (undo-in-progress (when (eq (get-text-property beg 'category) + 'allout-icon-span-category) + (save-excursion + (goto-char beg) + (let* ((item-widget (allout-get-item-widget))) + (if item-widget + (allout-widgets-exposure-undo-recorder + item-widget)))))) + (inhibit-read-only t) + ((not (and (boundp 'allout-mode) allout-mode)) t) + ((equal this-command 'quoted-insert) t) + ((yes-or-no-p "Unruly edit of outline structure - allow? ") + (setq allout-widgets-unset-inhibit-read-only (not inhibit-read-only) + inhibit-read-only t)) + (t (error + (substitute-command-keys allout-structure-unruly-deletion-message))))) +;;;_ > allout-item-icon-key-handler () +(defun allout-item-icon-key-handler () + "Catchall handling of key bindings in item icon/cue hot-spots. + +Applies `allout-hotspot-key-handler' and calls the result, if any, as an +interactive command." + + (interactive) + (let* ((mapped-binding (allout-hotspot-key-handler))) + (when mapped-binding + (call-interactively mapped-binding)))) + +;;;_ : Status +;;;_ . allout-item-location (item-widget) +(defun allout-item-location (item-widget) + "Location of the start of the item's text." + (overlay-start (widget-get item-widget :span-overlay))) + +;;;_ : Icon management +;;;_ > allout-fetch-icon-image (name) +(defun allout-fetch-icon-image (name) + "Fetch allout icon for symbol NAME. + +We use a caching strategy, so the caller doesn't need to do so." + (let* ((types allout-widgets-icon-types) + (use-dir (if (equal (allout-frame-property nil 'background-mode) + 'light) + allout-widgets-icons-light-subdir + allout-widgets-icons-dark-subdir)) + (key (list name use-dir)) + (got (assoc key allout-widgets-icons-cache))) + (if got + ;; display system shows only first of subsequent adjacent + ;; `eq'-identical repeats - use copies to avoid this problem. + (allout-widgets-copy-list (cadr got)) + (while (and types (not got)) + (setq got + (allout-find-image + (list (append (list :type (car types) + :file (concat use-dir + (symbol-name name) + "." (symbol-name + (car types)))) + (if (featurep 'xemacs) + allout-widgets-item-image-properties-xemacs + allout-widgets-item-image-properties-emacs) + )))) + (setq types (cdr types))) + (if got + (push (list key got) allout-widgets-icons-cache)) + got))) + +;;;_ : Miscellaneous +;;;_ > allout-elapsed-time-seconds (triple) +(defun allout-elapsed-time-seconds (end start) + "Return seconds between `current-time' style time START/END triples." + (let ((elapsed (time-subtract end start))) + (+ (* (car elapsed) (expt 2.0 16)) + (cadr elapsed) + (/ (caddr elapsed) (expt 10.0 6))))) +;;;_ > allout-frame-property (frame property) +(defalias 'allout-frame-property + (cond ((fboundp 'frame-parameter) + 'frame-parameter) + ((fboundp 'frame-property) + 'frame-property) + (t nil))) +;;;_ > allout-find-image (specs) +(defalias 'allout-find-image + (if (fboundp 'find-image) + 'find-image + nil) ; aka, not-yet-implemented for xemacs. +) +;;;_ > allout-widgets-copy-list (list) +(defun allout-widgets-copy-list (list) + ;; duplicated from cl.el 'copy-list' as of 2008-08-17 + "Return a copy of LIST, which may be a dotted list. +The elements of LIST are not copied, just the list structure itself." + (if (consp list) + (let ((res nil)) + (while (consp list) (push (pop list) res)) + (prog1 (nreverse res) (setcdr res list))) + (car list))) + +;;;_ : Run unit tests: +(defun allout-widgets-run-unit-tests () + (message "Running allout-widget tests...") + + (allout-test-range-overlaps) + + (message "Running allout-widget tests... Done.") + (sit-for .5)) + +(when allout-widgets-run-unit-tests-on-load + (allout-widgets-run-unit-tests)) + +;;;_ : provide +(provide 'allout-widgets) + +;;;_. Local emacs vars. +;;;_ , Local variables: +;;;_ , allout-layout: (-1 : 0) +;;;_ , End: diff --git a/lisp/allout.el b/lisp/allout.el index 5d87415a57f..1a7d8cb1593 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -6,7 +6,7 @@ ;; Maintainer: Ken Manheimer <ken dot manheimer at gmail dot com> ;; Created: Dec 1991 -- first release to usenet ;; Version: 2.3 -;; Keywords: outlines wp languages +;; Keywords: outlines, wp, languages, PGP, GnuPG ;; Website: http://myriadicity.net/Sundry/EmacsAllout ;; This file is part of GNU Emacs. @@ -39,11 +39,9 @@ ;; emacs local file variables need to be enabled when the ;; file was visited -- see `enable-local-variables'.) ;; - Configurable per-file initial exposure settings -;; - Symmetric-key and key-pair topic encryption, plus symmetric passphrase -;; mnemonic support, with verification against an established passphrase -;; (using a stashed encrypted dummy string) and user-supplied hint -;; maintenance. Encryption is via the Emacs 'epg' library. See -;; allout-toggle-current-subtree-encryption docstring. +;; - Symmetric-key and key-pair topic encryption. Encryption is via the +;; Emacs 'epg' library. See allout-toggle-current-subtree-encryption +;; docstring. ;; - Automatic topic-number maintenance ;; - "Hot-spot" operation, for single-keystroke maneuvering and ;; exposure control (see the allout-mode docstring) @@ -59,8 +57,8 @@ ;; See the `allout-mode' function's docstring for an introduction to the ;; mode. ;; -;; The latest development version and helpful notes are available at -;; http://myriadicity.net/Sundry/EmacsAllout . +;; Directions to the latest development version and helpful notes are +;; available at http://myriadicity.net/Sundry/EmacsAllout . ;; ;; The outline menubar additions provide quick reference to many of the ;; features. See the docstring of the variables `allout-layout' and @@ -76,7 +74,7 @@ ;;; Code: -;;;_* Dependency autoloads +;;;_* Dependency loads (require 'overlay) (eval-when-compile ;; Most of the requires here are for stuff covered by autoloads, which @@ -94,7 +92,9 @@ ;;;_ > defgroup allout, allout-keybindings (defgroup allout nil - "Extensive outline mode for use alone and with other modes." + "Extensive outline minor-mode, for use stand-alone and with other modes. + +See Allout Auto Activation for automatic activation." :prefix "allout-" :group 'outlines) (defgroup allout-keybindings nil @@ -308,9 +308,7 @@ performing auto-layout is asked of the user each time. With value \"activate\", only auto-mode-activation is enabled. Auto-layout is not. -With value nil, neither auto-mode-activation nor auto-layout are -enabled, and allout auto-activation processing is removed from -file visiting activities." +With value nil, inhibit any automatic allout-mode activation." :set 'allout-auto-activation-helper :type '(choice (const :tag "On" t) (const :tag "Ask about layout" "ask") @@ -752,8 +750,10 @@ Set this var to the bullet you want to use for file cross-references." ;;;###autoload (put 'allout-presentation-padding 'safe-local-variable 'integerp) -;;;_ = allout-abbreviate-flattened-numbering -(defcustom allout-abbreviate-flattened-numbering nil +;;;_ = allout-flattened-numbering-abbreviation +(define-obsolete-variable-alias 'allout-abbreviate-flattened-numbering + 'allout-flattened-numbering-abbreviation "24.0") +(defcustom allout-flattened-numbering-abbreviation nil "If non-nil, `allout-flatten-exposed-to-buffer' abbreviates topic numbers to minimal amount with some context. Otherwise, entire numbers are always used." @@ -1553,6 +1553,7 @@ See `allout-encryption-ciphertext-rejection-regexps' for rejection reasons.") ;;;_ > allout-mode-p () ;; Must define this macro above any uses, or byte compilation will lack ;; proper def, if file isn't loaded -- eg, during emacs build! +;;;###autoload (defmacro allout-mode-p () "Return t if `allout-mode' is active in current buffer." 'allout-mode) @@ -5410,7 +5411,7 @@ header and body. The elements of that list are: bullet))) (cond ((listp format) (list depth - (if allout-abbreviate-flattened-numbering + (if allout-flattened-numbering-abbreviation (allout-stringify-flat-index format gone-out) (allout-stringify-flat-index-plain @@ -6054,7 +6055,7 @@ signal." (with-temp-buffer (insert text) ;; convey the text characteristics of the original buffer: - (allout-set-buffer-multibyte multibyte) + (set-buffer-multibyte multibyte) (when encoding (set-buffer-file-coding-system encoding) (if (not decrypt) @@ -6085,9 +6086,14 @@ signal." (setq result-text (if decrypt - (epg-decrypt-string epg-context - (encode-coding-string massaged-text - (or encoding 'utf-8))) + (condition-case err + (epg-decrypt-string epg-context + (encode-coding-string massaged-text + (or encoding 'utf-8))) + (epg-error + (signal 'egp-error + (cons (concat (cadr err) " - gpg version problem?") + (cddr err))))) (replace-regexp-in-string "\n$" "" (epg-encrypt-string epg-context (encode-coding-string massaged-text @@ -6673,14 +6679,6 @@ To ignore intangibility, bind `inhibit-point-motion-hooks' to t." 'previous-single-property-change) ;; No docstring because xemacs defalias doesn't support it. ) -;;;_ > allout-set-buffer-multibyte -(if (fboundp 'set-buffer-multibyte) - (defalias 'allout-set-buffer-multibyte 'set-buffer-multibyte) - (with-no-warnings - ;; this definition is used only in older or alternative emacs, where - ;; the setting is our only recourse. - (defun allout-set-buffer-multibyte (is-multibyte) - (set enable-multibyte-characters is-multibyte)))) ;;;_ > allout-select-safe-coding-system (defalias 'allout-select-safe-coding-system (if (fboundp 'select-safe-coding-system) diff --git a/lisp/dired-x.el b/lisp/dired-x.el index 95381ccdc0c..202b4e754d7 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -32,7 +32,7 @@ ;; ;; (add-hook 'dired-load-hook ;; (lambda () -;; (require 'dired-x) +;; (load "dired-x") ;; ;; Set global variables here. For example: ;; ;; (setq dired-guess-shell-gnutar "gtar") ;; )) @@ -79,7 +79,6 @@ (defcustom dired-bind-vm nil "Non-nil means \"V\" runs `dired-vm', otherwise \"V\" runs `dired-rmail'. - RMAIL files in the old Babyl format (used before before Emacs 23.1) contain \"-*- rmail -*-\" at the top, so `dired-find-file' will run `rmail' on these files. New RMAIL files use the standard @@ -88,26 +87,49 @@ mbox format, and so cannot be distinguished in this way." :group 'dired-keys) (defcustom dired-bind-jump t - "Non-nil means bind `dired-jump' to C-x C-j, otherwise do not." + "Non-nil means bind `dired-jump' to C-x C-j, otherwise do not. +Setting this variable directly after dired-x is loaded has no effect - +use \\[customize]." :type 'boolean + :set (lambda (sym val) + (if (set sym val) + (progn + (define-key global-map "\C-x\C-j" 'dired-jump) + (define-key global-map "\C-x4\C-j" 'dired-jump-other-window)) + (if (eq 'dired-jump (lookup-key global-map "\C-x\C-j")) + (define-key global-map "\C-x\C-j" nil)) + (if (eq 'dired-jump-other-window (lookup-key global-map "\C-x4\C-j")) + (define-key global-map "\C-x4\C-j" nil)))) :group 'dired-keys) (defcustom dired-bind-man t - "Non-nil means bind `dired-man' to \"N\" in dired-mode, otherwise do not." + "Non-nil means bind `dired-man' to \"N\" in dired-mode, otherwise do not. +Setting this variable directly after dired-x is loaded has no effect - +use \\[customize]." :type 'boolean + :set (lambda (sym val) + (if (set sym val) + (define-key dired-mode-map "N" 'dired-man) + (if (eq 'dired-man (lookup-key dired-mode-map "N")) + (define-key dired-mode-map "N" nil)))) :group 'dired-keys) (defcustom dired-bind-info t - "Non-nil means bind `dired-info' to \"I\" in dired-mode, otherwise do not." + "Non-nil means bind `dired-info' to \"I\" in dired-mode, otherwise do not. +Setting this variable directly after dired-x is loaded has no effect - +use \\[customize]." :type 'boolean + :set (lambda (sym val) + (if (set sym val) + (define-key dired-mode-map "I" 'dired-info) + (if (eq 'dired-info (lookup-key dired-mode-map "I")) + (define-key dired-mode-map "I" nil)))) :group 'dired-keys) (defcustom dired-vm-read-only-folders nil "If non-nil, \\[dired-vm] will visit all folders read-only. If neither nil nor t, e.g. the symbol `if-file-read-only', only -files not writable by you are visited read-only. - -Read-only folders only work in VM 5, not in VM 4." +files not writable by you are visited read-only." :type '(choice (const :tag "off" nil) (const :tag "on" t) (other :tag "non-writable only" if-file-read-only)) @@ -181,13 +203,20 @@ listing a directory. See also `dired-local-variables-file'." :type 'boolean :group 'dired-x) -(defcustom dired-guess-shell-gnutar (when (or (eq system-type 'gnu) - (eq system-type 'gnu/linux)) - "tar") +(defcustom dired-guess-shell-gnutar + (catch 'found + (dolist (exe '("tar" "gtar")) + (if (with-temp-buffer + (ignore-errors (call-process exe nil t nil "--version")) + (and (re-search-backward "GNU tar" nil t) t)) + (throw 'found exe)))) "If non-nil, name of GNU tar executable. \(E.g., \"tar\" or \"gtar\"). The `z' switch will be used with it for compressed or gzip'ed tar files. If you don't have GNU tar, set this to nil: a pipe using `zcat' or `gunzip -c' will be used." + ;; Changed from system-type test to testing --version output. + ;; Maybe test --help for -z instead? + :version "24.1" :type '(choice (const :tag "Not GNU tar" nil) (string :tag "Command name")) :group 'dired-x) @@ -216,19 +245,12 @@ to nil: a pipe using `zcat' or `gunzip -c' will be used." (define-key dired-mode-map "*(" 'dired-mark-sexp) (define-key dired-mode-map "*." 'dired-mark-extension) (define-key dired-mode-map "\M-!" 'dired-smart-shell-command) -(define-key dired-mode-map "w" 'dired-copy-filename-as-kill) (define-key dired-mode-map "\M-G" 'dired-goto-subdir) (define-key dired-mode-map "F" 'dired-do-find-marked-files) (define-key dired-mode-map "Y" 'dired-do-relsymlink) (define-key dired-mode-map "%Y" 'dired-do-relsymlink-regexp) (define-key dired-mode-map "V" 'dired-do-run-mail) -(if dired-bind-man - (define-key dired-mode-map "N" 'dired-man)) - -(if dired-bind-info - (define-key dired-mode-map "I" 'dired-info)) - ;;; MENU BINDINGS (require 'easymenu) @@ -270,11 +292,6 @@ matching regexp"] files"] "Refresh")) -;;; GLOBAL BINDING. -(when dired-bind-jump - (define-key global-map "\C-x\C-j" 'dired-jump) - (define-key global-map "\C-x4\C-j" 'dired-jump-other-window)) - ;; Install into appropriate hooks. @@ -290,31 +307,9 @@ files"] \\[dired-do-find-marked-files]\t-- visit all marked files simultaneously \\[dired-omit-mode]\t-- toggle omitting of files \\[dired-mark-sexp]\t-- mark by Lisp expression - \\[dired-copy-filename-as-kill]\t-- copy the file or subdir names into the kill ring; - \t you can feed it to other commands using \\[yank] - -For more features, see variables - - `dired-bind-vm' - `dired-bind-jump' - `dired-bind-info' - `dired-bind-man' - `dired-vm-read-only-folders' - `dired-omit-mode' - `dired-omit-files' - `dired-omit-extensions' - `dired-omit-size-limit' - `dired-find-subdir' - `dired-enable-local-variables' - `dired-local-variables-file' - `dired-guess-shell-gnutar' - `dired-guess-shell-gzip-quiet' - `dired-guess-shell-znew-switches' - `dired-guess-shell-alist-user' - `dired-clean-up-buffers-too' - -See also functions +To see the options you can set, use M-x customize-group RET dired-x RET. +See also the functions: `dired-flag-extension' `dired-virtual' `dired-jump' @@ -324,7 +319,6 @@ See also functions `dired-info' `dired-do-find-marked-files'" (interactive) - ;; These must be done in each new dired buffer. (dired-hack-local-variables) (dired-omit-startup)) @@ -339,28 +333,21 @@ Remove expanded subdir of deleted dir, if any." (save-excursion (and (cdr dired-subdir-alist) (dired-goto-subdir fn) (dired-kill-subdir))) - ;; Offer to kill buffer of deleted file FN. - (if dired-clean-up-buffers-too - (progn - (let ((buf (get-file-buffer fn))) - (and buf - (funcall (function y-or-n-p) - (format "Kill buffer of %s, too? " - (file-name-nondirectory fn))) - (save-excursion ; you never know where kill-buffer leaves you - (kill-buffer buf)))) - (let ((buf-list (dired-buffers-for-dir (expand-file-name fn))) - (buf nil)) - (and buf-list - (y-or-n-p (format "Kill dired buffer%s of %s, too? " - (dired-plural-s (length buf-list)) - (file-name-nondirectory fn))) - (while buf-list - (save-excursion (kill-buffer (car buf-list))) - (setq buf-list (cdr buf-list))))))) - ;; Anything else? - ) + (when dired-clean-up-buffers-too + (let ((buf (get-file-buffer fn))) + (and buf + (funcall (function y-or-n-p) + (format "Kill buffer of %s, too? " + (file-name-nondirectory fn))) + (kill-buffer buf))) + (let ((buf-list (dired-buffers-for-dir (expand-file-name fn)))) + (and buf-list + (y-or-n-p (format "Kill dired buffer%s of %s, too? " + (dired-plural-s (length buf-list)) + (file-name-nondirectory fn))) + (dolist (buf buf-list) + (kill-buffer buf)))))) ;;; EXTENSION MARKING FUNCTIONS. @@ -460,11 +447,10 @@ move to its line in dired." (progn (setq dir (dired-current-directory)) (dired-up-directory other-window) - (or (dired-goto-file dir) + (unless (dired-goto-file dir) ;; refresh and try again - (progn - (dired-insert-subdir (file-name-directory dir)) - (dired-goto-file dir)))) + (dired-insert-subdir (file-name-directory dir)) + (dired-goto-file dir))) (if other-window (dired-other-window dir) (dired dir)) @@ -475,10 +461,9 @@ move to its line in dired." (dired-insert-subdir (file-name-directory file)) (dired-goto-file file)) ;; Toggle omitting, if it is on, and try again. - (if dired-omit-mode - (progn - (dired-omit-mode) - (dired-goto-file file)))))))) + (when dired-omit-mode + (dired-omit-mode) + (dired-goto-file file))))))) (defun dired-jump-other-window (&optional file-name) "Like \\[dired-jump] (`dired-jump') but in other window." @@ -695,7 +680,7 @@ you can relist single subdirs using \\[dired-do-redisplay]." (forward-line 1) (and (looking-at "^ wildcard ") (buffer-substring (match-end 0) - (progn (end-of-line) (point))))))) + (line-end-position)))))) (if wildcard (setq dirname (expand-file-name wildcard default-directory)))) ;; If raw ls listing (not a saved old dired buffer), give it a @@ -777,9 +762,12 @@ Also useful for `auto-mode-alist' like this: ;; mechanism is provided for special handling of the working directory in ;; special major modes. +(define-obsolete-variable-alias 'default-directory-alist + 'dired-default-directory-alist "24.1") + ;; It's easier to add to this alist than redefine function ;; default-directory while keeping the old information. -(defconst default-directory-alist +(defconst dired-default-directory-alist '((dired-mode . (if (fboundp 'dired-current-directory) (dired-current-directory) default-directory))) @@ -789,8 +777,8 @@ nil is ignored in favor of `default-directory'.") (defun dired-default-directory () "Usage like variable `default-directory'. -Knows about the special cases in variable `default-directory-alist'." - (or (eval (cdr (assq major-mode default-directory-alist))) +Knows about the special cases in variable `dired-default-directory-alist'." + (or (eval (cdr (assq major-mode dired-default-directory-alist))) default-directory)) (defun dired-smart-shell-command (command &optional output-buffer error-buffer) @@ -1369,8 +1357,9 @@ NOSELECT the files are merely found but not selected." (declare-function Man-getpage-in-background "man" (topic)) (defun dired-man () - "Run man on this file. Display old buffer if buffer name matches filename. -Uses `man.el' of \\[manual-entry] fame." + "Run `man' on this file." +;; Used also to say: "Display old buffer if buffer name matches filename." +;; but I have no idea what that means. (interactive) (require 'man) (let* ((file (dired-get-filename)) @@ -1382,7 +1371,7 @@ Uses `man.el' of \\[manual-entry] fame." ;; Run Info on files. (defun dired-info () - "Run info on this file." + "Run `info' on this file." (interactive) (info (dired-get-filename))) @@ -1393,17 +1382,16 @@ Uses `man.el' of \\[manual-entry] fame." (defun dired-vm (&optional read-only) "Run VM on this file. -With prefix arg, visit folder read-only (this requires at least VM 5). -See also variable `dired-vm-read-only-folders'." +With optional prefix argument, visits the folder read-only. +Otherwise obeys the value of `dired-vm-read-only-folders'." (interactive "P") (let ((dir (dired-current-directory)) (fil (dired-get-filename))) - ;; take care to supply 2nd arg only if requested - may still run VM 4! - (cond (read-only (vm-visit-folder fil t)) - ((eq t dired-vm-read-only-folders) (vm-visit-folder fil t)) - ((null dired-vm-read-only-folders) (vm-visit-folder fil)) - (t (vm-visit-folder fil (not (file-writable-p fil))))) - ;; so that pressing `v' inside VM does prompt within current directory: + (vm-visit-folder fil (or read-only + (eq t dired-vm-read-only-folders) + (and dired-vm-read-only-folders + (not (file-writable-p fil))))) + ;; So that pressing `v' inside VM does prompt within current directory: (set (make-local-variable 'vm-folder-directory) dir))) (defun dired-rmail () @@ -1412,7 +1400,7 @@ See also variable `dired-vm-read-only-folders'." (rmail (dired-get-filename))) (defun dired-do-run-mail () - "If `dired-bind-vm' is t, then function `dired-vm', otherwise `dired-rmail'." + "If `dired-bind-vm' is non-nil, call `dired-vm', else call `dired-rmail'." (interactive) (if dired-bind-vm ;; Read mail folder using vm. @@ -1450,16 +1438,11 @@ See also variable `dired-vm-read-only-folders'." ;; This should be a builtin (defun dired-buffer-more-recently-used-p (buffer1 buffer2) - "Return t if BUFFER1 is more recently used than BUFFER2." - (if (equal buffer1 buffer2) - nil - (let ((more-recent nil) - (list (buffer-list))) - (while (and list - (not (setq more-recent (equal buffer1 (car list)))) - (not (equal buffer2 (car list)))) - (setq list (cdr list))) - more-recent))) + "Return t if BUFFER1 is more recently used than BUFFER2. +Considers buffers closer to the car of `buffer-list' to be more recent." + (and (not (equal buffer1 buffer2)) + (memq buffer1 (buffer-list)) + (not (memq buffer1 (memq buffer2 (buffer-list)))))) ;; Same thing as `dired-buffers-for-dir' of dired.el? - lrd 11/23/93 ;; (defun dired-buffers-for-dir-exact (dir) @@ -1559,7 +1542,7 @@ to mark all zero length files." (forward-char mode-len) (setq nlink (read (current-buffer))) ;; Karsten Wenger <kw@cis.uni-muenchen.de> fixed uid. - (setq uid (buffer-substring (+ (point) 1) + (setq uid (buffer-substring (1+ (point)) (progn (forward-word 1) (point)))) (re-search-forward directory-listing-before-filename-regexp) (goto-char (match-beginning 1)) @@ -1649,7 +1632,7 @@ Identical to `find-file' except when called interactively, with a prefix arg \(e.g., \\[universal-argument]\), in which case it guesses filename near point. Useful for editing file mentioned in buffer you are viewing, or to test if that file exists. Use minibuffer after snatching filename." - (interactive (list (read-filename-at-point "Find file: "))) + (interactive (list (dired-x-read-filename-at-point "Find file: "))) (find-file (expand-file-name filename))) (defun dired-x-find-file-other-window (filename) @@ -1661,52 +1644,43 @@ Identical to `find-file-other-window' except when called interactively, with a prefix arg \(e.g., \\[universal-argument]\), in which case it guesses filename near point. Useful for editing file mentioned in buffer you are viewing, or to test if that file exists. Use minibuffer after snatching filename." - (interactive (list (read-filename-at-point "Find file: "))) + (interactive (list (dired-x-read-filename-at-point "Find file: "))) (find-file-other-window (expand-file-name filename))) ;;; Internal functions. ;; Fixme: This should probably use `thing-at-point'. -- fx (defun dired-filename-at-point () - "Get the filename closest to point, but do not change position. -Has a preference for looking backward when not directly on a symbol. -Not perfect - point must be in middle of or end of filename." - + "Return the filename closest to point, expanded. +Point should be in or after a filename." (let ((filename-chars "-.[:alnum:]_/:$+@") start end filename prefix) - (save-excursion ;; First see if just past a filename. - (if (not (eobp)) - (if (looking-at "[] \t\n[{}()]") ; whitespace or some parens - (progn - (skip-chars-backward " \n\t\r({[]})") - (if (not (bobp)) - (backward-char 1))))) - - (if (string-match (concat "[" filename-chars "]") - (char-to-string (following-char))) + (or (eobp) ; why? + (when (looking-at "[] \t\n[{}()]") ; whitespace or some parens + (skip-chars-backward " \n\t\r({[]})") + (or (bobp) (backward-char 1)))) + (if (looking-at (format "[%s]" filename-chars)) (progn - (if (re-search-backward (concat "[^" filename-chars "]") nil t) - (forward-char) - (goto-char (point-min))) - (setq start (point)) - (setq prefix + (skip-chars-backward filename-chars) + (setq start (point) + prefix + ;; This is something to do with ange-ftp filenames. + ;; It convert foo@bar to /foo@bar. + ;; But when does the former occur in dired buffers? (and (string-match "^\\w+@" - (buffer-substring start (line-beginning-position))) + (buffer-substring start (line-end-position))) "/")) - (goto-char start) (if (string-match "[/~]" (char-to-string (preceding-char))) (setq start (1- start))) - (re-search-forward (concat "\\=[" filename-chars "]*") nil t)) - + (skip-chars-forward filename-chars)) (error "No file found around point!")) - ;; Return string. (expand-file-name (concat prefix (buffer-substring start (point))))))) -(defun read-filename-at-point (prompt) +(defun dired-x-read-filename-at-point (prompt) "Return filename prompting with PROMPT with completion. If `current-prefix-arg' is non-nil, uses name at point as guess." (if current-prefix-arg @@ -1716,6 +1690,9 @@ If `current-prefix-arg' is non-nil, uses name at point as guess." guess nil (file-name-nondirectory guess))) (read-file-name prompt default-directory))) + +(define-obsolete-function-alias 'read-filename-at-point + 'dired-x-read-filename-at-point "24.1") ; is this even needed? ;;; BUG REPORTS diff --git a/lisp/dired.el b/lisp/dired.el index 058dbdc548a..22d9f91648c 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -4029,7 +4029,7 @@ true then the type of the file linked to by FILE is printed instead. ;;;*** ;;;### (autoloads (dired-do-relsymlink dired-jump) "dired-x" "dired-x.el" -;;;;;; "d35468f85920d324895b0c04bb703328") +;;;;;; "a2af6147cf06b53166d9e1a3bb200675") ;;; Generated autoloads from dired-x.el (autoload 'dired-jump "dired-x" "\ diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 695dc1e2db6..b3c95fcc78f 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -1877,6 +1877,7 @@ BUFFER-NAME, if non-nil, is the buffer name to use." (let ((inhibit-read-only t)) (buffer-disable-undo) (erase-buffer) + (ert-results-mode) ;; Erase buffer again in case switching out of the previous ;; mode inserted anything. (This happens e.g. when switching ;; from ert-results-mode to ert-results-mode when @@ -1895,9 +1896,8 @@ BUFFER-NAME, if non-nil, is the buffer name to use." (ewoc-enter-last ewoc (make-ert--ewoc-entry :test test :hidden-p t))) (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) - (goto-char (1- (point-max))))) - (ert-results-mode) - buffer))) + (goto-char (1- (point-max))) + buffer))))) (defvar ert--selector-history nil @@ -2343,6 +2343,7 @@ To be used in the ERT results buffer." (let ((inhibit-read-only t)) (buffer-disable-undo) (erase-buffer) + (ert-simple-view-mode) ;; Use unibyte because `debugger-setup-buffer' also does so. (set-buffer-multibyte nil) (setq truncate-lines t) @@ -2351,8 +2352,7 @@ To be used in the ERT results buffer." (goto-char (point-min)) (insert "Backtrace for test `") (ert-insert-test-name-button (ert-test-name test)) - (insert "':\n") - (ert-simple-view-mode))))))) + (insert "':\n"))))))) (defun ert-results-pop-to-messages-for-test-at-point () "Display the part of the *Messages* buffer generated during the test at point. @@ -2368,12 +2368,12 @@ To be used in the ERT results buffer." (let ((inhibit-read-only t)) (buffer-disable-undo) (erase-buffer) + (ert-simple-view-mode) (insert (ert-test-result-messages result)) (goto-char (point-min)) (insert "Messages for test `") (ert-insert-test-name-button (ert-test-name test)) - (insert "':\n") - (ert-simple-view-mode))))) + (insert "':\n"))))) (defun ert-results-pop-to-should-forms-for-test-at-point () "Display the list of `should' forms executed during the test at point. @@ -2389,6 +2389,7 @@ To be used in the ERT results buffer." (let ((inhibit-read-only t)) (buffer-disable-undo) (erase-buffer) + (ert-simple-view-mode) (if (null (ert-test-result-should-forms result)) (insert "\n(No should forms during this test.)\n") (loop for form-description in (ert-test-result-should-forms result) @@ -2406,8 +2407,7 @@ To be used in the ERT results buffer." (insert (concat "(Values are shallow copies and may have " "looked different during the test if they\n" "have been modified destructively.)\n")) - (forward-line 1) - (ert-simple-view-mode))))) + (forward-line 1))))) (defun ert-results-toggle-printer-limits-for-test-at-point () "Toggle how much of the condition to print for the test at point. @@ -2442,6 +2442,7 @@ To be used in the ERT results buffer." (let ((inhibit-read-only t)) (buffer-disable-undo) (erase-buffer) + (ert-simple-view-mode) (if (null data) (insert "(No data)\n") (insert (format "%-3s %8s %8s\n" "" "time" "cumul")) @@ -2454,8 +2455,7 @@ To be used in the ERT results buffer." (insert "\n")))) (goto-char (point-min)) (insert "Tests by run time (seconds):\n\n") - (forward-line 1) - (ert-simple-view-mode)))) + (forward-line 1)))) ;;;###autoload (defun ert-describe-test (test-or-test-name) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 24ea0a3e801..3179672a3ec 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -61,6 +61,8 @@ UPatterns can take the following forms: `QPAT matches if the QPattern QPAT matches. (pred PRED) matches if PRED applied to the object returns non-nil. (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. +If a SYMBOL is used twice in the same pattern (i.e. the pattern is +\"non-linear\"), then the second occurrence is turned into an `eq'uality test. QPatterns can take the following forms: (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr. @@ -457,7 +459,12 @@ and otherwise defers to REST which is a list of branches of the form (pcase--u1 matches code vars then-rest) (pcase--u else-rest)))) ((symbolp upat) - (pcase--u1 matches code (cons (cons upat sym) vars) rest)) + (if (not (assq upat vars)) + (pcase--u1 matches code (cons (cons upat sym) vars) rest) + ;; Non-linear pattern. Turn it into an `eq' test. + (pcase--u1 (cons `(match ,sym . (pred (eq ,(cdr (assq upat vars))))) + matches) + code vars rest))) ((eq (car-safe upat) '\`) (pcase--q1 sym (cadr upat) matches code vars rest)) ((eq (car-safe upat) 'or) diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 91ba9e5a359..b40c6b7d60f 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,81 @@ +2011-02-18 Lars Ingebrigtsen <larsi@gnus.org> + + * auth-source.el (auth-source-search): Don't try to create credentials + if the caller doesn't want that. + + * nnimap.el (nnimap-log-command): Add a newline to the inhibited + logging. + (nnimap-credentials): Protect against auth-source-search returning nil. + (nnimap-request-list): Protect against not being able to open the + server. + +2011-02-17 Lars Ingebrigtsen <larsi@gnus.org> + + * auth-source.el (auth-source-search): Do a two-phase search, one with + no :create to get the responses from all backends. + + * nnimap.el (nnimap-open-connection-1): Delete duplicate server names + when getting credentials. + + * gnus-util.el (gnus-delete-duplicates): New function. + +2011-02-17 Teodor Zlatanov <tzz@lifelogs.com> + + * nnimap.el (nnimap-credentials): Instead of picking the first port as + a creation default, pass the whole port list down. It will be + completed. + + * auth-source.el (auth-source-search): Updated docs to talk about + multiple creation choices. + (auth-source-netrc-create): Accept a list as a value (from the search + parameters) and do completion on that list. Keep a separate netrc line + with the password obscured for showing the user. + + * nnimap.el (nnimap-open-connection-1): Make the `nnimap-address' the + first choice to `auth-source-search' so it will be used for entry + creation instead of the server's Gnus-specific name. + (nnimap-credentials): Rely on the auth-source library to select which + port is actually wanted in the new netrc entry, so don't override + `auth-source-creation-defaults'. + + * auth-source.el (auth-source-netrc-parse): Use :port instead of + :protocol and accept a missing user, host, or port as a wildcard match. + (auth-source-debug): Default to off. + + (auth-source-netrc-search, auth-source-netrc-create) + (auth-source-secrets-search, auth-source-secrets-create) + (auth-source-user-or-password, auth-source-backend, auth-sources) + (auth-source-backend-parse-parameters, auth-source-search): Use :port + instead of :protocol. + + * nnimap.el (nnimap-credentials): Pass a port default to + `auth-source-search' in case an entry needs to be created. + (nnimap-open-connection-1): Use :port instead of :protocol. + +2011-02-17 Katsumi Yamaoka <yamaoka@jpl.org> + + * auth-source.el (auth-source-secrets-search): Use mm-delete-duplicates + instead of delete-dups that is not available in XEmacs 21.4. + +2011-02-16 Lars Ingebrigtsen <larsi@gnus.org> + + * gnus-sum.el (gnus-propagate-marks): Change default to t again, since + nil means that nnimap doesn't get updated. + +2011-02-16 Teodor Zlatanov <tzz@lifelogs.com> + + * auth-source.el (auth-source-netrc-create): Return a synthetic search + result when the user doesn't want to write to the file. + (auth-source-netrc-search): Expect a synthetic result and proceed + accordingly. + (auth-source-cache-expiry): New variable to override + `password-cache-expiry'. + (auth-source-remember): Use it. + + * nnimap.el (nnimap-credentials): Remove the `inhibit-create' + parameter. Create entry if necessary by using :create t. + (nnimap-open-connection-1): Don't pass `inhibit-create'. + 2011-02-15 Teodor Zlatanov <tzz@lifelogs.com> * auth-source.el (auth-source-debug): Enable by default and don't diff --git a/lisp/gnus/auth-source.el b/lisp/gnus/auth-source.el index a259c5c2f0b..4fdf521b1a9 100644 --- a/lisp/gnus/auth-source.el +++ b/lisp/gnus/auth-source.el @@ -40,6 +40,7 @@ ;;; Code: (require 'password-cache) +(require 'mm-util) (require 'gnus-util) (require 'netrc) (require 'assoc) @@ -61,6 +62,18 @@ :version "23.1" ;; No Gnus :group 'gnus) +;;;###autoload +(defcustom auth-source-cache-expiry 7200 + "How many seconds passwords are cached, or nil to disable +expiring. Overrides `password-cache-expiry' through a +let-binding." + :group 'auth-source + :type '(choice (const :tag "Never" nil) + (const :tag "All Day" 86400) + (const :tag "2 Hours" 7200) + (const :tag "30 Minutes" 1800) + (integer :tag "Seconds"))) + (defclass auth-source-backend () ((type :initarg :type :initform 'netrc @@ -81,11 +94,11 @@ :type t :custom string :documentation "The backend user.") - (protocol :initarg :protocol - :initform t - :type t - :custom string - :documentation "The backend protocol.") + (port :initarg :port + :initform t + :type t + :custom string + :documentation "The backend protocol.") (create-function :initarg :create-function :initform ignore :type function @@ -135,7 +148,7 @@ :version "23.2" ;; No Gnus :type `boolean) -(defcustom auth-source-debug t +(defcustom auth-source-debug nil "Whether auth-source should log debug messages. If the value is nil, debug messages are not logged. @@ -200,7 +213,7 @@ can get pretty complex." :tag "Regular expression"))) (list :tag "Protocol" - (const :format "" :value :protocol) + (const :format "" :value :port) (choice :tag "Protocol" (const :tag "Any" t) @@ -253,19 +266,19 @@ If the value is not a list, symmetric encryption will be used." msg)) -;; (auth-source-pick nil :host "any" :protocol 'imap :user "joe") -;; (auth-source-pick t :host "any" :protocol 'imap :user "joe") -;; (setq auth-sources '((:source (:secrets default) :host t :protocol t :user "joe") -;; (:source (:secrets "session") :host t :protocol t :user "joe") -;; (:source (:secrets "Login") :host t :protocol t) -;; (:source "~/.authinfo.gpg" :host t :protocol t))) +;; (auth-source-pick nil :host "any" :port 'imap :user "joe") +;; (auth-source-pick t :host "any" :port 'imap :user "joe") +;; (setq auth-sources '((:source (:secrets default) :host t :port t :user "joe") +;; (:source (:secrets "session") :host t :port t :user "joe") +;; (:source (:secrets "Login") :host t :port t) +;; (:source "~/.authinfo.gpg" :host t :port t))) -;; (setq auth-sources '((:source (:secrets default) :host t :protocol t :user "joe") -;; (:source (:secrets "session") :host t :protocol t :user "joe") -;; (:source (:secrets "Login") :host t :protocol t) +;; (setq auth-sources '((:source (:secrets default) :host t :port t :user "joe") +;; (:source (:secrets "session") :host t :port t :user "joe") +;; (:source (:secrets "Login") :host t :port t) ;; )) -;; (setq auth-sources '((:source "~/.authinfo.gpg" :host t :protocol t))) +;; (setq auth-sources '((:source "~/.authinfo.gpg" :host t :port t))) ;; (auth-source-backend-parse "myfile.gpg") ;; (auth-source-backend-parse 'default) @@ -342,8 +355,8 @@ If the value is not a list, symmetric encryption will be used." (defun auth-source-backend-parse-parameters (entry backend) "Fills in the extra auth-source-backend parameters of ENTRY. -Using the plist ENTRY, get the :host, :protocol, and :user search -parameters. Accepts :port as an alias to :protocol." +Using the plist ENTRY, get the :host, :port, and :user search +parameters." (let ((entry (if (stringp entry) nil entry)) @@ -352,15 +365,14 @@ parameters. Accepts :port as an alias to :protocol." (oset backend host val)) (when (setq val (plist-get entry :user)) (oset backend user val)) - ;; accept :port as an alias for :protocol - (when (setq val (or (plist-get entry :protocol) (plist-get entry :port))) - (oset backend protocol val))) + (when (setq val (plist-get entry :port)) + (oset backend port val))) backend) ;; (mapcar 'auth-source-backend-parse auth-sources) (defun* auth-source-search (&rest spec - &key type max host user protocol secret + &key type max host user port secret create delete &allow-other-keys) "Search or modify authentication backends according to SPEC. @@ -373,7 +385,7 @@ other properties will always hold scalar values. Typically the :secret property, if present, contains a password. -Common search keys are :max, :host, :protocol, and :user. In +Common search keys are :max, :host, :port, and :user. In addition, :create specifies how tokens will be or created. Finally, :type can specify which backend types you want to check. @@ -387,7 +399,7 @@ any of the search terms matches). A new token will be created if no matching tokens were found. The new token will have only the keys the backend requires. For the netrc backend, for instance, that's the user, host, and -protocol keys. +port keys. Here's an example: @@ -403,11 +415,11 @@ which says: 'netrc', maximum one result. Create a new entry if you found none. The netrc backend will - automatically require host, user, and protocol. The host will be + automatically require host, user, and port. The host will be 'mine'. We prompt for the user with default 'defaultUser' and - for the protocol without a default. We will not prompt for A, Q, + for the port without a default. We will not prompt for A, Q, or P. The resulting token will only have keys user, host, and - protocol.\" + port.\" :create '(A B C) also means to create a token if possible. @@ -432,17 +444,17 @@ which says: or 'twosuch' in backends of type 'netrc', maximum one result. Create a new entry if you found none. The netrc backend will - automatically require host, user, and protocol. The host will be + automatically require host, user, and port. The host will be 'nonesuch' and Q will be 'qqqq'. We prompt for A with default - 'default A', for B and protocol with default nil, and for the + 'default A', for B and port with default nil, and for the user with default 'defaultUser'. We will not prompt for Q. The - resulting token will have keys user, host, protocol, A, B, and Q. + resulting token will have keys user, host, port, A, B, and Q. It will not have P with any value, even though P is used in the search to find only entries that have P set to 'pppp'.\" When multiple values are specified in the search parameter, the -first one is used for creation. So :host (X Y Z) would create a -token for host X, for instance. +user is prompted for which one. So :host (X Y Z) would ask the +user to choose between X, Y, and Z. This creation can fail if the search was not specific enough to create a new token (it's up to the backend to decide that). You @@ -468,14 +480,14 @@ the match rules above. Defaults to t. :user (X Y Z) means to match only users X, Y, or Z according to the match rules above. Defaults to t. -:protocol (P Q R) means to match only protocols P, Q, or R. +:port (P Q R) means to match only protocols P, Q, or R. Defaults to t. :K (V1 V2 V3) for any other key K will match values V1, V2, or V3 (note the match rules above). The return value is a list with at most :max tokens. Each token -is a plist with keys :backend :host :protocol :user, plus any other +is a plist with keys :backend :host :port :user, plus any other keys provided by the backend (notably :secret). But note the exception for :max 0, which see above. @@ -488,7 +500,7 @@ must call it to obtain the actual value." unless (memq (nth i spec) ignored-keys) collect (nth i spec))) (found (auth-source-recall spec)) - filtered-backends accessor-key found-here goal) + filtered-backends accessor-key found-here goal matches) (if (and found auth-source-do-cache) (auth-source-do-debug @@ -517,38 +529,58 @@ must call it to obtain the actual value." ;; (debug spec "filtered" filtered-backends) (setq goal max) - (dolist (backend filtered-backends) - (setq found-here (apply - (slot-value backend 'search-function) - :backend backend - :create create - :delete delete - spec)) - - ;; if max is 0, as soon as we find something, return it - (when (and (zerop max) (> 0 (length found-here))) - (return t)) - - ;; decrement the goal by the number of new results - (decf goal (length found-here)) - ;; and append the new results to the full list - (setq found (append found found-here)) - - (auth-source-do-debug - "auth-source-search: found %d results (max %d/%d) in %S matching %S" - (length found-here) max goal backend spec) - - ;; return full list if the goal is 0 or negative - (when (zerop (max 0 goal)) - (return found)) - - ;; change the :max parameter in the spec to the goal - (setq spec (plist-put spec :max goal))) - - (when (and found auth-source-do-cache) - (auth-source-remember spec found))) - - found)) + ;; First go through all the backends without :create, so we can + ;; query them all. + (let ((uspec (copy-sequence spec))) + (plist-put uspec :create nil) + (dolist (backend filtered-backends) + (let ((match (apply + (slot-value backend 'search-function) + :backend backend + uspec))) + (when match + (push (list backend match) matches))))) + ;; If we didn't find anything, then we allow the backend(s) to + ;; create the entries. + (when (and create + (not matches)) + (let ((match (apply + (slot-value backend 'search-function) + :backend backend + :create create + :delete delete + spec))) + (when match + (push (list backend match) matches)))) + + (setq backend (caar matches) + found-here (cadar matches)) + + (block nil + ;; if max is 0, as soon as we find something, return it + (when (and (zerop max) (> 0 (length found-here))) + (return t)) + + ;; decrement the goal by the number of new results + (decf goal (length found-here)) + ;; and append the new results to the full list + (setq found (append found found-here)) + + (auth-source-do-debug + "auth-source-search: found %d results (max %d/%d) in %S matching %S" + (length found-here) max goal backend spec) + + ;; return full list if the goal is 0 or negative + (when (zerop (max 0 goal)) + (return found)) + + ;; change the :max parameter in the spec to the goal + (setq spec (plist-put spec :max goal)) + + (when (and found auth-source-do-cache) + (auth-source-remember spec found)))) + + found)) ;;; (auth-source-search :max 1) ;;; (funcall (plist-get (nth 0 (auth-source-search :max 1)) :secret)) @@ -588,8 +620,9 @@ Returns the deleted entries." (defun auth-source-remember (spec found) "Remember FOUND search results for SPEC." - (password-cache-add - (concat auth-source-magic (format "%S" spec)) found)) + (let ((password-cache-expiry auth-source-cache-expiry)) + (password-cache-add + (concat auth-source-magic (format "%S" spec)) found))) (defun auth-source-recall (spec) "Recall FOUND search results for SPEC." @@ -648,7 +681,7 @@ while \(:host t) would find all host entries." ;;; (auth-source-netrc-parse "~/.authinfo.gpg") (defun* auth-source-netrc-parse (&rest spec - &key file max host user protocol delete + &key file max host user port delete &allow-other-keys) "Parse FILE and return a list of all entries in the file. Note that the MAX parameter is used so we can exit the parse early." @@ -710,18 +743,21 @@ Note that the MAX parameter is used so we can exit the parse early." host (or (aget alist "machine") - (aget alist "host"))) + (aget alist "host") + t)) (auth-source-search-collection user (or (aget alist "login") (aget alist "account") - (aget alist "user"))) + (aget alist "user") + t)) (auth-source-search-collection - protocol + port (or (aget alist "port") - (aget alist "protocol")))) + (aget alist "protocol") + t))) (decf max) (push (nreverse alist) result) ;; to delete a line, we just comment it out @@ -787,7 +823,7 @@ Note that the MAX parameter is used so we can exit the parse early." (defun* auth-source-netrc-search (&rest spec &key backend create delete - type max host user protocol + type max host user port &allow-other-keys) "Given a property list SPEC, return search matches from the :backend. See `auth-source-search' for details on SPEC." @@ -802,20 +838,23 @@ See `auth-source-search' for details on SPEC." :file (oref backend source) :host (or host t) :user (or user t) - :protocol (or protocol t))))) + :port (or port t))))) ;; if we need to create an entry AND none were found to match (when (and create (= 0 (length results))) - ;; create based on the spec - (apply (slot-value backend 'create-function) spec) - ;; turn off the :create key - (setq spec (plist-put spec :create nil)) - ;; run the search again to get the updated data - ;; the result will be returned, even if the search fails - (setq results (apply 'auth-source-netrc-search spec))) - + ;; create based on the spec and record the value + (setq results (or + ;; if the user did not want to create the entry + ;; in the file, it will be returned + (apply (slot-value backend 'create-function) spec) + ;; if not, we do the search again without :create + ;; to get the updated data. + + ;; the result will be returned, even if the search fails + (apply 'auth-source-netrc-search + (plist-put spec :create nil))))) results)) ;;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t) @@ -823,26 +862,33 @@ See `auth-source-search' for details on SPEC." (defun* auth-source-netrc-create (&rest spec &key backend - secret host user protocol create + secret host user port create &allow-other-keys) - (let* ((base-required '(host user protocol secret)) + (let* ((base-required '(host user port secret)) ;; we know (because of an assertion in auth-source-search) that the ;; :create parameter is either t or a list (which includes nil) (create-extra (if (eq t create) nil create)) (required (append base-required create-extra)) (file (oref backend source)) (add "") + (show "") ;; `valist' is an alist - valist) + valist + ;; `artificial' will be returned if no creation is needed + artificial) ;; only for base required elements (defined as function parameters): ;; fill in the valist with whatever data we may have from the search - ;; we take the first value if it's a list, the whole value otherwise + ;; we complete the first value if it's a list and use the value otherwise (dolist (br base-required) (when (symbol-value br) - (aput 'valist br (if (listp (symbol-value br)) - (nth 0 (symbol-value br)) - (symbol-value br))))) + (let ((br-choice (cond + ;; all-accepting choice (predicate is t) + ((eq t (symbol-value br)) nil) + ;; just the value otherwise + (t (symbol-value br))))) + (when br-choice + (aput 'valist br br-choice))))) ;; for extra required elements, see if the spec includes a value for them (dolist (er create-extra) @@ -862,7 +908,7 @@ See `auth-source-search' for details on SPEC." ((and (not given-default) (eq r 'user)) (user-login-name)) ;; note we need this empty string - ((and (not given-default) (eq r 'protocol)) + ((and (not given-default) (eq r 'port)) "") (t given-default))) ;; the prompt's default string depends on the data so far @@ -872,20 +918,22 @@ See `auth-source-search' for details on SPEC." ;; the prompt should also show what's entered so far (user-value (aget valist 'user)) (host-value (aget valist 'host)) - (protocol-value (aget valist 'protocol)) + (port-value (aget valist 'port)) + ;; note this handles lists by just printing them + ;; later we allow the user to use completing-read to pick (info-so-far (concat (if user-value (format "%s@" user-value) "[USER?]") (if host-value (format "%s" host-value) "[HOST?]") - (if protocol-value + (if port-value ;; this distinguishes protocol between - (if (zerop (length protocol-value)) + (if (zerop (length port-value)) "" ; 'entered as "no default"' vs. - (format ":%s" protocol-value)) ; given + (format ":%s" port-value)) ; given ;; and this is when the protocol is unknown - "[PROTOCOL?]")))) + "[PORT?]")))) ;; now prompt if the search SPEC did not include a required key; ;; take the result and put it in `data' AND store it in `valist' @@ -900,25 +948,48 @@ See `auth-source-search' for details on SPEC." (format "Enter %s for %s%s: " r info-so-far default-string) nil nil default)) + ((listp data) + (completing-read + (format "Enter %s for %s (TAB to see the choices): " + r info-so-far) + data + nil ; no predicate + t ; require a match + ;; note the default is nil, but if the user + ;; hits RET we'll get "", which is handled OK later + nil)) (t data)))) + (when data + (setq artificial (plist-put artificial + (intern (concat ":" (symbol-name r))) + (if (eq r 'secret) + (lexical-let ((data data)) + (lambda () data)) + data)))) + ;; when r is not an empty string... (when (and (stringp data) (< 0 (length data))) - ;; append the key (the symbol name of r) and the value in r - (setq add (concat add - (format "%s%s %S" - ;; prepend a space - (if (zerop (length add)) "" " ") - ;; remap auth-source tokens to netrc - (case r + (let ((printer (lambda (hide) + ;; append the key (the symbol name of r) + ;; and the value in r + (format "%s%s %S" + ;; prepend a space + (if (zerop (length add)) "" " ") + ;; remap auth-source tokens to netrc + (case r ('user "login") ('host "machine") ('secret "password") - ('protocol "port") + ('port "port") ; redundant but clearer (t (symbol-name r))) - ;; the value will be printed in %S format - data)))))) + ;; the value will be printed in %S format + (if (and hide (eq r 'secret)) + "HIDDEN_SECRET" + data))))) + (setq add (concat add (funcall printer nil))) + (setq show (concat show (funcall printer t))))))) (with-temp-buffer (when (file-exists-p file) @@ -935,14 +1006,17 @@ See `auth-source-search' for details on SPEC." (goto-char (point-max)) ;; ask AFTER we've successfully opened the file - (when (y-or-n-p (format "Add to file %s: line [%s]" file add)) - (unless (bolp) - (insert "\n")) - (insert add "\n") - (write-region (point-min) (point-max) file nil 'silent) - (auth-source-do-debug - "auth-source-netrc-create: wrote 1 new line to %s" - file))))) + (if (y-or-n-p (format "Add to file %s: line [%s]" file show)) + (progn + (unless (bolp) + (insert "\n")) + (insert add "\n") + (write-region (point-min) (point-max) file nil 'silent) + (auth-source-do-debug + "auth-source-netrc-create: wrote 1 new line to %s" + file) + nil) + (list artificial))))) ;;; Backend specific parsing: Secrets API backend @@ -956,7 +1030,7 @@ See `auth-source-search' for details on SPEC." (defun* auth-source-secrets-search (&rest spec &key backend create delete label - type max host user protocol + type max host user port &allow-other-keys) "Search the Secrets API; spec is like `auth-source'. @@ -1012,10 +1086,10 @@ authentication tokens: nil (list k (plist-get spec k)))) search-keys))) - ;; needed keys (always including host, login, protocol, and secret) - (returned-keys (delete-dups (append - '(:host :login :protocol :secret) - search-keys))) + ;; needed keys (always including host, login, port, and secret) + (returned-keys (mm-delete-duplicates (append + '(:host :login :port :secret) + search-keys))) (items (loop for item in (apply 'secrets-search-items coll search-spec) unless (and (stringp label) (not (string-match label item))) @@ -1051,7 +1125,7 @@ authentication tokens: (defun* auth-source-secrets-create (&rest spec - &key backend type max host user protocol + &key backend type max host user port &allow-other-keys) ;; TODO ;; (apply 'secrets-create-item (auth-get-source entry) name passwd spec) @@ -1068,8 +1142,8 @@ authentication tokens: 'auth-source-forget "Emacs 24.1") (defun auth-source-user-or-password - (mode host protocol &optional username create-missing delete-existing) - "Find MODE (string or list of strings) matching HOST and PROTOCOL. + (mode host port &optional username create-missing delete-existing) + "Find MODE (string or list of strings) matching HOST and PORT. DEPRECATED in favor of `auth-source-search'! @@ -1092,14 +1166,14 @@ stored in the password database which matches best (see MODE can be \"login\" or \"password\"." (auth-source-do-debug "auth-source-user-or-password: DEPRECATED get %s for %s (%s) + user=%s" - mode host protocol username) + mode host port username) (let* ((listy (listp mode)) (mode (if listy mode (list mode))) (cname (if username - (format "%s %s:%s %s" mode host protocol username) - (format "%s %s:%s" mode host protocol))) - (search (list :host host :protocol protocol)) + (format "%s %s:%s %s" mode host port username) + (format "%s %s:%s" mode host port))) + (search (list :host host :port port)) (search (if username (append search (list :user username)) search)) (search (if create-missing (append search (list :create t)) @@ -1121,7 +1195,7 @@ MODE can be \"login\" or \"password\"." (if (and (member "password" mode) t) "SECRET" found) - host protocol username) + host port username) found) ; return the found data ;; else, if not found, search with a max of 1 (let ((choice (nth 0 (apply 'auth-source-search diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 4dfc79a8883..619c8bd75fd 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -1234,11 +1234,10 @@ For example: ((1 . cn-gb-2312) (2 . big5))." :type 'boolean :group 'gnus-summary-marks) -(defcustom gnus-propagate-marks nil +(defcustom gnus-propagate-marks t "If non-nil, Gnus will store and retrieve marks from the backends. This means that marks will be stored both in .newsrc.eld and in the backend, and will slow operation down somewhat." - :version "24.1" :type 'boolean :group 'gnus-summary-marks) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 67c49096b92..42dbd5948cf 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -871,6 +871,15 @@ Bind `print-quoted' and `print-readably' to t, and `print-length' and (when (file-exists-p file) (delete-file file))) +(defun gnus-delete-duplicates (list) + "Remove duplicate entries from LIST." + (let ((result nil)) + (while list + (unless (member (car list) result) + (push (car list) result)) + (pop list)) + (nreverse result))) + (defun gnus-delete-directory (directory) "Delete files in DIRECTORY. Subdirectories remain. If there's no subdirectory, delete DIRECTORY as well." diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index a5a001f7e11..9c93ee8bbd9 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -276,18 +276,17 @@ textual parts.") (push (current-buffer) nnimap-process-buffers) (current-buffer))) -(defun nnimap-credentials (address ports &optional inhibit-create) - (let* ((found (nth 0 (auth-source-search :max 1 - :host address - :port ports - :create (if inhibit-create - nil - (null ports))))) - (user (plist-get found :user)) - (secret (plist-get found :secret)) - (secret (if (functionp secret) (funcall secret) secret))) +(defun nnimap-credentials (address ports) + (let ((found (nth 0 (auth-source-search :max 1 + :host address + :port ports + :create t)))) (if found - (list user secret) + (list (plist-get found :user) + (let ((secret (plist-get found :secret))) + (if (functionp secret) + (funcall secret) + secret))) nil))) (defun nnimap-keepalive () @@ -386,10 +385,11 @@ textual parts.") ;; Look for the credentials based on ;; the virtual server name and the address (nnimap-credentials - (list - (nnoo-current-server 'nnimap) - nnimap-address) - ports t)))) + (gnus-delete-duplicates + (list + nnimap-address + (nnoo-current-server 'nnimap))) + ports)))) (setq nnimap-object nil) (let ((nnimap-inhibit-logging t)) (setq login-result @@ -400,7 +400,7 @@ textual parts.") (dolist (host (list (nnoo-current-server 'nnimap) nnimap-address)) (dolist (port ports) - (auth-source-forget+ :host host :protocol port))) + (auth-source-forget+ :host host :port port))) (delete-process (nnimap-process nnimap-object)) (setq nnimap-object nil)))) (when nnimap-object @@ -1075,60 +1075,62 @@ textual parts.") (nreverse groups))) (deffoo nnimap-request-list (&optional server) - (nnimap-possibly-change-group nil server) - (with-current-buffer nntp-server-buffer - (erase-buffer) - (let ((groups - (with-current-buffer (nnimap-buffer) - (nnimap-get-groups))) - sequences responses) - (when groups - (with-current-buffer (nnimap-buffer) - (setf (nnimap-group nnimap-object) nil) - (dolist (group groups) - (setf (nnimap-examined nnimap-object) group) - (push (list (nnimap-send-command "EXAMINE %S" (utf7-encode group t)) - group) - sequences)) - (nnimap-wait-for-response (caar sequences)) - (setq responses - (nnimap-get-responses (mapcar #'car sequences)))) - (dolist (response responses) - (let* ((sequence (car response)) - (response (cadr response)) - (group (cadr (assoc sequence sequences)))) - (when (and group - (equal (caar response) "OK")) - (let ((uidnext (nnimap-find-parameter "UIDNEXT" response)) - highest exists) - (dolist (elem response) - (when (equal (cadr elem) "EXISTS") - (setq exists (string-to-number (car elem))))) - (when uidnext - (setq highest (1- (string-to-number (car uidnext))))) - (cond - ((null highest) - (insert (format "%S 0 1 y\n" (utf7-decode group t)))) - ((zerop exists) - ;; Empty group. - (insert (format "%S %d %d y\n" - (utf7-decode group t) highest (1+ highest)))) - (t - ;; Return the widest possible range. - (insert (format "%S %d 1 y\n" (utf7-decode group t) - (or highest exists))))))))) - t)))) + (when (nnimap-possibly-change-group nil server) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (let ((groups + (with-current-buffer (nnimap-buffer) + (nnimap-get-groups))) + sequences responses) + (when groups + (with-current-buffer (nnimap-buffer) + (setf (nnimap-group nnimap-object) nil) + (dolist (group groups) + (setf (nnimap-examined nnimap-object) group) + (push (list (nnimap-send-command "EXAMINE %S" + (utf7-encode group t)) + group) + sequences)) + (nnimap-wait-for-response (caar sequences)) + (setq responses + (nnimap-get-responses (mapcar #'car sequences)))) + (dolist (response responses) + (let* ((sequence (car response)) + (response (cadr response)) + (group (cadr (assoc sequence sequences)))) + (when (and group + (equal (caar response) "OK")) + (let ((uidnext (nnimap-find-parameter "UIDNEXT" response)) + highest exists) + (dolist (elem response) + (when (equal (cadr elem) "EXISTS") + (setq exists (string-to-number (car elem))))) + (when uidnext + (setq highest (1- (string-to-number (car uidnext))))) + (cond + ((null highest) + (insert (format "%S 0 1 y\n" (utf7-decode group t)))) + ((zerop exists) + ;; Empty group. + (insert (format "%S %d %d y\n" + (utf7-decode group t) + highest (1+ highest)))) + (t + ;; Return the widest possible range. + (insert (format "%S %d 1 y\n" (utf7-decode group t) + (or highest exists))))))))) + t))))) (deffoo nnimap-request-newgroups (date &optional server) - (nnimap-possibly-change-group nil server) - (with-current-buffer nntp-server-buffer - (erase-buffer) - (dolist (group (with-current-buffer (nnimap-buffer) - (nnimap-get-groups))) - (unless (assoc group nnimap-current-infos) - ;; Insert dummy numbers here -- they don't matter. - (insert (format "%S 0 1 y\n" group)))) - t)) + (when (nnimap-possibly-change-group nil server) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (dolist (group (with-current-buffer (nnimap-buffer) + (nnimap-get-groups))) + (unless (assoc group nnimap-current-infos) + ;; Insert dummy numbers here -- they don't matter. + (insert (format "%S 0 1 y\n" group)))) + t))) (deffoo nnimap-retrieve-group-data-early (server infos) (when (nnimap-possibly-change-group nil server) @@ -1589,7 +1591,7 @@ textual parts.") (goto-char (point-max)) (insert (format-time-string "%H:%M:%S") " " (if nnimap-inhibit-logging - "(inhibited)" + "(inhibited)\n" command))) command) diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 8657dc58bf4..1d419dbfa18 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -556,6 +556,11 @@ If ARG is non-nil, instead prompt for connection parameters." `(with-current-buffer rcirc-server-buffer ,@body)) +(defun rcirc-float-time () + (if (featurep 'xemacs) + (time-to-seconds (current-time)) + (float-time))) + (defun rcirc-keepalive () "Send keep alive pings to active rcirc processes. Kill processes that have not received a server message since the @@ -567,10 +572,7 @@ last ping." (rcirc-send-ctcp process rcirc-nick (format "KEEPALIVE %f" - (if (featurep 'xemacs) - (time-to-seconds - (current-time)) - (float-time))))))) + (rcirc-float-time)))))) (rcirc-process-list)) ;; no processes, clean up timer (cancel-timer rcirc-keepalive-timer) @@ -578,10 +580,7 @@ last ping." (defun rcirc-handler-ctcp-KEEPALIVE (process target sender message) (with-rcirc-process-buffer process - (setq header-line-format (format "%f" (- (if (featurep 'xemacs) - (time-to-seconds - (current-time)) - (float-time)) + (setq header-line-format (format "%f" (- (rcirc-float-time) (string-to-number message)))))) (defvar rcirc-debug-buffer " *rcirc debug*") @@ -2209,7 +2208,7 @@ With a prefix arg, prompt for new topic." (defun rcirc-ctcp-sender-PING (process target request) "Send a CTCP PING message to TARGET." - (let ((timestamp (format "%.0f" (float-time)))) + (let ((timestamp (format "%.0f" (rcirc-float-time)))) (rcirc-send-ctcp process target "PING" timestamp))) (defun rcirc-cmd-me (args &optional process target) diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el new file mode 100644 index 00000000000..b4307223ba8 --- /dev/null +++ b/lisp/net/soap-client.el @@ -0,0 +1,1741 @@ +;;;; soap-client.el -- Access SOAP web services from Emacs + +;; Copyright (C) 2009-2011 Free Software Foundation, Inc. + +;; Author: Alexandru Harsanyi (AlexHarsanyi@gmail.com) +;; Created: December, 2009 +;; Keywords: soap, web-services, comm, hypermedia +;; Homepage: http://code.google.com/p/emacs-soap-client + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; To use the SOAP client, you first need to load the WSDL document for the +;; service you want to access, using `soap-load-wsdl-from-url'. A WSDL +;; document describes the available operations of the SOAP service, how their +;; parameters and responses are encoded. To invoke operations, you use the +;; `soap-invoke' method passing it the WSDL, the service name, the operation +;; you wish to invoke and any required parameters. +;; +;; Idealy, the service you want to access will have some documentation about +;; the operations it supports. If it does not, you can try using +;; `soap-inspect' to browse the WSDL document and see the available operations +;; and their parameters. +;; + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'xml) +(require 'warnings) +(require 'url) +(require 'url-http) +(require 'url-util) +(require 'mm-decode) + +(defsubst soap-warning (message &rest args) + "Display a warning MESSAGE with ARGS, using the 'soap-client warning type." + (display-warning 'soap-client (apply 'format message args) :warning)) + +(defgroup soap-client nil + "Access SOAP web services from Emacs." + :group 'tools) + +;;;; Support for parsing XML documents with namespaces + +;; XML documents with namespaces are difficult to parse because the names of +;; the nodes depend on what "xmlns" aliases have been defined in the document. +;; To work with such documents, we introduce a translation layer between a +;; "well known" namespace tag and the local namespace tag in the document +;; being parsed. + +(defconst soap-well-known-xmlns + '(("apachesoap" . "http://xml.apache.org/xml-soap") + ("soapenc" . "http://schemas.xmlsoap.org/soap/encoding/") + ("wsdl" . "http://schemas.xmlsoap.org/wsdl/") + ("wsdlsoap" . "http://schemas.xmlsoap.org/wsdl/soap/") + ("xsd" . "http://www.w3.org/2001/XMLSchema") + ("xsi" . "http://www.w3.org/2001/XMLSchema-instance") + ("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/")) + "A list of well known xml namespaces and their aliases.") + +(defvar soap-local-xmlns nil + "A list of local namespace aliases. +This is a dynamically bound variable, controlled by +`soap-with-local-xmlns'.") + +(defvar soap-default-xmlns nil + "The default XML namespaces. +Names in this namespace will be unqualified. This is a +dynamically bound variable, controlled by +`soap-with-local-xmlns'") + +(defvar soap-target-xmlns nil + "The target XML namespace. +New XSD elements will be defined in this namespace, unless they +are fully qualified for a different namespace. This is a +dynamically bound variable, controlled by +`soap-with-local-xmlns'") + +(defun soap-wk2l (well-known-name) + "Return local variant of WELL-KNOWN-NAME. +This is done by looking up the namespace in the +`soap-well-known-xmlns' table and resolving the namespace to +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))) + (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)))) + +(defun soap-l2wk (local-name) + "Convert LOCAL-NAME into a well known name. +The namespace of LOCAL-NAME is looked up in the +`soap-well-known-xmlns' table and a well known namespace tag is +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)) + 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))) + + (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) + (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))) + + +(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\"\). + +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' +will be used as the element's namespace, otherwise +`soap-default-xmlns' will be used. + +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))) + (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))))) + (t + (cons (if use-tns + soap-target-xmlns + soap-default-xmlns) + local-name))))) + +(defun soap-extract-xmlns (node &optional xmlns-table) + "Return a namespace alias table for NODE by extending XMLNS-TABLE." + (let (xmlns default-ns target-ns) + (dolist (a (xml-node-attributes node)) + (let ((name (symbol-name (car a))) + (value (cdr a))) + (cond ((string= name "targetNamespace") + (setq target-ns value)) + ((string= name "xmlns") + (setq default-ns value)) + ((string-match "^xmlns:\\(.*\\)$" name) + (push (cons (match-string 1 name) value) xmlns))))) + + (let ((tns (assoc "tns" xmlns))) + (cond ((and tns target-ns) + ;; If a tns alias is defined for this node, it must match + ;; the target namespace. + (unless (equal target-ns (cdr tns)) + (soap-warning + "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)))) + + (list default-ns target-ns (append xmlns xmlns-table)))) + +(defmacro soap-with-local-xmlns (node &rest body) + "Install a local alias table from NODE and execute BODY." + (declare (debug (form &rest form)) (indent 1)) + (let ((xmlns (make-symbol "xmlns"))) + `(let ((,xmlns (soap-extract-xmlns ,node soap-local-xmlns))) + (let ((soap-default-xmlns (or (nth 0 ,xmlns) soap-default-xmlns)) + (soap-target-xmlns (or (nth 1 ,xmlns) soap-target-xmlns)) + (soap-local-xmlns (nth 2 ,xmlns))) + ,@body)))) + +(defun soap-get-target-namespace (node) + "Return the target namespace of NODE. +This is the namespace in which new elements will be defined." + (or (xml-get-attribute-or-nil node 'targetNamespace) + (cdr (assoc "tns" soap-local-xmlns)) + soap-target-xmlns)) + +(defun soap-xml-get-children1 (node child-name) + "Return the children of NODE named CHILD-NAME. +This is the same as `xml-get-children', but CHILD-NAME can have +namespace tag." + (let (result) + (dolist (c (xml-node-children node)) + (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. + (eq (ignore-errors (soap-l2wk (xml-node-name c))) + child-name))) + (push c result))) + (nreverse result))) + +(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 +be tagged with a namespace tag." + (catch 'found + (soap-with-local-xmlns node + (dolist (a (xml-node-attributes node)) + ;; We use `ignore-errors' here because we want to silently skip + ;; attributes for which we cannot convert them to a well-known name. + (when (eq (ignore-errors (soap-l2wk (car a))) attribute) + (throw 'found (cdr a))))))) + + +;;;; XML namespaces + +;; An element in an XML namespace, "things" stored in soap-xml-namespaces will +;; be derived from this object. + +(defstruct soap-element + name + ;; The "well-known" namespace tag for the element. For example, while + ;; parsing XML documents, we can have different tags for the XMLSchema + ;; namespace, but internally all our XMLSchema elements will have the "xsd" + ;; tag. + namespace-tag) + +(defun soap-element-fq-name (element) + "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))) + +;; a namespace link stores an alias for an object in once namespace to a +;; "target" object possibly in a different namespace + +(defstruct (soap-namespace-link (:include soap-element)) + target) + +;; A namespace is a collection of soap-element objects under a name (the name +;; of the namespace). + +(defstruct soap-namespace + (name nil :read-only t) ; e.g "http://xml.apache.org/xml-soap" + (elements (make-hash-table :test 'equal) :read-only t)) + +(defun soap-namespace-put (element ns) + "Store ELEMENT in NS. +Multiple elements with the same name can be stored in a +namespace. When retrieving the element you can specify a +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) + "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. + +If NAME is nil, an element with the same name as TARGET will be +added to the namespace." + + (unless (and name (not (equal name ""))) + ;; if name is nil, use TARGET as a name... + (cond ((soap-element-p target) + (setq name (soap-element-name target))) + ((stringp target) + (cond ((string-match "^\\(.*\\):\\(.*\\)$" target) + (setq name (match-string 2 target))) + (t + (setq name target)))))) + + (assert name) ; by now, name should be valid + (push (make-soap-namespace-link :name name :target target) + (gethash name (soap-namespace-elements ns)))) + +(defun soap-namespace-get (name ns &optional discriminant-predicate) + "Retrieve an element with NAME from the namespace NS. +If multiple elements with the same name exist, +DISCRIMINANT-PREDICATE is used to pick one of them. This allows +storing elements of different types (like a message type and a +binding) but the same name." + (assert (stringp name)) + (let ((elements (gethash name (soap-namespace-elements ns)))) + (cond (discriminant-predicate + (catch 'found + (dolist (e elements) + (when (funcall discriminant-predicate e) + (throw 'found e))))) + ((= (length elements) 1) (car elements)) + ((> (length elements) 1) + (error + "Soap-namespace-get(%s): multiple elements, discriminant needed" + name)) + (t + nil)))) + + +;;;; WSDL documents +;;;;; WSDL document elements + +(defstruct (soap-basic-type (:include soap-element)) + kind ; a symbol of: string, dateTime, long, int + ) + +(defstruct soap-sequence-element + name type nillable? multiple?) + +(defstruct (soap-sequence-type (:include soap-element)) + parent ; OPTIONAL WSDL-TYPE name + elements ; LIST of SOAP-SEQUCENCE-ELEMENT + ) + +(defstruct (soap-array-type (:include soap-element)) + element-type ; WSDL-TYPE of the array elements + ) + +(defstruct (soap-message (:include soap-element)) + parts ; ALIST of NAME => WSDL-TYPE name + ) + +(defstruct (soap-operation (:include soap-element)) + parameter-order + input ; (NAME . MESSAGE) + output ; (NAME . MESSAGE) + faults) ; a list of (NAME . MESSAGE) + +(defstruct (soap-port-type (:include soap-element)) + operations) ; a namespace of operations + +;; A bound operation is an operation which has a soap action and a use +;; method attached -- these are attached as part of a binding and we +;; can have different bindings for the same operations. +(defstruct soap-bound-operation + operation ; SOAP-OPERATION + soap-action ; value for SOAPAction HTTP header + use ; 'literal or 'encoded, see + ; http://www.w3.org/TR/wsdl#_soap:body + ) + +(defstruct (soap-binding (:include soap-element)) + port-type + (operations (make-hash-table :test 'equal) :readonly t)) + +(defstruct (soap-port (:include soap-element)) + 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" "float" + "base64Binary" "anyType" "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" "float" + "base64Binary" "anyType" "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 + origin ; file or URL from which this wsdl was loaded + ports ; a list of SOAP-PORT instances + alias-table ; a list of namespace aliases + namespaces ; a list of namespaces + ) + +(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))) + +(defun soap-wsdl-find-namespace (name wsdl) + "Find a namespace by NAME in the WSDL document." + (catch 'found + (dolist (ns (soap-wsdl-namespaces wsdl)) + (when (equal name (soap-namespace-name ns)) + (throw 'found ns))))) + +(defun soap-wsdl-add-namespace (ns wsdl) + "Add the namespace NS to the WSDL document. +If a namespace by this name already exists in WSDL, individual +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) + (dolist (v value) + (soap-namespace-put v existing))) + (soap-namespace-elements ns)) + (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. + +PREDICATE is used to differentiate between elements when NAME +refers to multiple elements. A typical value for this would be a +structure predicate for the type of element you want to retrieve. +For example, to retrieve a message named \"foo\" when other +elements named \"foo\" exist in the WSDL you could use: + + (soap-wsdl-get \"foo\" WSDL 'soap-message-p) + +If USE-LOCAL-ALIAS-TABLE is not nil, `soap-local-xmlns` will be +used to resolve the namespace alias." + (let ((alias-table (soap-wsdl-alias-table wsdl)) + namespace element-name element) + + (when (symbolp name) + (setq name (symbol-name name))) + + (when use-local-alias-table + (setq alias-table (append soap-local-xmlns alias-table))) + + (cond ((consp name) ; a fully qualified name, as returned by `soap-l2fq' + (setq element-name (cdr name)) + (when (symbolp element-name) + (setq element-name (symbol-name element-name))) + (setq namespace (soap-wsdl-find-namespace (car name) wsdl)) + (unless namespace + (error "Soap-wsdl-get(%s): unknown namespace: %s" name namespace))) + + ((string-match "^\\(.*\\):\\(.*\\)$" name) + (setq element-name (match-string 2 name)) + + (let* ((ns-alias (match-string 1 name)) + (ns-name (cdr (assoc ns-alias alias-table)))) + (unless ns-name + (error "Soap-wsdl-get(%s): cannot find namespace alias %s" + 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)))) + (t + (error "Soap-wsdl-get(%s): bad name" name))) + + (setq element (soap-namespace-get + element-name namespace + (if predicate + (lambda (e) + (or (funcall 'soap-namespace-link-p e) + (funcall predicate e))) + nil))) + + (unless element + (error "Soap-wsdl-get(%s): cannot find element" name)) + + (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))) + +;;;;; 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. + +If ELEMENT has no resolver function, it is silently ignored. + +All references are resolved in-place, that is the ELEMENT is +updated." + (let ((resolver (get (aref element 0) 'soap-resolve-references))) + (when resolver + (funcall resolver element wsdl)))) + +(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 'soap-type-p)))) + (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 'soap-type-p))) + ((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 'soap-type-p))))) + +(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'" + (let (resolved-parts) + (dolist (part (soap-message-parts message)) + (let ((name (car part)) + (type (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)))) + +(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 +`soap-wsdl-resolve-references'" + (let ((input (soap-operation-input operation)) + (counter 0)) + (let ((name (car input)) + (message (cdr input))) + ;; 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)) + (setf (soap-operation-input operation) + (cons (intern name) + (soap-wsdl-get message wsdl 'soap-message-p)))))) + + (let ((output (soap-operation-output operation)) + (counter 0)) + (let ((name (car output)) + (message (cdr output))) + (when (or (null name) (equal name "")) + (setq name (format "out%d" (incf counter)))) + (when (or (consp message) (stringp message)) + (setf (soap-operation-output operation) + (cons (intern name) + (soap-wsdl-get message wsdl 'soap-message-p)))))) + + (let ((resolved-faults nil) + (counter 0)) + (dolist (fault (soap-operation-faults operation)) + (let ((name (car fault)) + (message (cdr fault))) + (when (or (null name) (equal name "")) + (setq name (format "fault%d" (incf counter)))) + (if (or (consp message) (stringp message)) + (push (cons (intern name) + (soap-wsdl-get message wsdl 'soap-message-p)) + resolved-faults) + (push fault resolved-faults)))) + (setf (soap-operation-faults operation) resolved-faults)) + + (when (= (length (soap-operation-parameter-order operation)) 0) + (setf (soap-operation-parameter-order operation) + (mapcar 'car (soap-message-parts + (cdr (soap-operation-input operation)))))) + + (setf (soap-operation-parameter-order operation) + (mapcar (lambda (p) + (if (stringp p) + (intern 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 +`soap-wsdl-resolve-references'" + (when (or (consp (soap-binding-port-type binding)) + (stringp (soap-binding-port-type binding))) + (setf (soap-binding-port-type binding) + (soap-wsdl-get (soap-binding-port-type binding) + 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-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))) + (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-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 + 'soap-resolve-references-for-operation) + (put (aref (make-soap-binding) 0) 'soap-resolve-references + 'soap-resolve-references-for-binding) + (put (aref (make-soap-port) 0) 'soap-resolve-references + 'soap-resolve-references-for-port)) + +(defun soap-wsdl-resolve-references (wsdl) + "Resolve all references inside the WSDL structure. + +When the WSDL elements are created from the XML document, they +refer to each other by name. For example, the ELEMENT-TYPE slot +of an SOAP-ARRAY-TYPE will contain the name of the element and +the user would have to call `soap-wsdl-get' to obtain the actual +element. + +After the entire document is loaded, we resolve all these +references to the actual elements they refer to so that at +runtime, we don't have to call `soap-wsdl-get' each time we +traverse an element tree." + (let ((nprocessed 0) + (nstag-id 0) + (alias-table (soap-wsdl-alias-table wsdl))) + (dolist (ns (soap-wsdl-namespaces wsdl)) + (let ((nstag (car-safe (rassoc (soap-namespace-name ns) alias-table)))) + (unless nstag + ;; If this namespace does not have an alias, create one for it. + (catch 'done + (while t + (setq nstag (format "ns%d" (incf nstag-id))) + (unless (assoc nstag alias-table) + (soap-wsdl-add-alias nstag (soap-namespace-name ns) wsdl) + (throw 'done t))))) + + (maphash (lambda (name element) + (cond ((soap-element-p element) ; skip links + (incf nprocessed) + (soap-resolve-references-for-element element wsdl) + (setf (soap-element-namespace-tag element) nstag)) + ((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-namespace-elements ns)))) + + (message "Processed %d" nprocessed)) + 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") + (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))) + (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-with-local-xmlns node + + (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." + (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:complexType)) + (soap-namespace-put (soap-parse-complex-type node) ns)) + + (dolist (node (soap-xml-get-children1 node 'xsd:element)) + (soap-namespace-put (soap-parse-schema-element node) ns)) + + ns))) + +(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 + ((eq node-name 'xsd:sequence) + (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 (eq (soap-l2wk (xml-node-name node)) 'xsd:sequence) + nil + "soap-parse-sequence: expecting xsd:sequence 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 "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))) + + (if array? + (make-soap-array-type :element-type parent) + (make-soap-sequence-type :parent parent :elements elements)))) + +(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" + (soap-l2wk (xml-node-name node))) + (let ((name (xml-get-attribute-or-nil node 'name)) + parts) + (dolist (p (soap-xml-get-children1 node 'wsdl:part)) + (let ((name (xml-get-attribute-or-nil p 'name)) + (type (xml-get-attribute-or-nil p 'type)) + (element (xml-get-attribute-or-nil p 'element))) + + (when type + (setq type (soap-l2fq type 'tns))) + + (when element + (setq element (soap-l2fq element 'tns))) + + (push (cons name (or type 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" + (soap-l2wk (xml-node-name node))) + (let ((ns (make-soap-namespace + :name (concat "urn:" (xml-get-attribute node 'name))))) + (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))) + (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)) + + (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)) + + (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))) + + ))))) + + (make-soap-port-type :name (xml-get-attribute node 'name) + :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" + (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) + (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))))))) + (make-soap-operation + :name name + :parameter-order parameter-order + :input input + :output output + :faults (nreverse faults)))) + +(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" + (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)))) + (dolist (wo (soap-xml-get-children1 node 'wsdl:operation)) + (let ((name (xml-get-attribute wo 'name)) + soap-action + use) + (dolist (so (soap-xml-get-children1 wo 'wsdlsoap:operation)) + (setq soap-action (xml-get-attribute-or-nil so 'soapAction))) + + ;; Search a wsdlsoap:body node and find a "use" tag. The + ;; same use tag is assumed to be present for both input and + ;; output types (although the WDSL spec allows separate + ;; "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))))) + + (unless use + (dolist (i (soap-xml-get-children1 wo 'wsdl:output)) + (dolist (b (soap-xml-get-children1 i 'wsdlsoap:body)) + (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))) + (soap-binding-operations binding)))) + binding))) + +;;;; SOAP type decoding + +(defvar soap-multi-refs nil + "The list of multi-ref nodes in the current SOAP response. +This is a dynamically bound variable used during decoding the +SOAP response.") + +(defvar soap-decoded-multi-refs nil + "List of decoded multi-ref nodes in the current 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. + +NODE is an XML node, representing some SOAP encoded value or a +reference to another XML node (a multiRef). This function will +resolve the multiRef reference, if any, than call a TYPE specific +decode function to perform the actual decoding." + (let ((href (xml-get-attribute-or-nil node 'href))) + (cond (href + (catch 'done + ;; NODE is actually a HREF, find the target and decode that. + ;; Check first if we already decoded this multiref. + + (let ((decoded (cdr (assoc href soap-decoded-multi-refs)))) + (when decoded + (throw 'done decoded))) + + (string-match "^#\\(.*\\)$" href) ; TODO: check that it matched + + (let ((id (match-string 1 href))) + (dolist (mr soap-multi-refs) + (let ((mrid (xml-get-attribute mr 'id))) + (when (equal id mrid) + ;; recurse here, in case there are multiple HREF's + (let ((decoded (soap-decode-type type mr))) + (push (cons href decoded) soap-decoded-multi-refs) + (throw 'done decoded))))) + (error "Cannot find href %s" href)))) + (t + (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)))))))) + +(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))) + (if type + (let ((wtype (soap-wsdl-get type soap-current-wsdl 'soap-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))))))) + +(defun soap-decode-array (node) + "Decode NODE as an Array using type information inside it." + (let ((type (soap-xml-get-attribute-or-nil1 node 'soapenc:arrayType)) + (wtype nil) + (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))) + (dolist (e contents) + (when (consp e) + (push (if wtype + (soap-decode-type wtype 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 (car contents)) + (dateTime (car contents)) ; TODO: convert to a date time + ((long int float) (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) + (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 + +(put 'soap-error + 'error-conditions + '(error soap-error)) +(put 'soap-error 'error-message "SOAP error") + +(defun soap-parse-envelope (node operation wsdl) + "Parse the SOAP envelope in NODE and return the response. +OPERATION is the WSDL operation for which we expect the response, +WSDL is used to decode the NODE" + (soap-with-local-xmlns node + (assert (eq (soap-l2wk (xml-node-name node)) 'soap:Envelope) + nil + "soap-parse-envelope: expecting soap:Envelope node, got %s" + (soap-l2wk (xml-node-name node))) + (let ((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)))) + (car-safe (xml-node-children n)))) + (fault-string (let ((n (car (xml-get-children + fault 'faultstring)))) + (car-safe (xml-node-children n))))) + (while t + (signal 'soap-error (list fault-code fault-string)))))) + + ;; 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) + "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-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." + (let* ((soap-current-wsdl wsdl) + (op (soap-bound-operation-operation operation)) + (use (soap-bound-operation-use operation)) + (message (cdr (soap-operation-output op)))) + + (soap-with-local-xmlns 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))) + (unless (eq received-message message) + (error "Unexpected message: got %s, expecting %s" + received-message-name + (soap-element-name message))))) + + (let ((decoded-parts nil) + (soap-multi-refs (xml-get-children soap-body 'multiRef)) + (soap-decoded-multi-refs nil)) + + (dolist (part (soap-message-parts message)) + (let ((tag (car part)) + (type (cdr part)) + 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)))))))))) + + (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))) + + 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. + +This variable is dynamically bound in `soap-create-envelope'.") + +(defun soap-encode-value (xml-tag value type) + "Encode inside an XML-TAG the VALUE using TYPE. +The resulting XML data is inserted in the current buffer +at (point)/ + +TYPE is one of the soap-*-type structures which defines how VALUE +is to be encoded. This is a generic function which finds an +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)))) + + (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 + (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) + (unless (integerp value) + (error "Soap-encode-basic-type(%s, %s, %s): not an integer value" + xml-tag value xsi-type)) + (insert (number-to-string value))) + + (base64Binary + (unless (stringp value) + (error "Soap-encode-basic-type(%s, %s, %s): not a string value" + xml-tag value xsi-type)) + (insert (base64-encode-string value))) + + (otherwise + (error + "Soap-encode-basic-type(%s, %s, %s): don't know how to encode" + xml-tag value xsi-type)))) + + (insert " xsi:nil=\"true\">")) + (insert "</" xml-tag ">\n"))) + +(defun soap-encode-sequence-type (xml-tag value type) + "Encode inside XML-TAG the LISP VALUE according to TYPE. +Do not call this function directly, use `soap-encode-value' +instead." + (let ((xsi-type (soap-element-fq-name type))) + (insert "<" xml-tag " xsi:type=\"" xsi-type "\"") + (if value + (progn + (insert ">\n") + (let ((parents (list type)) + (parent (soap-sequence-type-parent type))) + + (while parent + (push parent parents) + (setq parent (soap-sequence-type-parent parent))) + + (dolist (type parents) + (dolist (element (soap-sequence-type-elements type)) + (let ((instance-count 0) + (e-name (soap-sequence-element-name element)) + (e-type (soap-sequence-element-type element))) + (dolist (v value) + (when (equal (car v) e-name) + (incf instance-count) + (soap-encode-value e-name (cdr v) e-type))) + + ;; Do some sanity checking + (cond ((and (= instance-count 0) + (not (soap-sequence-element-nillable? element))) + (soap-warning + "While encoding %s: missing non-nillable slot %s" + (soap-element-name type) e-name)) + ((and (> instance-count 1) + (not (soap-sequence-element-multiple? element))) + (soap-warning + "While encoding %s: multiple slots named %s" + (soap-element-name type) e-name)))))))) + (insert " xsi:nil=\"true\">")) + (insert "</" xml-tag ">\n"))) + +(defun soap-encode-array-type (xml-tag value type) + "Encode inside XML-TAG the LISP VALUE according to TYPE. +Do not call this function directly, use `soap-encode-value' +instead." + (unless (vectorp value) + (error "Soap-encode: %s(%s) expects a vector, got: %s" + xml-tag (soap-element-fq-name type) value)) + (let* ((element-type (soap-array-type-element-type type)) + (array-type (concat (soap-element-fq-name element-type) + "[" (format "%s" (length value)) "]"))) + (insert "<" xml-tag + " soapenc:arrayType=\"" array-type "\" " + " xsi:type=\"soapenc:Array\">\n") + (loop for i below (length value) + do (soap-encode-value xml-tag (aref value i) element-type)) + (insert "</" xml-tag ">\n"))) + +(progn + (put (aref (make-soap-basic-type) 0) + 'soap-encoder 'soap-encode-basic-type) + (put (aref (make-soap-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) + "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." + (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))) + + (unless (= (length parameter-order) (length parameters)) + (error "Wrong number of parameters for %s: expected %d, got %s" + (soap-element-name op) + (length parameter-order) + (length parameters))) + + (insert "<soap:Body>\n") + (when (eq use 'encoded) + (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 "\" "))))))))) + + (when (eq use 'encoded) + (insert "</" (soap-element-fq-name op) ">\n")) + (insert "</soap:Body>\n"))) + +(defun soap-create-envelope (operation parameters wsdl) + "Create a SOAP request envelope for OPERATION using PARAMETERS. +WSDL is the wsdl document used to encode the PARAMETERS." + (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) + + ;; Put the envelope around the body + (goto-char (point-min)) + (insert "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<soap:Envelope\n") + (when (eq use 'encoded) + (insert " soapenc:encodingStyle=\"http://schemas.xmlsoap.org/soap/encoding/\"\n")) + (dolist (nstag soap-encoded-namespaces) + (insert " xmlns:" nstag "=\"") + (let ((nsname (cdr (assoc nstag soap-well-known-xmlns)))) + (unless nsname + (setq nsname (cdr (assoc nstag (soap-wsdl-alias-table wsdl))))) + (insert nsname) + (insert "\"\n"))) + (insert ">\n") + (goto-char (point-max)) + (insert "</soap:Envelope>\n")) + + (buffer-string))) + +;;;; invoking soap methods + +(defcustom soap-debug nil + "When t, enable some debugging facilities." + :type 'boolean + :group 'soap-client) + +(defun soap-invoke (wsdl service operation-name &rest parameters) + "Invoke a SOAP operation and return the result. + +WSDL is used for encoding the request and decoding the response. +It also contains information about the WEB server address that +will service the request. + +SERVICE is the SOAP service to invoke. + +OPERATION-NAME is the operation to invoke. + +PARAMETERS -- the remaining parameters are used as parameters for +the SOAP request. + +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 (soap-create-envelope operation parameters wsdl)) + (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)) + (when (> (buffer-size) 1000000) + (soap-warning + "Received large message: %s bytes" + (buffer-size))) + (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))))))))) + +(provide 'soap-client) + + +;;; Local Variables: +;;; mode: outline-minor +;;; outline-regexp: ";;;;+" +;;; End: + +;;; soap-client.el ends here diff --git a/lisp/net/soap-inspect.el b/lisp/net/soap-inspect.el new file mode 100644 index 00000000000..7cce9844d76 --- /dev/null +++ b/lisp/net/soap-inspect.el @@ -0,0 +1,357 @@ +;;;; soap-inspect.el -- Interactive inspector for soap WSDL structures + +;; Copyright (C) 2010-2011 Free Software Foundation, Inc. + +;; Author: Alexandru Harsanyi (AlexHarsanyi@gmail.com) +;; Created: October 2010 +;; Keywords: soap, web-services, comm, hypermedia +;; Homepage: http://code.google.com/p/emacs-soap-client + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This package provides an inspector for a WSDL document loaded with +;; `soap-load-wsdl' or `soap-load-wsdl-from-url'. To use it, evaluate: +;; +;; (soap-inspect *wsdl*) +;; +;; This will pop-up the inspector buffer. You can click on ports, operations +;; and types to explore the structure of the wsdl document. +;; + + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'soap-client) + +;;; sample-value + +(defun soap-sample-value (type) + "Provide a sample value for TYPE, a WSDL type. +A sample value is a LISP value which soap-client.el will accept +for encoding it using TYPE when making SOAP requests. + +This is a generic function, depending on TYPE a specific function +will be called." + (let ((sample-value (get (aref type 0) 'soap-sample-value))) + (if sample-value + (funcall sample-value type) + (error "Cannot provide sample value for type %s" (aref type 0))))) + +(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-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-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." + ;; 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)) + (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-sequence-type) 0) 'soap-sample-value + 'soap-sample-value-for-seqence-type) + + (put (aref (make-soap-array-type) 0) 'soap-sample-value + 'soap-sample-value-for-array-type) + + (put (aref (make-soap-message) 0) 'soap-sample-value + 'soap-sample-value-for-message) ) + + + +;;; soap-inspect + +(defvar soap-inspect-previous-items nil + "A stack of previously inspected items in the *soap-inspect* buffer. +Used to implement the BACK button.") + +(defvar soap-inspect-current-item nil + "The current item being inspected in the *soap-inspect* buffer.") + +(progn + (make-variable-buffer-local 'soap-inspect-previous-items) + (make-variable-buffer-local 'soap-inspect-current-item)) + +(defun soap-inspect (element) + "Inspect a SOAP ELEMENT in the *soap-inspect* buffer. +The buffer is populated with information about ELEMENT with links +to its sub elements. If ELEMENT is the WSDL document itself, the +entire WSDL can be inspected." + (let ((inspect (get (aref element 0) 'soap-inspect))) + (unless inspect + (error "Soap-inspect: no inspector for element")) + + (with-current-buffer (get-buffer-create "*soap-inspect*") + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (erase-buffer) + + (when soap-inspect-current-item + (push soap-inspect-current-item + soap-inspect-previous-items)) + (setq soap-inspect-current-item element) + + (funcall inspect element) + + (unless (null soap-inspect-previous-items) + (insert "\n\n") + (insert-text-button + "[back]" + 'type 'soap-client-describe-back-link + 'item element) + (insert "\n")) + (goto-char (point-min)) + (pop-to-buffer (current-buffer)))))) + + +(define-button-type 'soap-client-describe-link + 'face 'italic + 'help-echo "mouse-2, RET: describe item" + 'follow-link t + 'action (lambda (button) + (let ((item (button-get button 'item))) + (soap-inspect item))) + 'skip t) + +(define-button-type 'soap-client-describe-back-link + 'face 'italic + 'help-echo "mouse-2, RET: browse the previous item" + 'follow-link t + 'action (lambda (button) + (let ((item (pop soap-inspect-previous-items))) + (when item + (setq soap-inspect-current-item nil) + (soap-inspect item)))) + 'skip t) + +(defun soap-insert-describe-button (element) + "Insert a button to inspect ELEMENT when pressed." + (insert-text-button + (soap-element-fq-name element) + '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-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)) + (insert "\nSample value:\n") + (pp (soap-sample-value array) (current-buffer))) + +(defun soap-inspect-message (message) + "Insert information about MESSAGE into the current buffer." + (insert "Message name: " (soap-element-fq-name message) "\n") + (insert "Parts:\n") + (dolist (part (soap-message-parts message)) + (insert "\t" (symbol-name (car part)) + " type: ") + (soap-insert-describe-button (cdr part)) + (insert "\n"))) + +(defun soap-inspect-operation (operation) + "Insert information about OPERATION into the current buffer." + (insert "Operation name: " (soap-element-fq-name operation) "\n") + (let ((input (soap-operation-input operation))) + (insert "\tInput: " (symbol-name (car input)) " (" ) + (soap-insert-describe-button (cdr input)) + (insert ")\n")) + (let ((output (soap-operation-output operation))) + (insert "\tOutput: " (symbol-name (car output)) " (") + (soap-insert-describe-button (cdr output)) + (insert ")\n")) + + (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)))) + (let ((sample-invocation + (append funcall (mapcar 'cdr sample-message-value)))) + (pp sample-invocation (current-buffer))))) + +(defun soap-inspect-port-type (port-type) + "Insert information about PORT-TYPE into the current buffer." + (insert "Port-type name: " (soap-element-fq-name port-type) "\n") + (insert "Operations:\n") + (loop for o being the hash-values of + (soap-namespace-elements (soap-port-type-operations port-type)) + do (progn + (insert "\t") + (soap-insert-describe-button (car o))))) + +(defun soap-inspect-binding (binding) + "Insert information about BINDING into the current buffer." + (insert "Binding: " (soap-element-fq-name binding) "\n") + (insert "\n") + (insert "Bound operations:\n") + (let* ((ophash (soap-binding-operations binding)) + (operations (loop for o being the hash-keys of ophash + collect o)) + op-name-width) + + (setq operations (sort operations 'string<)) + + (setq op-name-width (loop for o in operations maximizing (length o))) + + (dolist (op operations) + (let* ((bound-op (gethash op ophash)) + (soap-action (soap-bound-operation-soap-action bound-op)) + (use (soap-bound-operation-use bound-op))) + (unless soap-action + (setq soap-action "")) + (insert "\t") + (soap-insert-describe-button (soap-bound-operation-operation bound-op)) + (when (or use (not (equal soap-action ""))) + (insert (make-string (- op-name-width (length op)) ?\s)) + (insert " (") + (insert soap-action) + (when use + (insert " " (symbol-name use))) + (insert ")")) + (insert "\n"))))) + +(defun soap-inspect-port (port) + "Insert information about PORT into the current buffer." + (insert "Port name: " (soap-element-name port) "\n" + "Service URL: " (soap-port-service-url port) "\n" + "Binding: ") + (soap-insert-describe-button (soap-port-binding port))) + +(defun soap-inspect-wsdl (wsdl) + "Insert information about WSDL into the current buffer." + (insert "WSDL Origin: " (soap-wsdl-origin wsdl) "\n") + (insert "Ports:") + (dolist (p (soap-wsdl-ports wsdl)) + (insert "\n--------------------\n") + ;; (soap-insert-describe-button p) + (soap-inspect-port p)) + (insert "\n--------------------\nNamespace alias table:\n") + (dolist (a (soap-wsdl-alias-table wsdl)) + (insert "\t" (car a) " => " (cdr a) "\n"))) + +(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-sequence-type) 0) 'soap-inspect + 'soap-inspect-sequence-type) + + (put (aref (make-soap-array-type) 0) 'soap-inspect + 'soap-inspect-array-type) + + (put (aref (make-soap-message) 0) 'soap-inspect + 'soap-inspect-message) + (put (aref (make-soap-operation) 0) 'soap-inspect + 'soap-inspect-operation) + + (put (aref (make-soap-port-type) 0) 'soap-inspect + 'soap-inspect-port-type) + + (put (aref (make-soap-binding) 0) 'soap-inspect + 'soap-inspect-binding) + + (put (aref (make-soap-port) 0) 'soap-inspect + 'soap-inspect-port) + + (put (aref (make-soap-wsdl) 0) 'soap-inspect + 'soap-inspect-wsdl)) + +(provide 'soap-inspect) +;;; soap-inspect.el ends here diff --git a/lisp/play/doctor.el b/lisp/play/doctor.el index 5b3b4aba0fe..c60472e9386 100644 --- a/lisp/play/doctor.el +++ b/lisp/play/doctor.el @@ -141,7 +141,7 @@ reads the sentence before point, and prints the Doctor's answer." (turn-on-auto-fill) (doctor-type '(i am the psychotherapist \. (doc$ doctor--please) (doc$ doctor--describe) your (doc$ doctor--problems) \. - each time you are finished talking, type \R\E\T twice \.)) + each time you are finished talking\, type \R\E\T twice \.)) (insert "\n")) (defun make-doctor-variables () diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el index fd79cfd2399..86553f9496e 100644 --- a/lisp/progmodes/prolog.el +++ b/lisp/progmodes/prolog.el @@ -5,8 +5,9 @@ ;; Authors: Emil Åström <emil_astrom(at)hotmail(dot)com> ;; Milan Zamazal <pdm(at)freesoft(dot)cz> -;; Stefan Bruda <stefan(at)bruda(dot)ca> (current maintainer) +;; Stefan Bruda <stefan(at)bruda(dot)ca> ;; * See below for more details +;; Maintainer: Stefan Bruda <stefan(at)bruda(dot)ca> ;; Keywords: prolog major mode sicstus swi mercury (defvar prolog-mode-version "1.22" diff --git a/lisp/shell.el b/lisp/shell.el index fcffc2317d5..ea89ce765c3 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -151,12 +151,14 @@ This is a fine thing to set in your `.emacs' file." :type '(repeat (string :tag "Suffix")) :group 'shell) -(defvar shell-delimiter-argument-list '(?\| ?& ?< ?> ?\( ?\) ?\;) +(defcustom shell-delimiter-argument-list nil ; '(?\| ?& ?< ?> ?\( ?\) ?\;) "List of characters to recognize as separate arguments. This variable is used to initialize `comint-delimiter-argument-list' in the -shell buffer. The value may depend on the operating system or shell. - -This is a fine thing to set in your `.emacs' file.") +shell buffer. The value may depend on the operating system or shell." + :type '(choice (const nil) + (repeat :tag "List of characters" character)) + :version "24.1" ; changed to nil (bug#8027) + :group 'shell) (defvar shell-file-name-chars (if (memq system-type '(ms-dos windows-nt cygwin)) diff --git a/lisp/simple.el b/lisp/simple.el index 4d2a0e69836..531c9212e34 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -778,7 +778,7 @@ If N is negative, delete newlines as well." (n (abs n))) (skip-chars-backward skip-characters) (constrain-to-field nil orig-pos) - (dotimes (i (or n 1)) + (dotimes (i n) (if (= (following-char) ?\s) (forward-char 1) (insert ?\s))) diff --git a/lisp/speedbar.el b/lisp/speedbar.el index b84afd797d1..dad2a4c82ac 100644 --- a/lisp/speedbar.el +++ b/lisp/speedbar.el @@ -614,8 +614,11 @@ state data." :group 'speedbar :type 'hook) -(defvar speedbar-ignored-modes '(fundamental-mode) - "*List of major modes which speedbar will not switch directories for.") +(defcustom speedbar-ignored-modes '(fundamental-mode) + "List of major modes which speedbar will not switch directories for." + :group 'speedbar + :type '(choice (const nil) + (repeat :tag "List of modes" (symbol :tag "Major mode")))) (defun speedbar-extension-list-to-regex (extlist) "Takes EXTLIST, a list of extensions and transforms it into regexp. @@ -669,7 +672,7 @@ directories here; see `vc-directory-exclusion-list'." :group 'speedbar :type 'string) -(defvar speedbar-file-unshown-regexp +(defcustom speedbar-file-unshown-regexp (let ((nstr "") (noext completion-ignored-extensions)) (while noext (setq nstr (concat nstr (regexp-quote (car noext)) "\\'" @@ -677,8 +680,10 @@ directories here; see `vc-directory-exclusion-list'." noext (cdr noext))) ;; backup refdir lockfile (concat nstr "\\|#[^#]+#$\\|\\.\\.?\\'\\|\\.#")) - "*Regexp matching files we don't want displayed in a speedbar buffer. -It is generated from the variable `completion-ignored-extensions'.") + "Regexp matching files we don't want displayed in a speedbar buffer. +It is generated from the variable `completion-ignored-extensions'." + :group 'speedbar + :type 'string) (defvar speedbar-file-regexp nil "Regular expression matching files we know how to expand. @@ -755,14 +760,17 @@ DIRECTORY-EXPRESSION to `speedbar-ignored-directory-expressions'." speedbar-ignored-directory-regexp (speedbar-extension-list-to-regex speedbar-ignored-directory-expressions))) -(defvar speedbar-update-flag dframe-have-timer-flag - "*Non-nil means to automatically update the display. +(defcustom speedbar-update-flag dframe-have-timer-flag + "Non-nil means to automatically update the display. When this is nil then speedbar will not follow the attached frame's directory. -When speedbar is active, use: - -\\<speedbar-key-map> `\\[speedbar-toggle-updates]' - -to toggle this value.") +If you want to change this while speedbar is active, either use +\\[customize] or call \\<speedbar-key-map> `\\[speedbar-toggle-updates]'." + :group 'speedbar + :initialize 'custom-initialize-default + :set (lambda (sym val) + (set sym val) + (speedbar-toggle-updates)) + :type 'boolean) (defvar speedbar-update-flag-disable nil "Permanently disable changing of the update flag.") @@ -3643,17 +3651,20 @@ to be at the beginning of a line in the etags buffer. This variable is ignored if `speedbar-use-imenu-flag' is non-nil.") -(defvar speedbar-fetch-etags-command "etags" - "*Command used to create an etags file. - -This variable is ignored if `speedbar-use-imenu-flag' is t.") +(defcustom speedbar-fetch-etags-command "etags" + "Command used to create an etags file. +This variable is ignored if `speedbar-use-imenu-flag' is t." + :group 'speedbar + :type 'string) -(defvar speedbar-fetch-etags-arguments '("-D" "-I" "-o" "-") - "*List of arguments to use with `speedbar-fetch-etags-command'. +(defcustom speedbar-fetch-etags-arguments '("-D" "-I" "-o" "-") + "List of arguments to use with `speedbar-fetch-etags-command'. This creates an etags output buffer. Use `speedbar-toggle-etags' to modify this list conveniently. - -This variable is ignored if `speedbar-use-imenu-flag' is t.") +This variable is ignored if `speedbar-use-imenu-flag' is t." + :group 'speedbar + :type '(choice (const nil) + (repeat :tag "List of arguments" string))) (defun speedbar-toggle-etags (flag) "Toggle FLAG in `speedbar-fetch-etags-arguments'. diff --git a/lisp/term.el b/lisp/term.el index ea419234e0f..df95ca830ab 100644 --- a/lisp/term.el +++ b/lisp/term.el @@ -762,11 +762,13 @@ Buffer local variable.") "magenta3" "cyan3" "white"]) ;; Inspiration came from comint.el -mm -(defvar term-buffer-maximum-size 2048 - "*The maximum size in lines for term buffers. +(defcustom term-buffer-maximum-size 2048 + "The maximum size in lines for term buffers. Term buffers are truncated from the top to be no greater than this number. Notice that a setting of 0 means \"don't truncate anything\". This variable -is buffer-local.") +is buffer-local." + :group 'term + :type 'integer) (when (featurep 'xemacs) (defvar term-terminal-menu @@ -2209,9 +2211,11 @@ Security bug: your string can still be temporarily recovered with ;;; Low-level process communication -(defvar term-input-chunk-size 512 - "*Long inputs send to term processes are broken up into chunks of this size. -If your process is choking on big inputs, try lowering the value.") +(defcustom term-input-chunk-size 512 + "Long inputs send to term processes are broken up into chunks of this size. +If your process is choking on big inputs, try lowering the value." + :group 'term + :type 'integer) (defun term-send-string (proc str) "Send to PROC the contents of STR as input. @@ -3909,27 +3913,38 @@ This is a good place to put keybindings.") ;; Commands like this are fine things to put in load hooks if you ;; want them present in specific modes. -(defvar term-completion-autolist nil - "*If non-nil, automatically list possibilities on partial completion. -This mirrors the optional behavior of tcsh.") +(defcustom term-completion-autolist nil + "If non-nil, automatically list possibilities on partial completion. +This mirrors the optional behavior of tcsh." + :group 'term + :type 'boolean) -(defvar term-completion-addsuffix t - "*If non-nil, add a `/' to completed directories, ` ' to file names. +(defcustom term-completion-addsuffix t + "If non-nil, add a `/' to completed directories, ` ' to file names. If a cons pair, it should be of the form (DIRSUFFIX . FILESUFFIX) where DIRSUFFIX and FILESUFFIX are strings added on unambiguous or exact -completion. This mirrors the optional behavior of tcsh.") +completion. This mirrors the optional behavior of tcsh." + :group 'term + :type '(choice (const :tag "No suffix" nil) + (cons (string :tag "dirsuffix") (string :tag "filesuffix")) + (other :tag "Suffix" t))) -(defvar term-completion-recexact nil - "*If non-nil, use shortest completion if characters cannot be added. +(defcustom term-completion-recexact nil + "If non-nil, use shortest completion if characters cannot be added. This mirrors the optional behavior of tcsh. -A non-nil value is useful if `term-completion-autolist' is non-nil too.") +A non-nil value is useful if `term-completion-autolist' is non-nil too." + :group 'term + :type 'boolean) -(defvar term-completion-fignore nil - "*List of suffixes to be disregarded during file completion. +(defcustom term-completion-fignore nil + "List of suffixes to be disregarded during file completion. This mirrors the optional behavior of bash and tcsh. -Note that this applies to `term-dynamic-complete-filename' only.") +Note that this applies to `term-dynamic-complete-filename' only." + :group 'term + :type '(choice (const nil) + (repeat :tag "List of suffixes" string))) (defvar term-file-name-prefix "" "Prefix prepended to absolute file names taken from process input. diff --git a/lisp/term/sup-mouse.el b/lisp/term/sup-mouse.el index a8b78bb3e38..6d77241008c 100644 --- a/lisp/term/sup-mouse.el +++ b/lisp/term/sup-mouse.el @@ -30,8 +30,11 @@ ;;; User customization option: -(defvar sup-mouse-fast-select-window nil - "*Non-nil for mouse hits to select new window, then execute; else just select.") +(defcustom sup-mouse-fast-select-window nil + "Non-nil means mouse hits select new window, then execute. +Otherwise just select." + :type 'boolean + :group 'mouse) (defconst mouse-left 0) (defconst mouse-center 1) diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el index 1ec80d5c277..e3c42626a3f 100644 --- a/lisp/term/x-win.el +++ b/lisp/term/x-win.el @@ -1167,20 +1167,28 @@ pasted text.") :group 'killing :version "24.1") -(defvar x-select-request-type nil - "*Data type request for X selection. +(defcustom x-select-request-type nil + "Data type request for X selection. The value is one of the following data types, a list of them, or nil: `COMPOUND_TEXT', `UTF8_STRING', `STRING', `TEXT' -If the value is one of the above symbols, try only the specified -type. +If the value is one of the above symbols, try only the specified type. If the value is a list of them, try each of them in the specified order until succeed. -The value nil is the same as this list: - \(UTF8_STRING COMPOUND_TEXT STRING) -") +The value nil is the same as the list (UTF8_STRING COMPOUND_TEXT STRING)." + :type '(choice (const :tag "Default" nil) + (const COMPOUND_TEXT) + (const UTF8_STRING) + (const STRING) + (const TEXT) + (set :tag "List of values" + (const COMPOUND_TEXT) + (const UTF8_STRING) + (const STRING) + (const TEXT))) + :group 'killing) ;; Get a selection value of type TYPE by calling x-get-selection with ;; an appropriate DATA-TYPE argument decided by `x-select-request-type'. diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 815bdbfc5bf..02743847800 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -2614,9 +2614,6 @@ log entries should be gathered." (when index (substring rev 0 index)))) -(define-obsolete-function-alias - 'vc-default-previous-version 'vc-default-previous-revision "23.1") - (defun vc-default-responsible-p (backend file) "Indicate whether BACKEND is reponsible for FILE. The default is to return nil always." |