map-ynp.el 10 KB

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