* 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.
** 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'.
+
\f
* Changes in Emacs 27.1 on Non-Free Operating Systems
;; 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.
"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))))
;; 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 (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
(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.
(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
(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)
(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)
(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)
projects / emacs.git / commitdiff