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