Commit afba4ccb authored by Juri Linkov's avatar Juri Linkov

New function read-answer (bug#30073)

* lisp/emacs-lisp/map-ynp.el (read-answer): New function.
(read-answer-short): New defcustom.

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

* lisp/subr.el (assoc-delete-all): New function.
parent 9ae0e4aa
......@@ -240,6 +240,9 @@ file name extensions.
** The ecomplete sorting has changed to a decay-based algorithm. This
can be controlled by the new `ecomplete-sort-predicate' variable.
** The new function 'read-answer' accepts either long or short answers
depending on the new customizable variable 'read-answer-short'.
* Changes in Emacs 27.1 on Non-Free Operating Systems
......
......@@ -2997,37 +2997,6 @@ Any other value means to ask for each directory."
;; Match anything but `.' and `..'.
(defvar dired-re-no-dot "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")
(defconst dired-delete-help
"Type:
`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 ()
(read-string
(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")
(beep)
(message "Please answer `yes' or `no' or `all' or `quit'")
(sleep-for 2))
(setq answer (funcall input-fn)))
answer))
;; 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.
......@@ -3057,11 +3026,17 @@ TRASH non-nil means to trash the file instead of deleting, provided
"trash"
"delete")
(dired-make-relative file))))
(pcase (dired--yes-no-all-quit-help prompt) ; Prompt user.
(pcase (read-answer
prompt
'(("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))))
......
......@@ -252,4 +252,126 @@ C-g to quit (cancel the whole command);
;; 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 (eq (symbol-function 'yes-or-no-p) 'y-or-n-p)
"If non-nil, accept short answers to the question."
:type 'boolean
:version "27.1"
: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.
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."
(custom-reevaluate-setting 'read-answer-short)
(let* ((short 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
(format "%c" (nth 1 a))
(nth 0 a)))
answers-with-help ", ")))
(message
(format "Please answer %s."
(mapconcat (lambda (a)
(format "`%s'" (if short
(string (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 (vector (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)
(sleep-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
'yes-or-no-p-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 (string (nth 1 a)) (nth 0 a))
(if short (format " (%s)" (nth 0 a)) "")
(nth 2 a)))
answers-with-help ",\n")
".\n")))
(beep)
(message message)
(sleep-for 2)))
answer))
;;; map-ynp.el ends here
......@@ -705,6 +705,21 @@ Non-strings in LIST are ignored."
(setq list (cdr list)))
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))))
alist)
(defun assq-delete-all (key alist)
"Delete from ALIST all elements whose car is `eq' to KEY.
Return the modified alist.
......
......@@ -59,7 +59,7 @@
(unwind-protect
(if ,yes-or-no
(cl-letf (((symbol-function 'yes-or-no-p)
(lambda (prompt) (eq ,yes-or-no 'yes))))
(lambda (_prompt) (eq ,yes-or-no 'yes))))
,@body)
,@body)
;; clean up
......
......@@ -384,9 +384,9 @@
(dired-test-with-temp-dirs
'just-empty-dirs
(let (asked)
(advice-add 'dired--yes-no-all-quit-help
(advice-add 'read-answer
:override
(lambda (_) (setq asked t) "")
(lambda (_q _a) (setq asked t) "")
'((name . dired-test-bug27940-advice)))
(dired default-directory)
(dired-toggle-marks)
......@@ -395,44 +395,44 @@
(progn
(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
(dired-test-with-temp-dirs
nil
(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-toggle-marks)
(dired-do-delete nil)
(unwind-protect
(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
(dired-test-with-temp-dirs
nil
(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-toggle-marks)
(dired-do-delete nil)
(unwind-protect
(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
(dired-test-with-temp-dirs
nil
(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-toggle-marks)
(dired-do-delete nil)
(unwind-protect
(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
(dired-test-with-temp-dirs
nil
(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)
(dired-toggle-marks)
......@@ -440,7 +440,7 @@
(dired-do-delete nil))
(unwind-protect
(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