From: Juri Linkov <juri@linkov.net>
To: Eli Zaretskii <eliz@gnu.org>
Cc: contovob@tcd.ie, 30073@debbugs.gnu.org, tino.calancha@gmail.com
Subject: bug#30073: 27.0.50; dired-do-delete ignores customization for short answers
Date: Thu, 18 Jan 2018 00:56:57 +0200 [thread overview]
Message-ID: <87inc0yt1y.fsf@mail.linkov.net> (raw)
In-Reply-To: <83a7xdy9eo.fsf@gnu.org> (Eli Zaretskii's message of "Tue, 16 Jan 2018 19:56:47 +0200")
>> Regarding a new multiple options reading function ‘read-answer’, I'm
>> not sure where to put it.
>
> How many callers does it have now, and which callers are those?
Currently it will have just one caller in ‘dired-delete-file’,
but it's possible to gradually replace all callers that are using
‘yes-or-no-p’ and ‘y-or-n-p’ with equivalent calls of ‘read-answer’
with the argument
'(("yes" ?y)
("no" ?n))
that will accept either long or short answer depending on the new
customizable variable.
In this patch I placed new code to map-ynp.el because in loadup.el
"emacs-lisp/map-ynp" is loaded immediately after loading "custom",
so map-ynp.el is the first file that allows using defcustom.
Most importantly, a new function is logically related to map-y-or-n-p,
and grouping related functions in one file is much better than polluting
file namespace with separate files such as map-ynp.el, rmc.el, crm.el...
diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el
index 2a7edde..85ed9e0 100644
--- a/lisp/emacs-lisp/map-ynp.el
+++ b/lisp/emacs-lisp/map-ynp.el
@@ -256,4 +256,86 @@ map-y-or-n-p
;; Return the number of actions that were taken.
actions))
+\f
+;; 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)
+
+(defun read-answer (question answers)
+ "Read an answer either as a complete word or its character abbreviation.
+Ask QUESTION and accept an answer from the list of possible ANSWERS.
+This list contains lists in the following format:
+ (LONG-ANSWER SHORT-ANSWER HELP-MESSAGE)
+where
+ LONG-ANSWER is a complete answer,
+ SHORT-ANSWER is an abbreviated one-letter 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\")
+ (\"quit\" ?q \"exit\"))
+
+When `read-answer-short' is non-nil, accept short answers.
+
+Return a long answer even in case of accepting short ones."
+ (custom-reevaluate-setting 'read-answer-short)
+ (let* ((short read-answer-short)
+ (answers-with-help (append answers '(("help" ?? "show this help message"))))
+ (prompt (format "%s(%s) " question
+ (mapconcat (lambda (a)
+ (if short (format "%c=%s" (nth 1 a) (nth 0 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
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map minibuffer-local-map)
+ (dolist (answer answers-with-help)
+ (define-key map (vector (nth 1 answer))
+ (lambda ()
+ (interactive)
+ (delete-minibuffer-contents)
+ (insert (nth 0 answer))
+ (exit-minibuffer))))
+ (define-key map [remap self-insert-command]
+ (lambda ()
+ (interactive)
+ (delete-minibuffer-contents)
+ (beep)
+ (message message)
+ (sleep-for 2)))
+ map)))
+ answer)
+ (while (not (assoc (setq answer (cond (short
+ (read-from-minibuffer
+ prompt nil short-answer-map))
+ (t
+ (read-from-minibuffer
+ prompt nil nil nil
+ 'yes-or-no-p-history))))
+ answers))
+ (if (string= answer "help")
+ (with-help-window "*Help*"
+ (with-current-buffer "*Help*"
+ (insert "Type:\n"
+ (mapconcat (lambda (a)
+ (format "`%s' to %s"
+ (if short
+ (format "%c (%s)" (nth 1 a) (nth 0 a))
+ (nth 0 a))
+ (nth 2 a)))
+ answers-with-help ",\n")
+ ".\n")))
+ (beep)
+ (message message)
+ (sleep-for 2)))
+ answer))
+
;;; map-ynp.el ends here
diff --git a/lisp/dired.el b/lisp/dired.el
index b853d64..9a412d0 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -2997,37 +2998,6 @@ dired-recursive-deletes
;; 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 +3027,17 @@ dired-delete-file
"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))))
diff --git a/test/lisp/dired-tests.el b/test/lisp/dired-tests.el
index c024213..bb0e1bc 100644
--- a/test/lisp/dired-tests.el
+++ b/test/lisp/dired-tests.el
@@ -384,9 +384,9 @@ dired-test-with-temp-dirs
(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 @@ dired-test-with-temp-dirs
(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-test-with-temp-dirs
(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)
next prev parent reply other threads:[~2018-01-17 22:56 UTC|newest]
Thread overview: 29+ messages / expand[flat|nested] mbox.gz Atom feed top
2018-01-10 21:41 bug#30073: 27.0.50; dired-do-delete ignores customization for short answers Juri Linkov
2018-01-11 3:00 ` Basil L. Contovounesios
2018-01-11 15:52 ` Eli Zaretskii
2018-01-11 17:34 ` Basil L. Contovounesios
2018-01-11 18:01 ` Eli Zaretskii
2018-01-11 19:39 ` Basil L. Contovounesios
2018-01-11 21:57 ` Juri Linkov
2018-01-11 21:54 ` Juri Linkov
2018-01-12 9:57 ` Eli Zaretskii
2018-01-13 22:38 ` Juri Linkov
2018-01-14 11:01 ` Tino Calancha
2018-01-14 22:53 ` Juri Linkov
2018-01-15 5:19 ` Eli Zaretskii
2018-01-15 23:02 ` Juri Linkov
2018-01-16 17:56 ` Eli Zaretskii
2018-01-17 22:56 ` Juri Linkov [this message]
2018-01-18 21:11 ` Juri Linkov
2018-01-15 17:01 ` Drew Adams
2018-01-15 23:13 ` Juri Linkov
2018-01-16 0:48 ` Drew Adams
2018-01-17 22:03 ` Juri Linkov
2018-01-18 3:36 ` Eli Zaretskii
2018-01-18 21:12 ` Juri Linkov
2018-01-21 21:46 ` Juri Linkov
2018-01-25 18:04 ` Drew Adams
2018-01-25 21:20 ` Juri Linkov
2018-01-25 21:48 ` Drew Adams
2018-01-26 7:57 ` Eli Zaretskii
2018-01-27 21:20 ` Juri Linkov
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87inc0yt1y.fsf@mail.linkov.net \
--to=juri@linkov.net \
--cc=30073@debbugs.gnu.org \
--cc=contovob@tcd.ie \
--cc=eliz@gnu.org \
--cc=tino.calancha@gmail.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).