From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: Juri Linkov Newsgroups: gmane.emacs.bugs Subject: bug#30073: 27.0.50; dired-do-delete ignores customization for short answers Date: Thu, 18 Jan 2018 23:12:06 +0200 Organization: LINKOV.NET Message-ID: <874lnjqeft.fsf@mail.linkov.net> References: <87bmi1cryh.fsf@mail.linkov.net> <87o9m1nlpl.fsf@gmail.com> <83po6g4cky.fsf@gnu.org> <87vag8f4da.fsf@mail.linkov.net> <83fu7b2yda.fsf@gnu.org> <87y3l1e68y.fsf@mail.linkov.net> <871sis66w1.fsf@gmail.com> <874lno10di.fsf@mail.linkov.net> <87d12aaedz.fsf@mail.linkov.net> <8737345cy3.fsf@mail.linkov.net> <831sinx2ge.fsf@gnu.org> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: blaine.gmane.org 1516311312 21871 195.159.176.226 (18 Jan 2018 21:35:12 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Thu, 18 Jan 2018 21:35:12 +0000 (UTC) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/27.0.50 (x86_64-pc-linux-gnu) Cc: contovob@tcd.ie, 30073@debbugs.gnu.org, tino.calancha@gmail.com To: Eli Zaretskii Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Thu Jan 18 22:35:07 2018 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ecHpV-0003nt-9M for geb-bug-gnu-emacs@m.gmane.org; Thu, 18 Jan 2018 22:34:37 +0100 Original-Received: from localhost ([::1]:56979 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ecHrV-0002lc-Dc for geb-bug-gnu-emacs@m.gmane.org; Thu, 18 Jan 2018 16:36:41 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:34359) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ecHqv-0002Pj-DG for bug-gnu-emacs@gnu.org; Thu, 18 Jan 2018 16:36:08 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1ecHqt-0004wU-JJ for bug-gnu-emacs@gnu.org; Thu, 18 Jan 2018 16:36:05 -0500 Original-Received: from debbugs.gnu.org ([208.118.235.43]:54123) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1ecHqt-0004wL-DF for bug-gnu-emacs@gnu.org; Thu, 18 Jan 2018 16:36:03 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1ecHqt-0003GG-4f for bug-gnu-emacs@gnu.org; Thu, 18 Jan 2018 16:36:03 -0500 X-Loop: help-debbugs@gnu.org Resent-From: Juri Linkov Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Thu, 18 Jan 2018 21:36:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 30073 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch Original-Received: via spool by 30073-submit@debbugs.gnu.org id=B30073.151631131612450 (code B ref 30073); Thu, 18 Jan 2018 21:36:03 +0000 Original-Received: (at 30073) by debbugs.gnu.org; 18 Jan 2018 21:35:16 +0000 Original-Received: from localhost ([127.0.0.1]:33781 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ecHq6-0003Ef-3l for submit@debbugs.gnu.org; Thu, 18 Jan 2018 16:35:16 -0500 Original-Received: from sub3.mail.dreamhost.com ([69.163.253.7]:47321 helo=homiemail-a100.g.dreamhost.com) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ecHq4-0003ER-8q for 30073@debbugs.gnu.org; Thu, 18 Jan 2018 16:35:13 -0500 Original-Received: from homiemail-a100.g.dreamhost.com (localhost [127.0.0.1]) by homiemail-a100.g.dreamhost.com (Postfix) with ESMTP id B6CE831A073; Thu, 18 Jan 2018 13:35:11 -0800 (PST) Original-Received: from localhost.linkov.net (m91-129-98-183.cust.tele2.ee [91.129.98.183]) (using TLSv1 with cipher DHE-RSA-AES128-SHA (128/128 bits)) (No client certificate requested) (Authenticated sender: jurta@jurta.org) by homiemail-a100.g.dreamhost.com (Postfix) with ESMTPSA id B785A31A075; Thu, 18 Jan 2018 13:35:09 -0800 (PST) In-Reply-To: <831sinx2ge.fsf@gnu.org> (Eli Zaretskii's message of "Thu, 18 Jan 2018 05:36:49 +0200") X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 208.118.235.43 X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.org gmane.emacs.bugs:142274 Archived-At: --=-=-= Content-Type: text/plain > 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. --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=read-answer.patch 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) --=-=-=--