mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-11-26 07:33:47 +00:00
ecf08f0621
dc4e6b1329; Update copyright years in more files64b3777631; Run set-copyright from admin.el8e1c56ae46; Add 2024 to copyright years # Conflicts: # doc/misc/modus-themes.org # doc/misc/texinfo.tex # etc/NEWS # etc/refcards/ru-refcard.tex # etc/themes/modus-operandi-theme.el # etc/themes/modus-themes.el # etc/themes/modus-vivendi-theme.el # lib/alloca.in.h # lib/binary-io.h # lib/c-ctype.h # lib/c-strcasecmp.c # lib/c-strncasecmp.c # lib/careadlinkat.c # lib/cloexec.c # lib/close-stream.c # lib/diffseq.h # lib/dup2.c # lib/filemode.h # lib/fpending.c # lib/fpending.h # lib/fsusage.c # lib/getgroups.c # lib/getloadavg.c # lib/gettext.h # lib/gettime.c # lib/gettimeofday.c # lib/group-member.c # lib/malloc.c # lib/md5-stream.c # lib/md5.c # lib/md5.h # lib/memmem.c # lib/memrchr.c # lib/nanosleep.c # lib/save-cwd.h # lib/sha1.c # lib/sig2str.c # lib/stdlib.in.h # lib/strtoimax.c # lib/strtol.c # lib/strtoll.c # lib/time_r.c # lib/xalloc-oversized.h # lisp/auth-source-pass.el # lisp/emacs-lisp/lisp-mnt.el # lisp/emacs-lisp/timer.el # lisp/info-look.el # lisp/jit-lock.el # lisp/loadhist.el # lisp/mail/rmail.el # lisp/net/ntlm.el # lisp/net/webjump.el # lisp/progmodes/asm-mode.el # lisp/progmodes/project.el # lisp/progmodes/sh-script.el # lisp/textmodes/flyspell.el # lisp/textmodes/reftex-toc.el # lisp/textmodes/reftex.el # lisp/textmodes/tex-mode.el # lisp/url/url-gw.el # m4/alloca.m4 # m4/clock_time.m4 # m4/d-type.m4 # m4/dirent_h.m4 # m4/dup2.m4 # m4/euidaccess.m4 # m4/fchmodat.m4 # m4/filemode.m4 # m4/fsusage.m4 # m4/getgroups.m4 # m4/getloadavg.m4 # m4/getrandom.m4 # m4/gettime.m4 # m4/gettimeofday.m4 # m4/gnulib-common.m4 # m4/group-member.m4 # m4/inttypes.m4 # m4/malloc.m4 # m4/manywarnings.m4 # m4/mempcpy.m4 # m4/memrchr.m4 # m4/mkostemp.m4 # m4/mktime.m4 # m4/nproc.m4 # m4/nstrftime.m4 # m4/pathmax.m4 # m4/pipe2.m4 # m4/pselect.m4 # m4/pthread_sigmask.m4 # m4/readlink.m4 # m4/realloc.m4 # m4/sig2str.m4 # m4/ssize_t.m4 # m4/stat-time.m4 # m4/stddef_h.m4 # m4/stdint.m4 # m4/stdio_h.m4 # m4/stdlib_h.m4 # m4/stpcpy.m4 # m4/strnlen.m4 # m4/strtoimax.m4 # m4/strtoll.m4 # m4/time_h.m4 # m4/timegm.m4 # m4/timer_time.m4 # m4/timespec.m4 # m4/unistd_h.m4 # m4/warnings.m4 # nt/configure.bat # nt/preprep.c # test/lisp/register-tests.el
423 lines
17 KiB
EmacsLisp
423 lines
17 KiB
EmacsLisp
;;; map-ynp.el --- general-purpose boolean question-asker -*- lexical-binding:t -*-
|
||
|
||
;; Copyright (C) 1991-1995, 2000-2024 Free Software Foundation, Inc.
|
||
|
||
;; Author: Roland McGrath <roland@gnu.org>
|
||
;; 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 <https://www.gnu.org/licenses/>.
|
||
|
||
;;; 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 boolean question per PROMPTER for each object in LIST, then call ACTOR.
|
||
|
||
LIST is a list of objects, or a function of no arguments to return the next
|
||
object; when it returns nil, the list of objects is considered exhausted.
|
||
|
||
If PROMPTER is a string, it should be a format string to be used to format
|
||
the question as \(format PROMPTER OBJECT).
|
||
If PROMPTER is not a string, it should be a function of one argument, an
|
||
object from LIST, which returns a string to be used as the question for
|
||
that object. If the function's return value is not a string, it may be
|
||
nil to ignore the object, or non-nil to act on the object with ACTOR
|
||
without asking the user.
|
||
|
||
ACTOR is a function of one argument, an object from LIST,
|
||
which gets called with each object for which the user answers `yes'
|
||
to the question presented by PROMPTER.
|
||
|
||
The user's answers to the questions may be one of the following:
|
||
|
||
- 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.
|
||
|
||
HELP provides information for displaying help when the user
|
||
types \\[help-command]. If HELP is given, it should be a list of
|
||
the form (OBJECT OBJECTS ACTION), where OBJECT is a string giving
|
||
the singular noun describing an element of LIST; OBJECTS is the
|
||
plural noun describing several elements of LIST, and ACTION is a
|
||
transitive verb describing action by ACTOR on one or more elements
|
||
of LIST. If HELP is omitted or nil, it defaults
|
||
to \(\"object\" \"objects\" \"act on\").
|
||
|
||
If ACTION-ALIST is given, it is an alist specifying additional keys
|
||
that will be accepted as an answer to the questions. Each element
|
||
of the alist has the form (KEY FUNCTION HELP), where KEY is a character;
|
||
FUNCTION is a function of one argument (an object from LIST); and HELP
|
||
is a string. When the user presses KEY, FUNCTION is called; if it
|
||
returns non-nil, the object is considered to have been \"acted upon\",
|
||
and `map-y-or-n-p' proceeds to the next object from LIST. If
|
||
FUNCTION returns nil, the prompt is re-issued for the same object: this
|
||
comes in handy if FUNCTION produces some display that will allow the
|
||
user to make an intelligent decision whether the object in question
|
||
should be acted upon. If the user types \\[help-command], the string
|
||
given by HELP is used to describe the effect of KEY.
|
||
|
||
Optional argument NO-CURSOR-IN-ECHO-AREA, if non-nil, means not to set
|
||
`cursor-in-echo-area' while prompting with the questions.
|
||
|
||
This function uses `query-replace-map' to define the standard responses,
|
||
but only some of the responses which `query-replace' understands
|
||
are meaningful here, as described above.
|
||
|
||
The function's value is 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))))
|
||
(setq char (read-event))
|
||
;; Show the answer to the question.
|
||
(message "%s(y, n, !, ., q, %sor %s) %s"
|
||
prompt user-keys
|
||
(key-description (vector help-char))
|
||
(if (equal char -1)
|
||
"[end-of-keyboard-macro]"
|
||
(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
|
||
(substitute-command-keys "\
|
||
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, the `read-answer' function 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'.
|
||
|
||
Note that this variable does not affect calls to the more
|
||
commonly-used `yes-or-no-p' function; it only affects calls to
|
||
the `read-answer' function. To control whether `yes-or-no-p'
|
||
requires a long or a short answer, see the `use-short-answers'
|
||
variable."
|
||
: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
|