bug#30073: 27.0.50; dired-do-delete ignores customization for short answers

[Juri Linkov]

>> 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))
 
+
+;; 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)