procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

New function read-answer (bug#30073)

Browse source 
* 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.
This commit is contained in:
Juri Linkov 2018-01-21 23:45:43 +02:00
parent 9ae0e4aa1a
commit afba4ccb8b
6 changed files with 160 additions and 45 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
etc/NEWS
View file

@ -240,6 +240,9 @@ file name extensions.
** 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'.
* Changes in Emacs 27.1 on Non-Free Operating Systems

41
lisp/dired.el
View file

@ -2997,37 +2997,6 @@ Any other value means to ask for each directory."
;; 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 +3026,17 @@ TRASH non-nil means to trash the file instead of deleting, provided
"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))))

122
lisp/emacs-lisp/map-ynp.el
View file

@ -252,4 +252,126 @@ C-g to quit (cancel the whole command);
;; 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" (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

15
lisp/subr.el
View file

@ -705,6 +705,21 @@ Non-strings in LIST are ignored."
(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.

2
test/lisp/dired-aux-tests.el
View file

@ -59,7 +59,7 @@
(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

22
test/lisp/dired-tests.el
View file

@ -384,9 +384,9 @@
(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 @@
(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-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)