| 1 | ;;; map-ynp.el --- general-purpose boolean question-asker |
| 2 | |
| 3 | ;; Copyright (C) 1991-1995, 2000-2012 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Roland McGrath <roland@gnu.org> |
| 6 | ;; Maintainer: FSF |
| 7 | ;; Keywords: lisp, extensions |
| 8 | |
| 9 | ;; This file is part of GNU Emacs. |
| 10 | |
| 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 12 | ;; it under the terms of the GNU General Public License as published by |
| 13 | ;; the Free Software Foundation, either version 3 of the License, or |
| 14 | ;; (at your option) any later version. |
| 15 | |
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 19 | ;; GNU General Public License for more details. |
| 20 | |
| 21 | ;; You should have received a copy of the GNU General Public License |
| 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 23 | |
| 24 | ;;; Commentary: |
| 25 | |
| 26 | ;; map-y-or-n-p is a general-purpose question-asking function. |
| 27 | ;; It asks a series of y/n questions (a la y-or-n-p), and decides to |
| 28 | ;; apply an action to each element of a list based on the answer. |
| 29 | ;; The nice thing is that you also get some other possible answers |
| 30 | ;; to use, reminiscent of query-replace: ! to answer y to all remaining |
| 31 | ;; questions; ESC or q to answer n to all remaining questions; . to answer |
| 32 | ;; y once and then n for the remainder; and you can get help with C-h. |
| 33 | |
| 34 | ;;; Code: |
| 35 | |
| 36 | (declare-function x-popup-dialog "xmenu.c" (position contents &optional header)) |
| 37 | |
| 38 | (defun map-y-or-n-p (prompter actor list &optional help action-alist |
| 39 | no-cursor-in-echo-area) |
| 40 | "Ask a series of boolean questions. |
| 41 | Takes args PROMPTER ACTOR LIST, and optional args HELP and ACTION-ALIST. |
| 42 | |
| 43 | LIST is a list of objects, or a function of no arguments to return the next |
| 44 | object or nil. |
| 45 | |
| 46 | If PROMPTER is a string, the prompt is \(format PROMPTER OBJECT\). If not |
| 47 | a string, PROMPTER is a function of one arg (an object from LIST), which |
| 48 | returns a string to be used as the prompt for that object. If the return |
| 49 | value is not a string, it may be nil to ignore the object or non-nil to act |
| 50 | on the object without asking the user. |
| 51 | |
| 52 | ACTOR is a function of one arg (an object from LIST), |
| 53 | which gets called with each object that the user answers `yes' for. |
| 54 | |
| 55 | If HELP is given, it is a list (OBJECT OBJECTS ACTION), |
| 56 | where OBJECT is a string giving the singular noun for an elt of LIST; |
| 57 | OBJECTS is the plural noun for elts of LIST, and ACTION is a transitive |
| 58 | verb describing ACTOR. The default is \(\"object\" \"objects\" \"act on\"\). |
| 59 | |
| 60 | At the prompts, the user may enter y, Y, or SPC to act on that object; |
| 61 | n, N, or DEL to skip that object; ! to act on all following objects; |
| 62 | ESC or q to exit (skip all following objects); . (period) to act on the |
| 63 | current object and then exit; or \\[help-command] to get help. |
| 64 | |
| 65 | If ACTION-ALIST is given, it is an alist (KEY FUNCTION HELP) of extra keys |
| 66 | that will be accepted. KEY is a character; FUNCTION is a function of one |
| 67 | arg (an object from LIST); HELP is a string. When the user hits KEY, |
| 68 | FUNCTION is called. If it returns non-nil, the object is considered |
| 69 | \"acted upon\", and the next object from LIST is processed. If it returns |
| 70 | nil, the prompt is repeated for the same object. |
| 71 | |
| 72 | Final optional argument NO-CURSOR-IN-ECHO-AREA non-nil says not to set |
| 73 | `cursor-in-echo-area' while prompting. |
| 74 | |
| 75 | This function uses `query-replace-map' to define the standard responses, |
| 76 | but not all of the responses which `query-replace' understands |
| 77 | are meaningful here. |
| 78 | |
| 79 | Returns the number of actions taken." |
| 80 | (let* ((actions 0) |
| 81 | user-keys mouse-event map prompt char elt tail def |
| 82 | ;; Non-nil means we should use mouse menus to ask. |
| 83 | use-menus |
| 84 | delayed-switch-frame |
| 85 | ;; Rebind other-window-scroll-buffer so that subfunctions can set |
| 86 | ;; it temporarily, without risking affecting the caller. |
| 87 | (other-window-scroll-buffer other-window-scroll-buffer) |
| 88 | (next (if (functionp list) |
| 89 | (lambda () (setq elt (funcall list))) |
| 90 | (lambda () (when list |
| 91 | (setq elt (pop list)) |
| 92 | t))))) |
| 93 | (if (and (listp last-nonmenu-event) |
| 94 | use-dialog-box) |
| 95 | ;; Make a list describing a dialog box. |
| 96 | (let ((object (if help (capitalize (nth 0 help)))) |
| 97 | (objects (if help (capitalize (nth 1 help)))) |
| 98 | (action (if help (capitalize (nth 2 help))))) |
| 99 | (setq map `(("Yes" . act) ("No" . skip) |
| 100 | ,@(mapcar (lambda (elt) |
| 101 | (cons (with-syntax-table |
| 102 | text-mode-syntax-table |
| 103 | (capitalize (nth 2 elt))) |
| 104 | (vector (nth 1 elt)))) |
| 105 | action-alist) |
| 106 | (,(if help (concat action " This But No More") |
| 107 | "Do This But No More") . act-and-exit) |
| 108 | (,(if help (concat action " All " objects) |
| 109 | "Do All") . automatic) |
| 110 | ("No For All" . exit)) |
| 111 | use-menus t |
| 112 | mouse-event last-nonmenu-event)) |
| 113 | (setq user-keys (if action-alist |
| 114 | (concat (mapconcat (lambda (elt) |
| 115 | (key-description |
| 116 | (vector (car elt)))) |
| 117 | action-alist ", ") |
| 118 | " ") |
| 119 | "") |
| 120 | ;; Make a map that defines each user key as a vector containing |
| 121 | ;; its definition. |
| 122 | map |
| 123 | (let ((map (make-sparse-keymap))) |
| 124 | (set-keymap-parent map query-replace-map) |
| 125 | (define-key map [?\C-\M-v] 'scroll-other-window) |
| 126 | (define-key map [M-next] 'scroll-other-window) |
| 127 | (define-key map [?\C-\M-\S-v] 'scroll-other-window-down) |
| 128 | (define-key map [M-prior] 'scroll-other-window-down) |
| 129 | ;; The above are rather inconvenient, so maybe we should |
| 130 | ;; provide the non-other keys for the other-scroll as well. |
| 131 | ;; (define-key map [?\C-v] 'scroll-other-window) |
| 132 | ;; (define-key map [next] 'scroll-other-window) |
| 133 | ;; (define-key map [?\M-v] 'scroll-other-window-down) |
| 134 | ;; (define-key map [prior] 'scroll-other-window-down) |
| 135 | (dolist (elt action-alist) |
| 136 | (define-key map (vector (car elt)) (vector (nth 1 elt)))) |
| 137 | map))) |
| 138 | (unwind-protect |
| 139 | (progn |
| 140 | (if (stringp prompter) |
| 141 | (setq prompter `(lambda (object) |
| 142 | (format ,prompter object)))) |
| 143 | (while (funcall next) |
| 144 | (setq prompt (funcall prompter elt)) |
| 145 | (cond ((stringp prompt) |
| 146 | ;; Prompt the user about this object. |
| 147 | (setq quit-flag nil) |
| 148 | (if use-menus |
| 149 | (setq def (or (x-popup-dialog (or mouse-event use-menus) |
| 150 | (cons prompt map)) |
| 151 | 'quit)) |
| 152 | ;; Prompt in the echo area. |
| 153 | (let ((cursor-in-echo-area (not no-cursor-in-echo-area)) |
| 154 | (message-log-max nil)) |
| 155 | (message (apply 'propertize "%s(y, n, !, ., q, %sor %s) " |
| 156 | minibuffer-prompt-properties) |
| 157 | prompt user-keys |
| 158 | (key-description (vector help-char))) |
| 159 | (if minibuffer-auto-raise |
| 160 | (raise-frame (window-frame (minibuffer-window)))) |
| 161 | (while (progn |
| 162 | (setq char (read-event)) |
| 163 | ;; If we get -1, from end of keyboard |
| 164 | ;; macro, try again. |
| 165 | (equal char -1))) |
| 166 | ;; Show the answer to the question. |
| 167 | (message "%s(y, n, !, ., q, %sor %s) %s" |
| 168 | prompt user-keys |
| 169 | (key-description (vector help-char)) |
| 170 | (single-key-description char))) |
| 171 | (setq def (lookup-key map (vector char)))) |
| 172 | (cond ((eq def 'exit) |
| 173 | (setq next (lambda () nil))) |
| 174 | ((eq def 'act) |
| 175 | ;; Act on the object. |
| 176 | (funcall actor elt) |
| 177 | (setq actions (1+ actions))) |
| 178 | ((eq def 'skip) |
| 179 | ;; Skip the object. |
| 180 | ) |
| 181 | ((eq def 'act-and-exit) |
| 182 | ;; Act on the object and then exit. |
| 183 | (funcall actor elt) |
| 184 | (setq actions (1+ actions) |
| 185 | next (lambda () nil))) |
| 186 | ((eq def 'quit) |
| 187 | (setq quit-flag t) |
| 188 | (setq next `(lambda () |
| 189 | (setq next ',next) |
| 190 | ',elt))) |
| 191 | ((eq def 'automatic) |
| 192 | ;; Act on this and all following objects. |
| 193 | (if (funcall prompter elt) |
| 194 | (progn |
| 195 | (funcall actor elt) |
| 196 | (setq actions (1+ actions)))) |
| 197 | (while (funcall next) |
| 198 | (if (funcall prompter elt) |
| 199 | (progn |
| 200 | (funcall actor elt) |
| 201 | (setq actions (1+ actions)))))) |
| 202 | ((eq def 'help) |
| 203 | (with-output-to-temp-buffer "*Help*" |
| 204 | (princ |
| 205 | (let ((object (if help (nth 0 help) "object")) |
| 206 | (objects (if help (nth 1 help) "objects")) |
| 207 | (action (if help (nth 2 help) "act on"))) |
| 208 | (concat |
| 209 | (format "Type SPC or `y' to %s the current %s; |
| 210 | DEL or `n' to skip the current %s; |
| 211 | RET or `q' to give up on the %s (skip all remaining %s); |
| 212 | C-g to quit (cancel the whole command); |
| 213 | ! to %s all remaining %s;\n" |
| 214 | action object object action objects action |
| 215 | objects) |
| 216 | (mapconcat (function |
| 217 | (lambda (elt) |
| 218 | (format "%s to %s" |
| 219 | (single-key-description |
| 220 | (nth 0 elt)) |
| 221 | (nth 2 elt)))) |
| 222 | action-alist |
| 223 | ";\n") |
| 224 | (if action-alist ";\n") |
| 225 | (format "or . (period) to %s \ |
| 226 | the current %s and exit." |
| 227 | action object)))) |
| 228 | (with-current-buffer standard-output |
| 229 | (help-mode))) |
| 230 | |
| 231 | (setq next `(lambda () |
| 232 | (setq next ',next) |
| 233 | ',elt))) |
| 234 | ((and (symbolp def) (commandp def)) |
| 235 | (call-interactively def) |
| 236 | ;; Regurgitated; try again. |
| 237 | (setq next `(lambda () |
| 238 | (setq next ',next) |
| 239 | ',elt))) |
| 240 | ((vectorp def) |
| 241 | ;; A user-defined key. |
| 242 | (if (funcall (aref def 0) elt) ;Call its function. |
| 243 | ;; The function has eaten this object. |
| 244 | (setq actions (1+ actions)) |
| 245 | ;; Regurgitated; try again. |
| 246 | (setq next `(lambda () |
| 247 | (setq next ',next) |
| 248 | ',elt)))) |
| 249 | ((and (consp char) |
| 250 | (eq (car char) 'switch-frame)) |
| 251 | ;; switch-frame event. Put it off until we're done. |
| 252 | (setq delayed-switch-frame char) |
| 253 | (setq next `(lambda () |
| 254 | (setq next ',next) |
| 255 | ',elt))) |
| 256 | (t |
| 257 | ;; Random char. |
| 258 | (message "Type %s for help." |
| 259 | (key-description (vector help-char))) |
| 260 | (beep) |
| 261 | (sit-for 1) |
| 262 | (setq next `(lambda () |
| 263 | (setq next ',next) |
| 264 | ',elt))))) |
| 265 | (prompt |
| 266 | (funcall actor elt) |
| 267 | (setq actions (1+ actions)))))) |
| 268 | (if delayed-switch-frame |
| 269 | (setq unread-command-events |
| 270 | (cons delayed-switch-frame unread-command-events)))) |
| 271 | ;; Clear the last prompt from the minibuffer. |
| 272 | (let ((message-log-max nil)) |
| 273 | (message "")) |
| 274 | ;; Return the number of actions that were taken. |
| 275 | actions)) |
| 276 | |
| 277 | ;;; map-ynp.el ends here |