[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#30073: 27.0.50; dired-do-delete ignores customization for short answ
From: |
Juri Linkov |
Subject: |
bug#30073: 27.0.50; dired-do-delete ignores customization for short answers |
Date: |
Thu, 18 Jan 2018 23:12:06 +0200 |
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/27.0.50 (x86_64-pc-linux-gnu) |
> Thus, making the customization "official" in this case is the only way
> to "fix" the "regression".
>
> Thanks for working on this.
Here is a quite final patch I believe. At least, it works
without noticed problems in my tests.
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/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el
index 2a7edde..1b67dc2 100644
--- a/lisp/emacs-lisp/map-ynp.el
+++ b/lisp/emacs-lisp/map-ynp.el
@@ -256,4 +256,125 @@ map-y-or-n-p
;; 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=%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
+ (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))
+ (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 46cf5a3..092850a 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-aux-tests.el b/test/lisp/dired-aux-tests.el
index 89cb7b6..ab6d1cb 100644
--- a/test/lisp/dired-aux-tests.el
+++ b/test/lisp/dired-aux-tests.el
@@ -59,7 +59,7 @@ with-dired-bug28834-test
(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
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)
- bug#30073: 27.0.50; dired-do-delete ignores customization for short answers, (continued)
- bug#30073: 27.0.50; dired-do-delete ignores customization for short answers, Eli Zaretskii, 2018/01/15
- bug#30073: 27.0.50; dired-do-delete ignores customization for short answers, Juri Linkov, 2018/01/15
- bug#30073: 27.0.50; dired-do-delete ignores customization for short answers, Eli Zaretskii, 2018/01/16
- bug#30073: 27.0.50; dired-do-delete ignores customization for short answers, Juri Linkov, 2018/01/17
- bug#30073: 27.0.50; dired-do-delete ignores customization for short answers, Juri Linkov, 2018/01/18
- bug#30073: 27.0.50; dired-do-delete ignores customization for short answers, Drew Adams, 2018/01/15
- bug#30073: 27.0.50; dired-do-delete ignores customization for short answers, Juri Linkov, 2018/01/15
- bug#30073: 27.0.50; dired-do-delete ignores customization for short answers, Drew Adams, 2018/01/15
- bug#30073: 27.0.50; dired-do-delete ignores customization for short answers, Juri Linkov, 2018/01/17
- bug#30073: 27.0.50; dired-do-delete ignores customization for short answers, Eli Zaretskii, 2018/01/17
- bug#30073: 27.0.50; dired-do-delete ignores customization for short answers,
Juri Linkov <=
- bug#30073: 27.0.50; dired-do-delete ignores customization for short answers, Juri Linkov, 2018/01/21
- bug#30073: 27.0.50; dired-do-delete ignores customization for short answers, Drew Adams, 2018/01/25
- bug#30073: 27.0.50; dired-do-delete ignores customization for short answers, Juri Linkov, 2018/01/25
- bug#30073: 27.0.50; dired-do-delete ignores customization for short answers, Drew Adams, 2018/01/25
- bug#30073: 27.0.50; dired-do-delete ignores customization for short answers, Eli Zaretskii, 2018/01/26
- bug#30073: 27.0.50; dired-do-delete ignores customization for short answers, Juri Linkov, 2018/01/27