Subject: 27.0.50; Error in async shell-command process filter

From: "Basil L. Contovounesios" <[email-masked]>
Date: Wed, 25 Oct 2017 16:50:01 +0100

>From 064e4e4d9958fcfc0980091f302a0dd31bdc4581 Mon Sep 17 00:00:00 2001
From: "Basil L. Contovounesios" <[email-masked]>
Date: Wed, 25 Oct 2017 16:15:19 +0100
Subject: [PATCH 1/2] Fix buffer name comparison in async shell-command

When async-shell-command-display-buffer is nil, the async
shell-command process filter passed output-buffer, which could be a
buffer object, to string=, resulting in an error.

* lisp/simple.el (shell-command): Keep track of output-buffer name to
fix this and DRY.  Replace quoted lambda with closure.
---
 lisp/simple.el | 35 ++++++++++++++---------------------
 1 file changed, 14 insertions(+), 21 deletions(-)

diff --git a/lisp/simple.el b/lisp/simple.el
index 12d65e50c3..96f5a321f3 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -3487,10 +3487,11 @@ shell-command
 	(save-match-data
 	  (if (string-match "[ \t]*&[ \t]*\\'" command)
 	      ;; Command ending with ampersand means asynchronous.
-	      (let ((buffer (get-buffer-create
-			     (or output-buffer "*Async Shell Command*")))
-		    (directory default-directory)
-		    proc)
+              (let* ((buffer (get-buffer-create
+                              (or output-buffer "*Async Shell Command*")))
+                     (name (buffer-name buffer))
+                     (directory default-directory)
+                     proc)
 		;; Remove the ampersand.
 		(setq command (substring command 0 (match-beginning 0)))
 		;; Ask the user what to do with already running process.
@@ -3505,30 +3506,24 @@ 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
-				      (or (and (bufferp output-buffer) (buffer-name output-buffer))
-					  output-buffer "*Async Shell Command*")))
+                        (setq buffer (generate-new-buffer name))
 		      (error "Shell command in progress")))
 		   ((eq async-shell-command-buffer 'new-buffer)
 		    ;; It will create a new buffer.
-		    (setq buffer (generate-new-buffer
-				  (or (and (bufferp output-buffer) (buffer-name output-buffer))
-				      output-buffer "*Async Shell Command*"))))
+                    (setq buffer (generate-new-buffer name)))
 		   ((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
-					(or output-buffer "*Async Shell Command*"))))
+                          (setq buffer (get-buffer-create name)))
 		      (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
-				  (or output-buffer "*Async Shell Command*"))))))
+                    (setq buffer (get-buffer-create name)))))
 		(with-current-buffer buffer
                   (shell-command--save-pos-or-erase)
 		  (setq default-directory directory)
@@ -3543,13 +3538,11 @@ shell-command
                   (if async-shell-command-display-buffer
                       (display-buffer buffer '(nil (allow-no-window . t)))
                     (add-function :before (process-filter proc)
-                                  `(lambda (process string)
-                                     (when (and (= 0 (buffer-size (process-buffer process)))
-                                                (string= (buffer-name (process-buffer process))
-                                                    ,(or output-buffer "*Async Shell Command*")))
-                                       (display-buffer (process-buffer process))))
-                                  ))
-                  ))
+                                  (lambda (process _string)
+                                    (let ((buf (process-buffer process)))
+                                      (when (and (zerop (buffer-size buf))
+                                                 (string= (buffer-name buf) name))
+                                        (display-buffer buf))))))))
 	    ;; Otherwise, command is executed synchronously.
 	    (shell-command-on-region (point) (point) command
 				     output-buffer nil error-buffer)))))))
-- 
2.14.2

>From 6e192d6bb5c2c8c3565df14505b15327fb061d48 Mon Sep 17 00:00:00 2001
From: "Basil L. Contovounesios" <[email-masked]>
Date: Wed, 25 Oct 2017 16:22:06 +0100
Subject: [PATCH 2/2] * lisp/simple.el (shell-command): Simplify cond with
 pcase

---
 lisp/simple.el | 54 +++++++++++++++++++++++++++---------------------------
 1 file changed, 27 insertions(+), 27 deletions(-)

diff --git a/lisp/simple.el b/lisp/simple.el
index 96f5a321f3..147cc34646 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -3497,33 +3497,33 @@ shell-command
 		;; 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)
-		    ;; If will kill a process, query first.
-		    (if (yes-or-no-p "A command is running in the default buffer.  Kill it? ")
-			(kill-process proc)
-		      (error "Shell command in progress")))
-		   ((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 name))
-		      (error "Shell command in progress")))
-		   ((eq async-shell-command-buffer 'new-buffer)
-		    ;; It will create a new buffer.
-                    (setq buffer (generate-new-buffer name)))
-		   ((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 name)))
-		      (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 name)))))
+                  (pcase async-shell-command-buffer
+                    ('confirm-kill-process
+                     ;; If will kill a process, query first.
+                     (if (yes-or-no-p "A command is running in the default buffer.  Kill it? ")
+                         (kill-process proc)
+                       (error "Shell command in progress")))
+                    ('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 name))
+                       (error "Shell command in progress")))
+                    ('new-buffer
+                     ;; It will create a new buffer.
+                     (setq buffer (generate-new-buffer name)))
+                    ('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 name)))
+                       (error "Shell command in progress")))
+                    ('rename-buffer
+                     ;; It will rename the buffer.
+                     (with-current-buffer buffer
+                       (rename-uniquely))
+                     (setq buffer (get-buffer-create name)))))
 		(with-current-buffer buffer
                   (shell-command--save-pos-or-erase)
 		  (setq default-directory directory)
-- 
2.14.2

# Steps to reproduce

1) emacs -Q
2) M-x set-variable RET
   async-shell-command-display-buffer RET
   nil RET
3) M-: (async-shell-command
        "ls ~" (generate-new-buffer "home")) RET

This results in the following error:

  error in process filter: Wrong type argument:
    stringp, #<buffer home>

I attach the relevant backtrace.

# Diagnosis

When async-shell-command-display-buffer is nil, the async
shell-command process filter passes output-buffer, which
could be a buffer object, to string=.

# Patch

I attach two patches to address this issue.

The first patch replaces the quoted lambda process filter
with a closure over the name of output-buffer.  By keeping
track of this name, a lot of the surrounding
buffer-name-determining code can be simplified via DRY.

The second patch is purely aesthetic and simplifies the cond
that is touched by my first patch into an equivalent pcase.

# Environment

In GNU Emacs 27.0.50 (build 1, x86_64-pc-linux-gnu, X toolkit, Xaw3d scroll bars)
 of 2017-10-25 built on thunk
Repository revision: 090f4f157eea6f0d0d13963520f5e05706de142f
Windowing system distributor 'The X.Org Foundation', version 11.0.11905000
System Description:	Debian GNU/Linux testing (buster)

Recent messages:
Configuring package avy...done
Configuring package ace-window...done
Configuring package mm-decode...done
Configuring package dired...done
Loading /home/blc/.emacs.d/eudc-options...
Loading eudcb-bbdb...
Configuring package bbdb...done
Loading eudcb-bbdb...done
Loading /home/blc/.emacs.d/eudc-options...done
Configuring package message...done

Configured using:
 'configure --prefix=/home/blc/.local
 --enable-locallisppath= --with-mailutils --with-sound=yes
 --with-x-toolkit=lucid --with-xpm --with-jpeg --with-tiff
 --with-gif --with-png --with-rsvg --with-libsystemd
 --with-xml2 --with-imagemagick --with-xft --with-libotf
 --with-m17n-flt --with-toolkit-scroll-bars --with-xaw3d
 --with-xim --with-gpm --with-dbus --with-gsettings
 --with-selinux --with-gnutls --with-zlib --with-modules
 --with-threads --with-file-notification=yes --with-x
 --without-gconf --with-lcms2 'CFLAGS=-flto
 -fomit-frame-pointer -march=native -maes -mavx -mcrc32
 -mf16c -mfpmath=sse -mfsgsbase -mfxsr
 -minline-all-stringops -mmmx -mpclmul -mpopcnt -msahf
 -msse4.2 -mxsave -mxsaveopt -mvzeroupper -O3 -pipe'
 LDFLAGS=-flto'

Configured features:
XAW3D XPM JPEG TIFF GIF PNG RSVG IMAGEMAGICK SOUND GPM DBUS
GSETTINGS NOTIFY ACL LIBSELINUX GNUTLS LIBXML2 FREETYPE
M17N_FLT LIBOTF XFT ZLIB TOOLKIT_SCROLL_BARS LUCID X11
MODULES LIBSYSTEMD LCMS2

Important settings:
  value of $LANG: en_IE.UTF-8
  locale-coding-system: utf-8-unix

Major mode: Lisp Interaction

Minor modes in effect:
  ace-window-display-mode: t
  shell-dirtrack-mode: t
  counsel-mode: t
  bug-reference-prog-mode: t
  fic-mode: t
  global-paren-face-mode: t
  paren-face-mode: t
  xterm-mouse-mode: t
  winner-mode: t
  global-whitespace-mode: t
  display-time-mode: t
  global-subword-mode: t
  subword-mode: t
  save-place-mode: t
  show-paren-mode: t
  global-hi-lock-mode: t
  hi-lock-mode: t
  engine-mode: t
  delete-selection-mode: t
  display-battery-mode: t
  override-global-mode: t
  blc-dropbox-mode: t
  blc-rainbow-mode: t
  tooltip-mode: t
  global-eldoc-mode: t
  eldoc-mode: t
  electric-indent-mode: t
  mouse-wheel-mode: t
  tool-bar-mode: t
  menu-bar-mode: t
  file-name-shadow-mode: t
  global-font-lock-mode: t
  font-lock-mode: t
  window-divider-mode: t
  auto-composition-mode: t
  auto-encryption-mode: t
  auto-compression-mode: t
  column-number-mode: t
  line-number-mode: t
  transient-mark-mode: t
  auto-save-visited-mode: t

Features:
(shadow sort footnote face-remap mail-extr gnus-msg gnus-art
mm-uu mml2015 mm-view mml-smime smime dig mailcap gnus-sum
gnus-group gnus-undo gnus-start gnus-cloud nnimap nnmail
mail-source tls gnutls utf7 netrc nnoo parse-time gnus-spec
gnus-int gnus-range gnus-win gnus nnheader emacsbug
eudcb-bbdb bbdb-com crm bbdb bbdb-site timezone eudc
eudc-options-file cus-edit eudc-vars wid-edit message rmc
puny git-annex dired-x dired dired-loaddefs format-spec
rfc822 mml mml-sec epa derived epg gnus-util rmail
rmail-loaddefs xdg mm-decode mm-bodies mm-encode mail-parse
rfc2231 mailabbrev gmm-utils mailheader sendmail rfc2047
rfc2045 ietf-drums mm-util mail-prsvr mail-utils ace-window
avy cl-print debug shell pcomplete comint ansi-color
cus-start cus-load colir color counsel jka-compr esh-util
etags xref project swiper ivy flx ivy-overlay ffap thingatpt
server bug-reference fic-mode fill-column-indicator
paren-face elec-pair xt-mouse winner ring disp-table
whitespace time cap-words superword subword saveplace paren
ibuf-macs highlight-escape-sequences hi-lock time-date
engine-mode delsel battery edmacro kmacro cl-extra help-mode
delight advice zenburn-theme browse-url use-package diminish
bind-key finder-inf tex-site info package easymenu
epg-config url-handlers url-parse auth-source cl-seq eieio
eieio-core cl-macs eieio-loaddefs password-cache url-vars
blc-macs blc-lib easy-mmode rx pcase thunk subr-x map seq
byte-opt gv bytecomp byte-compile cconv cl-loaddefs cl-lib
realpath mule-util tooltip eldoc electric uniquify
ediff-hook vc-hooks lisp-float-type mwheel term/x-win x-win
term/common-win x-dnd tool-bar dnd fontset image regexp-opt
fringe tabulated-list replace newcomment text-mode
elisp-mode lisp-mode prog-mode register page menu-bar
rfn-eshadow isearch timer select scroll-bar mouse jit-lock
font-lock syntax facemenu font-core term/tty-colors frame
cl-generic cham georgian utf-8-lang misc-lang vietnamese
tibetan thai tai-viet lao korean japanese eucjp-ms cp51932
hebrew greek romanian slovak czech european ethiopic indian
cyrillic chinese composite charscript charprop case-table
epa-hook jka-cmpr-hook help simple abbrev obarray minibuffer
cl-preloaded nadvice loaddefs button faces cus-face macroexp
files text-properties overlay sha1 md5 base64 format env
code-pages mule custom widget hashtable-print-readable
backquote dbusbind inotify lcms2 dynamic-setting
system-font-setting font-render-setting x-toolkit x
multi-tty make-network-process emacs)

Memory information:
((conses 16 359441 89175)
 (symbols 48 41275 27)
 (miscs 40 1373 2435)
 (strings 32 101726 9595)
 (string-bytes 1 3144509)
 (vectors 16 36288)
 (vector-slots 8 830885 84664)
 (floats 8 420 172)
 (intervals 56 1018 82)
 (buffers 992 17))

Thanks,

-- 
Basil