Commit cc233365 authored by Juri Linkov's avatar Juri Linkov Committed by Noam Postavsky

New function read-answer (Bug#31782)

* lisp/emacs-lisp/map-ynp.el (read-answer-short): New defcustom.
(read-answer): New function.
* lisp/subr.el (assoc-delete-all): New function.
* etc/NEWS: Announce them.

* lisp/dired.el (dired-delete-file): Use read-answer.
(dired--yes-no-all-quit-help): Remove function.
(dired-delete-help): Remove defconst.

(backported from master, "New function read-answer (bug#30073)" and
"Respect non-saved value of `read-short-answer' (Bug#31782)")
parent f0b8e64f
......@@ -110,6 +110,12 @@ be removed prior using the changed 'shadow-*' commands.
* Lisp Changes in Emacs 26.2
** The new function 'read-answer' accepts either long or short answers
depending on the new customizable variable 'read-answer-short'.
** New function 'assoc-delete-all'.
Like 'assq-delete-all', but uses 'equal' for comparison.
* Changes in Emacs 26.2 on Non-Free Operating Systems
......@@ -2995,37 +2995,6 @@ Any other value means to ask for each directory."
;; Match anything but `.' and `..'.
(defvar dired-re-no-dot "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")
(defconst dired-delete-help
`yes' to delete recursively the current directory,
`no' to skip to next,
`all' to delete all remaining directories with no more questions,
`quit' to exit,
`help' to show this help message.")
(defun dired--yes-no-all-quit-help (prompt &optional help-msg)
"Ask a question with valid answers: yes, no, all, quit, help.
PROMPT must end with '? ', for instance, 'Delete it? '.
If optional arg HELP-MSG is non-nil, then is a message to show when
the user answers 'help'. Otherwise, default to `dired-delete-help'."
(let ((valid-answers (list "yes" "no" "all" "quit"))
(answer "")
(input-fn (lambda ()
(format "%s [yes, no, all, quit, help] " prompt)))))
(setq answer (funcall input-fn))
(when (string= answer "help")
(with-help-window "*Help*"
(with-current-buffer "*Help*"
(insert (or help-msg dired-delete-help)))))
(while (not (member answer valid-answers))
(unless (string= answer "help")
(message "Please answer `yes' or `no' or `all' or `quit'")
(sleep-for 2))
(setq answer (funcall input-fn)))
;; Delete file, possibly delete a directory and all its files.
;; This function is useful outside of dired. One could change its name
;; to e.g. recursive-delete-file and put it somewhere else.
......@@ -3055,11 +3024,17 @@ TRASH non-nil means to trash the file instead of deleting, provided
(dired-make-relative file))))
(pcase (dired--yes-no-all-quit-help prompt) ; Prompt user.
(pcase (read-answer
'(("yes" ?y "delete recursively the current directory")
("no" ?n "skip to next")
("all" ?! "delete all remaining directories with no more questions")
("quit" ?q "exit")))
('"all" (setq recursive 'always dired-recursive-deletes recursive))
('"yes" (if (eq recursive 'top) (setq recursive 'always)))
('"no" (setq recursive nil))
('"quit" (keyboard-quit)))))
('"quit" (keyboard-quit))
(_ (keyboard-quit))))) ; catch all unknown answers
(setq recursive nil)) ; Empty dir or recursive is nil.
(delete-directory file recursive trash))))
......@@ -256,4 +256,132 @@ the current %s and exit."
;; Return the number of actions that were taken.
;; 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
the function cell of `yes-or-no-p' is set to `y-or-on-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 is a complete answer,
SHORT-ANSWER is an abbreviated one-character answer,
HELP-MESSAGE is a string describing the meaning of the answer.
\\='((\"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)
(eq (symbol-function 'yes-or-no-p) 'y-or-n-p)
(if (assoc "help" answers)
(append answers '(("help" ?? "show this help message")))))
(assoc-delete-all "help" (copy-alist answers-with-help)))
(format "%s(%s) " question
(mapconcat (lambda (a)
(if short
(format "%c" (nth 1 a))
(nth 0 a)))
answers-with-help ", ")))
(format "Please answer %s."
(mapconcat (lambda (a)
(format "`%s'" (if short
(string (nth 1 a))
(nth 0 a))))
answers-with-help " or ")))
(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 (vector (nth 1 a))
(lambda ()
(insert (nth 0 a))
(define-key map [remap self-insert-command]
(lambda ()
(message message)
(sleep-for 2)))
(while (not (assoc (setq answer (downcase
((and (display-popup-menus-p)
last-input-event ; not during startup
(listp last-nonmenu-event)
(cons question
(mapcar (lambda (a)
(cons (capitalize (nth 0 a))
(nth 0 a)))
prompt nil short-answer-map nil
prompt nil nil nil
(if (string= answer "help")
(with-help-window "*Help*"
(with-current-buffer "*Help*"
(insert "Type:\n"
(lambda (a)
(format "`%s'%s to %s"
(if short (string (nth 1 a)) (nth 0 a))
(if short (format " (%s)" (nth 0 a)) "")
(nth 2 a)))
answers-with-help ",\n")
(message message)
(sleep-for 2)))
;;; map-ynp.el ends here
......@@ -705,6 +705,21 @@ Non-strings in LIST are ignored."
(setq list (cdr list)))
(defun assoc-delete-all (key alist)
"Delete from ALIST all elements whose car is `equal' to KEY.
Return the modified alist.
Elements of ALIST that are not conses are ignored."
(while (and (consp (car alist))
(equal (car (car alist)) key))
(setq alist (cdr alist)))
(let ((tail alist) tail-cdr)
(while (setq tail-cdr (cdr tail))
(if (and (consp (car tail-cdr))
(equal (car (car tail-cdr)) key))
(setcdr tail (cdr tail-cdr))
(setq tail tail-cdr))))
(defun assq-delete-all (key alist)
"Delete from ALIST all elements whose car is `eq' to KEY.
Return the modified alist.
......@@ -384,9 +384,9 @@
(let (asked)
(advice-add 'dired--yes-no-all-quit-help
(advice-add 'read-answer
(lambda (_) (setq asked t) "")
(lambda (_q _a) (setq asked t) "")
'((name . dired-test-bug27940-advice)))
(dired default-directory)
......@@ -395,44 +395,44 @@
(should-not asked)
(should-not (dired-get-marked-files))) ; All dirs deleted.
(advice-remove 'dired--yes-no-all-quit-help 'dired-test-bug27940-advice))))
(advice-remove 'read-answer 'dired-test-bug27940-advice))))
;; Answer yes
(advice-add 'dired--yes-no-all-quit-help :override (lambda (_) "yes")
(advice-add 'read-answer :override (lambda (_q _a) "yes")
'((name . dired-test-bug27940-advice)))
(dired default-directory)
(dired-do-delete nil)
(should-not (dired-get-marked-files)) ; All dirs deleted.
(advice-remove 'dired--yes-no-all-quit-help 'dired-test-bug27940-advice)))
(advice-remove 'read-answer 'dired-test-bug27940-advice)))
;; Answer no
(advice-add 'dired--yes-no-all-quit-help :override (lambda (_) "no")
(advice-add 'read-answer :override (lambda (_q _a) "no")
'((name . dired-test-bug27940-advice)))
(dired default-directory)
(dired-do-delete nil)
(should (= 5 (length (dired-get-marked-files)))) ; Just the empty dirs deleted.
(advice-remove 'dired--yes-no-all-quit-help 'dired-test-bug27940-advice)))
(advice-remove 'read-answer 'dired-test-bug27940-advice)))
;; Answer all
(advice-add 'dired--yes-no-all-quit-help :override (lambda (_) "all")
(advice-add 'read-answer :override (lambda (_q _a) "all")
'((name . dired-test-bug27940-advice)))
(dired default-directory)
(dired-do-delete nil)
(should-not (dired-get-marked-files)) ; All dirs deleted.
(advice-remove 'dired--yes-no-all-quit-help 'dired-test-bug27940-advice)))
(advice-remove 'read-answer 'dired-test-bug27940-advice)))
;; Answer quit
(advice-add 'dired--yes-no-all-quit-help :override (lambda (_) "quit")
(advice-add 'read-answer :override (lambda (_q _a) "quit")
'((name . dired-test-bug27940-advice)))
(dired default-directory)
......@@ -440,7 +440,7 @@
(dired-do-delete nil))
(should (= 6 (length (dired-get-marked-files)))) ; All empty dirs but zeta-empty-dir deleted.
(advice-remove 'dired--yes-no-all-quit-help 'dired-test-bug27940-advice))))
(advice-remove 'read-answer 'dired-test-bug27940-advice))))
(provide 'dired-tests)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment