From: Noam Postavsky <npostavs@gmail.com>
To: Leo Liu <sdl.web@gmail.com>
Cc: 31782@debbugs.gnu.org, Juri Linkov <juri@linkov.net>
Subject: bug#31782: 26.1; dired-recursive-deletes broken
Date: Mon, 30 Jul 2018 21:39:12 -0400 [thread overview]
Message-ID: <87va8w18vz.fsf@gmail.com> (raw)
In-Reply-To: <87wov0uwai.fsf@gmail.com> (Noam Postavsky's message of "Fri, 15 Jun 2018 07:24:53 -0400")
[-- Attachment #1: Type: text/plain, Size: 585 bytes --]
tags 31782 + patch
quit
Noam Postavsky <npostavs@gmail.com> writes:
> So, looking at the Bug#30073 fix, the new (currently being introduced in
> Emacs 27) read-answer function looks pretty similar to
> read-multiple-choice. Perhaps some sharing is in order?
There are differences in both the interface and implementation which
make it difficult to merge these, even though the functionality has some
overlap. Maybe something could be done later, but for now we'll have to
settle for taking it as is (modulo the fix for the standard value
problem). Here is the backported patch:
[-- Attachment #2: patch --]
[-- Type: text/plain, Size: 14481 bytes --]
From 0cb77a6c47799a556f224176e5e122b276224328 Mon Sep 17 00:00:00 2001
From: Juri Linkov <juri@linkov.net>
Date: Sun, 21 Jan 2018 23:45:43 +0200
Subject: [PATCH] New function read-answer (bug#30073)
* lisp/emacs-lisp/map-ynp.el (read-answer-short): New defcustom.
(read-answer): New function.
* etc/NEWS: Announce it.
* 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.
(backported from master, "New function read-answer (bug#30073)" and
"Respect non-saved value of `read-short-answer' (Bug#31782)")
---
etc/NEWS | 3 ++
lisp/dired.el | 41 +++------------
lisp/emacs-lisp/map-ynp.el | 128 +++++++++++++++++++++++++++++++++++++++++++++
lisp/subr.el | 15 ++++++
test/lisp/dired-tests.el | 22 ++++----
5 files changed, 165 insertions(+), 44 deletions(-)
diff --git a/etc/NEWS b/etc/NEWS
index a27d1b89ec..331d5767f7 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -110,6 +110,9 @@ be removed prior using the changed 'shadow-*' commands.
\f
* 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'.
+
\f
* Changes in Emacs 26.2 on Non-Free Operating Systems
diff --git a/lisp/dired.el b/lisp/dired.el
index c421e51ffd..2520ed2a10 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -2995,37 +2995,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.
@@ -3055,11 +3024,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/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el
index 2a7eddedad..a1489c66ed 100644
--- a/lisp/emacs-lisp/map-ynp.el
+++ b/lisp/emacs-lisp/map-ynp.el
@@ -256,4 +256,132 @@ map-y-or-n-p
;; Return the number of actions that were taken.
actions))
+\f
+;; 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
+ "Control whether `read-answer' accepts short 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 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."
+ (let* ((short (if (eq read-answer-short 'auto)
+ (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
+ (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
diff --git a/lisp/subr.el b/lisp/subr.el
index f8ac70edef..7582b6cdb8 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -705,6 +705,21 @@ member-ignore-case
(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.
diff --git a/test/lisp/dired-tests.el b/test/lisp/dired-tests.el
index c0242137b3..bb0e1bc388 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)
--
2.11.0
[-- Attachment #3: Type: text/plain, Size: 712 bytes --]
I guess assoc-delete-all should be announced in NEWS too? Although it
looks like it could be replaced with cl-delete instead.
> Another thing is that the defcustom default value trick doesn't work as
> intended (as far as I understand the intention, at least).
>
> ;; 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."
> I think we'd want some `auto' setting which would tell read-answer to
> look at the yes-or-no-p function value at run time.
Here's a patch for that against master (I already included this into the
backported patch above).
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: patch --]
[-- Type: text/x-diff, Size: 2068 bytes --]
From 1059db2520f1aa8d26d2cdb253c57421f647df2e Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
Date: Wed, 4 Jul 2018 22:51:45 -0400
Subject: [PATCH 1/2] Respect non-saved value of `read-short-answer'
(Bug#31782)
* lisp/emacs-lisp/map-ynp.el (read-answer-short): Add an `auto'
setting.
(read-answer): Check the function cell of `yes-or-no-p' when
`read-answer-short' is `auto' rather than calling
`custom-reevaluate-setting' which would reset the option to its saved
value.
---
lisp/emacs-lisp/map-ynp.el | 16 +++++++++++-----
1 file changed, 11 insertions(+), 5 deletions(-)
diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el
index 61c04ff7b3..c029c7e1b5 100644
--- a/lisp/emacs-lisp/map-ynp.el
+++ b/lisp/emacs-lisp/map-ynp.el
@@ -257,9 +257,14 @@ map-y-or-n-p
;; 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
+(defcustom read-answer-short 'auto
+ "Control whether `read-answer' accepts short 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 "27.1"
:group 'minibuffer)
@@ -290,8 +295,9 @@ read-answer
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)
+ (let* ((short (if (eq read-answer-short 'auto)
+ (eq (symbol-function 'yes-or-no-p) 'y-or-n-p)
+ read-answer-short))
(answers-with-help
(if (assoc "help" answers)
answers
--
2.11.0
[-- Attachment #5: Type: text/plain, Size: 135 bytes --]
And once backported, we should remove the announcement from 27.1 NEWS,
since the new function it will already be introduced in 26.2:
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #6: patch --]
[-- Type: text/x-diff, Size: 883 bytes --]
From c791639c259abe6e514a4e3ffd62c904cff636e2 Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
Date: Mon, 30 Jul 2018 21:02:07 -0400
Subject: [PATCH 2/2] ; etc/NEWS: Remove read-answer, it was backported to v26
---
etc/NEWS | 4 ----
1 file changed, 4 deletions(-)
diff --git a/etc/NEWS b/etc/NEWS
index 5ca1b428de..2825bb9f59 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -913,10 +913,6 @@ higher-level functions.
some years back. It now respects 'imagemagick-types-inhibit' as a way
to disable that.
-+++
-** The new function 'read-answer' accepts either long or short answers
-depending on the new customizable variable 'read-answer-short'.
-
** The function 'load' now behaves correctly when loading modules.
Specifically, it puts the module name into 'load-history', prints
loading messages if requested, and protects against recursive loads.
--
2.11.0
next prev parent reply other threads:[~2018-07-31 1:39 UTC|newest]
Thread overview: 15+ messages / expand[flat|nested] mbox.gz Atom feed top
2018-06-11 5:09 bug#31782: 26.1; dired-recursive-deletes broken Leo Liu
2018-06-11 14:33 ` Noam Postavsky
2018-06-11 17:23 ` Eli Zaretskii
2018-06-12 21:55 ` Noam Postavsky
2018-06-13 2:32 ` Eli Zaretskii
2018-06-14 4:15 ` Leo Liu
2018-06-14 13:05 ` Noam Postavsky
2018-06-14 13:26 ` Leo Liu
2018-06-15 11:24 ` Noam Postavsky
2018-07-31 1:39 ` Noam Postavsky [this message]
2018-07-31 16:00 ` Eli Zaretskii
2018-08-01 4:35 ` Richard Stallman
2018-08-01 6:04 ` Eli Zaretskii
2018-08-01 13:00 ` Basil L. Contovounesios
2018-08-04 16:02 ` Noam Postavsky
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
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87va8w18vz.fsf@gmail.com \
--to=npostavs@gmail.com \
--cc=31782@debbugs.gnu.org \
--cc=juri@linkov.net \
--cc=sdl.web@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 external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.