bug#30280: async-shell-command-display-buffer doesn't work anymore

["Basil L. Contovounesios" <contovob@tcd.ie>]

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: 0001-Fix-failing-test-for-bug-30280.patch --]
[-- Type: text/x-diff, Size: 3786 bytes --]

From 871cc1bd0b4ef13b759814e4f32a644463e887d7 Mon Sep 17 00:00:00 2001
From: "Basil L. Contovounesios" <contovob@tcd.ie>
Date: Fri, 20 Apr 2018 15:45:06 +0100
Subject: [PATCH 1/2] Fix failing test for bug#30280

* test/lisp/simple-tests.el
(simple-tests-async-shell-command-30280): Fix failing test.
---
 test/lisp/simple-tests.el | 59 ++++++++++++++++++++++++++-------------
 1 file changed, 40 insertions(+), 19 deletions(-)

diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el
index 7a10df2058..678d9b9385 100644
--- a/test/lisp/simple-tests.el
+++ b/test/lisp/simple-tests.el
@@ -521,30 +521,51 @@ simple-test-undo-with-switched-buffer
     (do-auto-fill)
     (should (string-equal (buffer-string) "foo bar"))))
 
+\f
+;;; Shell command.
+
 (ert-deftest simple-tests-async-shell-command-30280 ()
   "Test for https://debbugs.gnu.org/30280 ."
-  :expected-result :failed
   (let* ((async-shell-command-buffer 'new-buffer)
          (async-shell-command-display-buffer nil)
-         (str "*Async Shell Command*")
-         (buffers-name
-          (cl-loop repeat 2
-                   collect (buffer-name
-                            (generate-new-buffer str))))
+         (base "name")
+         (first (buffer-name (generate-new-buffer base)))
+         (second (generate-new-buffer-name base))
+         ;; `save-window-excursion' doesn't restore frame configurations.
+         (pop-up-frames nil)
          (inhibit-message t))
-    (mapc #'kill-buffer buffers-name)
-    (async-shell-command
-     (format "%s -Q -batch -eval '(progn (sleep-for 3600) (message \"foo\"))'"
-             invocation-name))
-    (async-shell-command
-     (format "%s -Q -batch -eval '(progn (sleep-for 1) (message \"bar\"))'"
-             invocation-name))
-    (let ((buffers (mapcar #'get-buffer buffers-name))
-          (processes (mapcar #'get-buffer-process buffers-name)))
-      (unwind-protect
-          (should (memq (cadr buffers) (mapcar #'window-buffer (window-list))))
-        (mapc #'delete-process processes)
-        (mapc #'kill-buffer buffers)))))
+    ;; Let `shell-command' create the buffer as needed.
+    (kill-buffer first)
+    (unwind-protect
+        (save-window-excursion
+          ;; One command has no output, the other does.
+          ;; Removing the -eval argument also yields no output, but
+          ;; then both commands exit simultaneously when
+          ;; `accept-process-output' is called on the second command.
+          (dolist (form '("(sleep-for 8)" "(message \"\")"))
+            (async-shell-command (format "%s -Q -batch -eval '%s'"
+                                         invocation-name form)
+                                 first))
+          ;; First command should neither have nor display output.
+          (let* ((buffer (get-buffer first))
+                 (process (get-buffer-process buffer)))
+            (should (buffer-live-p buffer))
+            (should process)
+            (should (zerop (buffer-size buffer)))
+            (should (not (get-buffer-window buffer))))
+          ;; Second command should both have and display output.
+          (let* ((buffer (get-buffer second))
+                 (process (get-buffer-process buffer)))
+            (should (buffer-live-p buffer))
+            (should process)
+            (should (accept-process-output process 4 nil t))
+            (should (> (buffer-size buffer) 0))
+            (should (get-buffer-window buffer))))
+      (dolist (name (list first second))
+        (let* ((buffer (get-buffer name))
+               (process (and buffer (get-buffer-process buffer))))
+          (when process (delete-process process))
+          (when buffer (kill-buffer buffer)))))))
 
 (provide 'simple-test)
 ;;; simple-test.el ends here
-- 
2.17.0


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0002-Minor-shell-command-simplifications.patch --]
[-- Type: text/x-diff, Size: 7049 bytes --]

From 8743148a16480f12923dbaecdefbc641b64d7f0a Mon Sep 17 00:00:00 2001
From: "Basil L. Contovounesios" <contovob@tcd.ie>
Date: Sun, 6 May 2018 16:41:01 +0100
Subject: [PATCH 2/2] Minor shell-command simplifications

* lisp/simple.el (shell-command): Use call-process-shell-command,
start-process-shell-command, and file-attribute-size.  Keep track of
output-buffer only by its object, not by its name. (bug#30280)
---
 lisp/simple.el | 72 +++++++++++++++++++++++---------------------------
 1 file changed, 33 insertions(+), 39 deletions(-)

diff --git a/lisp/simple.el b/lisp/simple.el
index a0a6898e17..7958a3b134 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -3400,6 +3400,8 @@ async-shell-command
     (setq command (concat command " &")))
   (shell-command command output-buffer error-buffer))
 
+(declare-function comint-output-filter "comint" (process string))
+
 (defun shell-command (command &optional output-buffer error-buffer)
   "Execute string COMMAND in inferior shell; display output, if any.
 With prefix argument, insert the COMMAND's output at point.
@@ -3477,12 +3479,11 @@ shell-command
 	       (not (or (bufferp output-buffer)  (stringp output-buffer))))
 	  ;; Output goes in current buffer.
 	  (let ((error-file
-		 (if error-buffer
-		     (make-temp-file
-		      (expand-file-name "scor"
-					(or small-temporary-file-directory
-					    temporary-file-directory)))
-		   nil)))
+                 (and error-buffer
+                      (make-temp-file
+                       (expand-file-name "scor"
+                                         (or small-temporary-file-directory
+                                             temporary-file-directory))))))
 	    (barf-if-buffer-read-only)
 	    (push-mark nil t)
 	    ;; We do not use -f for csh; we will not support broken use of
@@ -3490,24 +3491,22 @@ shell-command
 	    ;; "if ($?prompt) exit" before things which are not useful
 	    ;; non-interactively.  Besides, if someone wants their other
 	    ;; aliases for shell commands then they can still have them.
-	    (call-process shell-file-name nil
-			  (if error-file
-			      (list t error-file)
-			    t)
-			  nil shell-command-switch command)
+            (call-process-shell-command command nil (if error-file
+                                                        (list t error-file)
+                                                      t))
 	    (when (and error-file (file-exists-p error-file))
-	      (if (< 0 (nth 7 (file-attributes error-file)))
-		  (with-current-buffer (get-buffer-create error-buffer)
-		    (let ((pos-from-end (- (point-max) (point))))
-		      (or (bobp)
-			  (insert "\f\n"))
-		      ;; Do no formatting while reading error file,
-		      ;; because that can run a shell command, and we
-		      ;; don't want that to cause an infinite recursion.
-		      (format-insert-file error-file nil)
-		      ;; Put point after the inserted errors.
-		      (goto-char (- (point-max) pos-from-end)))
-		    (display-buffer (current-buffer))))
+              (when (< 0 (file-attribute-size (file-attributes error-file)))
+                (with-current-buffer (get-buffer-create error-buffer)
+                  (let ((pos-from-end (- (point-max) (point))))
+                    (or (bobp)
+                        (insert "\f\n"))
+                    ;; Do no formatting while reading error file,
+                    ;; because that can run a shell command, and we
+                    ;; don't want that to cause an infinite recursion.
+                    (format-insert-file error-file nil)
+                    ;; Put point after the inserted errors.
+                    (goto-char (- (point-max) pos-from-end)))
+                  (display-buffer (current-buffer))))
 	      (delete-file error-file))
 	    ;; This is like exchange-point-and-mark, but doesn't
 	    ;; activate the mark.  It is cleaner to avoid activation,
@@ -3525,13 +3524,11 @@ shell-command
 	      ;; Command ending with ampersand means asynchronous.
               (let* ((buffer (get-buffer-create
                               (or output-buffer "*Async Shell Command*")))
-                     (bname (buffer-name buffer))
-                     (directory default-directory)
-                     proc)
+                     (proc (get-buffer-process buffer))
+                     (directory default-directory))
 		;; Remove the ampersand.
 		(setq command (substring command 0 (match-beginning 0)))
 		;; Ask the user what to do with already running process.
-		(setq proc (get-buffer-process buffer))
 		(when proc
 		  (cond
 		   ((eq async-shell-command-buffer 'confirm-kill-process)
@@ -3542,35 +3539,32 @@ shell-command
 		   ((eq async-shell-command-buffer 'confirm-new-buffer)
 		    ;; If will create a new buffer, query first.
 		    (if (yes-or-no-p "A command is running in the default buffer.  Use a new buffer? ")
-                        (setq buffer (generate-new-buffer bname))
+                        (setq buffer (generate-new-buffer (buffer-name buffer)))
 		      (error "Shell command in progress")))
 		   ((eq async-shell-command-buffer 'new-buffer)
 		    ;; It will create a new buffer.
-                    (setq buffer (generate-new-buffer bname)))
+                    (setq buffer (generate-new-buffer (buffer-name buffer))))
 		   ((eq async-shell-command-buffer 'confirm-rename-buffer)
 		    ;; If will rename the buffer, query first.
 		    (if (yes-or-no-p "A command is running in the default buffer.  Rename it? ")
-			(progn
-			  (with-current-buffer buffer
-			    (rename-uniquely))
-                          (setq buffer (get-buffer-create bname)))
+                        (with-current-buffer buffer
+                          (rename-uniquely))
 		      (error "Shell command in progress")))
 		   ((eq async-shell-command-buffer 'rename-buffer)
 		    ;; It will rename the buffer.
 		    (with-current-buffer buffer
-		      (rename-uniquely))
-                    (setq buffer (get-buffer-create bname)))))
+                      (rename-uniquely)))))
 		(with-current-buffer buffer
                   (shell-command--save-pos-or-erase)
 		  (setq default-directory directory)
-		  (setq proc (start-process "Shell" buffer shell-file-name
-					    shell-command-switch command))
+                  (setq proc
+                        (start-process-shell-command "Shell" buffer command))
 		  (setq mode-line-process '(":%s"))
 		  (require 'shell) (shell-mode)
-		  (set-process-sentinel proc 'shell-command-sentinel)
+                  (set-process-sentinel proc #'shell-command-sentinel)
 		  ;; Use the comint filter for proper handling of
 		  ;; carriage motion (see comint-inhibit-carriage-motion).
-		  (set-process-filter proc 'comint-output-filter)
+                  (set-process-filter proc #'comint-output-filter)
                   (if async-shell-command-display-buffer
                       ;; Display buffer immediately.
                       (display-buffer buffer '(nil (allow-no-window . t)))
-- 
2.17.0


[-- Attachment #3: Type: text/plain, Size: 547 bytes --]


I recently noticed that a test for an expected failure was added around
the time of this bug report[1: ea8c0e1b9e].

[1: ea8c0e1b9e]: 2018-01-29 22:31:50 +0900
  * test/lisp/simple-tests.el (simple-tests-async-shell-command-30280): Add test
  https://git.savannah.gnu.org/cgit/emacs.git/commit/?id=ea8c0e1b9eaa6651919fb4e039e3fcb5a1fa73db

I attach two patches.  The first tries to make this test succeed in
accordance with the resulting bugfix.  The second suggests some
simplifications to the logic in shell-command.  WDYT?

Thanks,

-- 
Basil