;;; map-ynp.el --- general-purpose boolean question-asker -*- lexical-binding:t -*- ;; Copyright (C) 1991-1995, 2000-2021 Free Software Foundation, Inc. ;; Author: Roland McGrath ;; Maintainer: emacs-devel@gnu.org ;; Keywords: lisp, extensions ;; Package: emacs ;; 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 . ;;; Commentary: ;; map-y-or-n-p is a general-purpose question-asking function. ;; It asks a series of y/n questions (a la y-or-n-p), and decides to ;; apply an action to each element of a list based on the answer. ;; The nice thing is that you also get some other possible answers ;; to use, reminiscent of query-replace: ! to answer y to all remaining ;; questions; ESC or q to answer n to all remaining questions; . to answer ;; y once and then n for the remainder; and you can get help with C-h. ;;; Code: (declare-function x-popup-dialog "menu.c" (position contents &optional header)) (defun map-y-or-n-p (prompter actor list &optional help action-alist no-cursor-in-echo-area) "Ask a series of boolean questions. Takes args PROMPTER ACTOR LIST, and optional args HELP, ACTION-ALIST and NO-CURSOR-IN-ECHO-AREA. LIST is a list of objects, or a function of no arguments to return the next object or nil. If PROMPTER is a string, the prompt is \(format PROMPTER OBJECT). If not a string, PROMPTER is a function of one arg (an object from LIST), which returns a string to be used as the prompt for that object. If the return value is not a string, it may be nil to ignore the object or non-nil to act on the object without asking the user. ACTOR is a function of one arg (an object from LIST), which gets called with each object that the user answers `yes' for. If HELP is given, it is a list (OBJECT OBJECTS ACTION), where OBJECT is a string giving the singular noun for an elt of LIST; OBJECTS is the plural noun for elts of LIST, and ACTION is a transitive verb describing ACTOR. The default is \(\"object\" \"objects\" \"act on\"). At the prompts, the user may enter y, Y, or SPC to act on that object; n, N, or DEL to skip that object; ! to act on all following objects; ESC or q to exit (skip all following objects); . (period) to act on the current object and then exit; or \\[help-command] to get help. If ACTION-ALIST is given, it is an alist (KEY FUNCTION HELP) of extra keys that will be accepted. KEY is a character; FUNCTION is a function of one arg (an object from LIST); HELP is a string. When the user hits KEY, FUNCTION is called. If it returns non-nil, the object is considered \"acted upon\", and the next object from LIST is processed. If it returns nil, the prompt is repeated for the same object. Final optional argument NO-CURSOR-IN-ECHO-AREA non-nil says not to set `cursor-in-echo-area' while prompting. This function uses `query-replace-map' to define the standard responses, but not all of the responses which `query-replace' understands are meaningful here. Returns the number of actions taken." (let* ((actions 0) (msg (current-message)) user-keys mouse-event map prompt char elt def ;; Non-nil means we should use mouse menus to ask. use-menus delayed-switch-frame ;; Rebind other-window-scroll-buffer so that subfunctions can set ;; it temporarily, without risking affecting the caller. (other-window-scroll-buffer other-window-scroll-buffer) (next (if (functionp list) (lambda () (setq elt (funcall list))) (lambda () (when list (setq elt (pop list)) t)))) (try-again (lambda () (let ((x next)) (setq next (lambda () (setq next x) elt)))))) (if (and (listp last-nonmenu-event) use-dialog-box) ;; Make a list describing a dialog box. (let ((objects (if help (capitalize (nth 1 help)))) (action (if help (capitalize (nth 2 help))))) (setq map `(("Yes" . act) ("No" . skip) ,@(mapcar (lambda (elt) (cons (with-syntax-table text-mode-syntax-table (capitalize (nth 2 elt))) (vector (nth 1 elt)))) action-alist) (,(if help (concat action " This But No More") "Do This But No More") . act-and-exit) (,(if help (concat action " All " objects) "Do All") . automatic) ("No For All" . exit)) use-menus t mouse-event last-nonmenu-event)) (setq user-keys (if action-alist (concat (mapconcat (lambda (elt) (key-description (vector (car elt)))) action-alist ", ") " ") "") ;; Make a map that defines each user key as a vector containing ;; its definition. map (let ((map (make-sparse-keymap))) (set-keymap-parent map query-replace-map) (dolist (elt action-alist) (define-key map (vector (car elt)) (vector (nth 1 elt)))) map))) (unwind-protect (progn (if (stringp prompter) (setq prompter (let ((prompter prompter)) (lambda (object) (format prompter object))))) (while (funcall next) (setq prompt (funcall prompter elt)) (cond ((stringp prompt) ;; Prompt the user about this object. (setq quit-flag nil) (if use-menus (setq def (or (x-popup-dialog (or mouse-event use-menus) (cons prompt map)) 'quit)) ;; Prompt in the echo area. (let ((cursor-in-echo-area (not no-cursor-in-echo-area))) (message (apply 'propertize "%s(y, n, !, ., q, %sor %s) " minibuffer-prompt-properties) prompt user-keys (key-description (vector help-char))) (if minibuffer-auto-raise (raise-frame (window-frame (minibuffer-window)))) (while (progn (setq char (read-event)) ;; If we get -1, from end of keyboard ;; macro, try again. (equal char -1))) ;; Show the answer to the question. (message "%s(y, n, !, ., q, %sor %s) %s" prompt user-keys (key-description (vector help-char)) (single-key-description char))) (setq def (lookup-key map (vector char)))) (cond ((eq def 'exit) (setq next (lambda () nil))) ((eq def 'act) ;; Act on the object. (funcall actor elt) (setq actions (1+ actions))) ((eq def 'skip) ;; Skip the object. ) ((eq def 'act-and-exit) ;; Act on the object and then exit. (funcall actor elt) (setq actions (1+ actions) next (lambda () nil))) ((eq def 'quit) (setq quit-flag t) (funcall try-again)) ((eq def 'automatic) ;; Act on this and all following objects. (if (funcall prompter elt) (progn (funcall actor elt) (setq actions (1+ actions)))) (while (funcall next) (if (funcall prompter elt) (progn (funcall actor elt) (setq actions (1+ actions)))))) ((eq def 'help) (with-help-window (help-buffer) (princ (let ((object (or (nth 0 help) "object")) (objects (or (nth 1 help) "objects")) (action (or (nth 2 help) "act on"))) (concat (format-message "\ Type SPC or `y' to %s the current %s; DEL or `n' to skip the current %s; RET or `q' to skip the current and all remaining %s; C-g to quit (cancel the whole command); ! to %s all remaining %s;\n" action object object objects action objects) (mapconcat (lambda (elt) (format "%s to %s;\n" (single-key-description (nth 0 elt)) (nth 2 elt))) action-alist "") (format "or . (period) to %s the current %s and exit." action object))))) (funcall try-again)) ((and (symbolp def) (commandp def)) (call-interactively def) ;; Regurgitated; try again. (funcall try-again)) ((vectorp def) ;; A user-defined key. (if (funcall (aref def 0) elt) ;Call its function. ;; The function has eaten this object. (setq actions (1+ actions)) ;; Regurgitated; try again. (funcall try-again))) ((and (consp char) (eq (car char) 'switch-frame)) ;; switch-frame event. Put it off until we're done. (setq delayed-switch-frame char) (funcall try-again)) (t ;; Random char. (message "Type %s for help." (key-description (vector help-char))) (beep) (sit-for 1) (funcall try-again)))) (prompt (funcall actor elt) (setq actions (1+ actions)))))) (if delayed-switch-frame (setq unread-command-events (cons delayed-switch-frame unread-command-events)))) ;; Clear the last prompt from the minibuffer, and restore the ;; previous echo-area message, if any. (let ((message-log-max nil)) (if msg (message "%s" msg) (message ""))) ;; Return the number of actions that were taken. actions)) ;; read-answer is a general-purpose question-asker that supports ;; either long or short answers. ;; For backward compatibility check if short y/n answers are preferred. (defcustom read-answer-short 'auto "If non-nil, `read-answer' accepts single-character answers. If t, accept short (single key-press) answers to the question. If nil, require long answers. If `auto', accept short answers if `use-short-answers' is non-nil, or the function cell of `yes-or-no-p' is set to `y-or-n-p'." :type '(choice (const :tag "Accept short answers" t) (const :tag "Require long answer" nil) (const :tag "Guess preference" auto)) :version "26.2" :group 'minibuffer) (defconst read-answer-map--memoize (make-hash-table :weakness 'key :test 'equal)) (defun read-answer (question answers) "Read an answer either as a complete word or its character abbreviation. Ask user a question and accept an answer from the list of possible answers. QUESTION should end in a space; this function adds a list of answers to it. ANSWERS is an alist with elements in the following format: (LONG-ANSWER SHORT-ANSWER HELP-MESSAGE) where LONG-ANSWER is a complete answer, SHORT-ANSWER is an abbreviated one-character answer, HELP-MESSAGE is a string describing the meaning of the answer. SHORT-ANSWER is not necessarily a single character answer. It can be also a function key like F1, a character event such as C-M-h, or a control character like C-h. Example: \\='((\"yes\" ?y \"perform the action\") (\"no\" ?n \"skip to the next\") (\"all\" ?! \"accept all remaining without more questions\") (\"help\" ?h \"show help\") (\"quit\" ?q \"exit\")) When `read-answer-short' is non-nil, accept short answers. Return a long answer even in case of accepting short ones. When `use-dialog-box' is t, pop up a dialog window to get user input." (let* ((short (if (eq read-answer-short 'auto) (or use-short-answers (eq (symbol-function 'yes-or-no-p) 'y-or-n-p)) read-answer-short)) (answers-with-help (if (assoc "help" answers) answers (append answers '(("help" ?? "show this help message"))))) (answers-without-help (assoc-delete-all "help" (copy-alist answers-with-help))) (prompt (format "%s(%s) " question (mapconcat (lambda (a) (if short (if (characterp (nth 1 a)) (format "%c" (nth 1 a)) (key-description (nth 1 a))) (nth 0 a))) answers-with-help ", "))) (message (format "Please answer %s." (mapconcat (lambda (a) (format "`%s'" (if short (if (characterp (nth 1 a)) (string (nth 1 a)) (key-description (nth 1 a))) (nth 0 a)))) answers-with-help " or "))) (short-answer-map (when short (or (gethash answers read-answer-map--memoize) (puthash answers (let ((map (make-sparse-keymap))) (set-keymap-parent map minibuffer-local-map) (dolist (a answers-with-help) (define-key map (if (characterp (nth 1 a)) (vector (nth 1 a)) (nth 1 a)) (lambda () (interactive) (delete-minibuffer-contents) (insert (nth 0 a)) (exit-minibuffer)))) (define-key map [remap self-insert-command] (lambda () (interactive) (delete-minibuffer-contents) (beep) (message message) (sit-for 2))) map) read-answer-map--memoize)))) answer) (while (not (assoc (setq answer (downcase (cond ((and (display-popup-menus-p) last-input-event ; not during startup (listp last-nonmenu-event) use-dialog-box) (x-popup-dialog t (cons question (mapcar (lambda (a) (cons (capitalize (nth 0 a)) (nth 0 a))) answers-with-help)))) (short (read-from-minibuffer prompt nil short-answer-map nil 'read-char-history)) (t (read-from-minibuffer prompt nil nil nil 'yes-or-no-p-history))))) answers-without-help)) (if (string= answer "help") (with-help-window "*Help*" (with-current-buffer "*Help*" (insert "Type:\n" (mapconcat (lambda (a) (format "`%s'%s to %s" (if short (if (characterp (nth 1 a)) (string (nth 1 a)) (key-description (nth 1 a))) (nth 0 a)) (if short (format " (%s)" (nth 0 a)) "") (nth 2 a))) answers-with-help ",\n") ".\n"))) (beep) (message message) (sit-for 2))) answer)) ;;; map-ynp.el ends here