branch: elpa/vm
commit 5cc5cfa59c7930bf1b138bb938132d1c79cbbe9f
Author: Mark Diekhans <[email protected]>
Commit: Mark Diekhans <[email protected]>
Fix "Blocking call to accept-process-output with quit inhibited" warning
Add vm-accept-process-output in vm-misc.el that binds inhibit-quit to
nil, allowing user interrupts during process I/O and avoiding the
Emacs 27+ warning about blocking calls with quit inhibited.
- vm-misc.el: Add generic vm-accept-process-output with optional timeout
- vm-imap.el: Add vm-imap-accept-process-output wrapper with IMAP timeout
and error handling, update all call sites
- vm-pop.el: Replace direct accept-process-output calls
- vm-crypto.el, vm-save.el: Use vm-accept-process-output
Fixes vm#320
---
lisp/vm-crypto.el | 2 +-
lisp/vm-imap.el | 37 ++++++++++---------------------------
lisp/vm-misc.el | 8 ++++++++
lisp/vm-pop.el | 10 +++++-----
lisp/vm-save.el | 4 ++--
5 files changed, 26 insertions(+), 35 deletions(-)
diff --git a/lisp/vm-crypto.el b/lisp/vm-crypto.el
index 2aa46b7de1..4823f7f89a 100644
--- a/lisp/vm-crypto.el
+++ b/lisp/vm-crypto.el
@@ -148,7 +148,7 @@
;; wait for some output from vm-ssh-remote-command. this
;; ensures that when we return the ssh connection is ready to
;; do port-forwarding.
- (accept-process-output process)
+ (vm-accept-process-output process)
local-port ))
diff --git a/lisp/vm-imap.el b/lisp/vm-imap.el
index 96c00bcfad..5ad9b2c54b 100644
--- a/lisp/vm-imap.el
+++ b/lisp/vm-imap.el
@@ -458,25 +458,13 @@ for accessing MAILBOX."
(defsubst vm-imap-auth-method (auth)
(memq auth vm-imap-auth-methods))
-(defsubst vm-accept-process-output (process)
- "Accept output from PROCESS.
-
+(defun vm-imap-accept-process-output (process)
+ "Accept output from PROCESS for IMAP operations.
The variable `vm-imap-server-timeout' specifies how many seconds
-to wait before timing out. If a timeout occurs, an exception is
-thrown. In such a situation, typically VM cannot proceed."
- ;; protect against possible buffer change due to bug in Emacs
- (let ((buf (current-buffer))
- (got-output (accept-process-output process vm-imap-server-timeout)))
- (if got-output
- (when (not (equal (current-buffer) buf))
- (when (string-lessp "24" emacs-version)
- ;; the Emacs bug should have been fixed in version 24
- (vm-warn 0 2
- "Emacs process output error: Buffer changed to %s"
- (current-buffer)))
- ;; recover from the bug
- (set-buffer buf))
- (vm-imap-protocol-error "Timed out for response from the IMAP server"))))
+to wait before timing out. If a timeout occurs, a protocol error
+is signaled."
+ (unless (vm-accept-process-output process vm-imap-server-timeout)
+ (vm-imap-protocol-error "Timed out for response from the IMAP server")))
;; (defvar vm-imap-connection-mode 'online) ; moved to vm-vars.el
@@ -1549,11 +1537,6 @@ as well."
(if (not (= (point) (point-max)))
(vm-imap-log-tokens (list 'send1 (point) (point-max))))
(goto-char (point-max))
- ;; try if it makes a difference to get pending output here, use timeout
- ;; (accept-process-output process 0 0.01)
- ;; (if (not (= (point) (point-max)))
- ;; (vm-imap-log-tokens (list 'send2 (point) (point-max))))
- ;; (goto-char (point-max))
(unless no-tag (insert-before-markers (or tag "VM") " "))
(let ((case-fold-search t))
@@ -2312,7 +2295,7 @@ May throw exceptions."
(setq opoint (point))
(vm-imap-check-connection process)
;; point might change here?
- (vm-accept-process-output process)
+ (vm-imap-accept-process-output process)
(goto-char opoint))
((looking-at "\r\n")
(forward-char 2)
@@ -2381,7 +2364,7 @@ May throw exceptions."
(while (< (- (point-max) start) n-octets)
(vm-imap-check-connection process)
;; point might change here? USR, 2011-03-16
- (vm-accept-process-output process))
+ (vm-imap-accept-process-output process))
(goto-char (+ start n-octets))
(setq token (list 'string start (point))
done t)))
@@ -2401,7 +2384,7 @@ May throw exceptions."
(forward-char 1))
(vm-imap-check-connection process)
;; point might change here?
- (vm-accept-process-output process)
+ (vm-imap-accept-process-output process)
(goto-char curpoint))
(setq token (list 'string start curpoint)))))
;; should be (looking-at "[\000-\040\177-\377]")
@@ -2430,7 +2413,7 @@ May throw exceptions."
(setq done t)
(vm-imap-check-connection process)
;; point might change here?
- (vm-accept-process-output process)
+ (vm-imap-accept-process-output process)
(goto-char curpoint))
(vm-imap-log-token (buffer-substring start curpoint))
(setq token (list 'atom start curpoint)))))))
diff --git a/lisp/vm-misc.el b/lisp/vm-misc.el
index 1823a9c50f..b4ff1d7ea2 100644
--- a/lisp/vm-misc.el
+++ b/lisp/vm-misc.el
@@ -89,6 +89,14 @@ message."
(defsubst vm-garbage-collect ()
(pp (vm-zip-lists gc-fields (garbage-collect))))
+(defun vm-accept-process-output (process &optional timeout)
+ "Accept output from PROCESS, optionally with TIMEOUT seconds.
+Binds `inhibit-quit' to nil to allow user interrupts and avoid
+the \"Blocking call to accept-process-output with quit inhibited\" warning.
+Returns non-nil if output was received, nil on timeout."
+ (let ((inhibit-quit nil))
+ (accept-process-output process timeout)))
+
;; Make sure that interprogram-cut-function is defined
(unless (boundp 'interprogram-cut-function)
(defvar interprogram-cut-function nil))
diff --git a/lisp/vm-pop.el b/lisp/vm-pop.el
index 50a4bb713b..4053254eb7 100644
--- a/lisp/vm-pop.el
+++ b/lisp/vm-pop.el
@@ -792,7 +792,7 @@ killed as well."
(goto-char vm-pop-read-point)
(while (not (search-forward "\r\n" nil t))
(vm-pop-check-connection process)
- (accept-process-output process)
+ (vm-accept-process-output process)
(goto-char vm-pop-read-point))
(setq match-end (point))
(goto-char vm-pop-read-point)
@@ -812,7 +812,7 @@ killed as well."
;; save-excursion doesn't work right
(let ((opoint (point)))
(vm-pop-check-connection process)
- (accept-process-output process)
+ (vm-accept-process-output process)
(goto-char opoint)))
(setq vm-pop-read-point (point))))
@@ -841,7 +841,7 @@ killed as well."
;; save-excursion doesn't work right
(let ((opoint (point)))
(vm-pop-check-connection process)
- (accept-process-output process)
+ (vm-accept-process-output process)
(goto-char opoint)))
(setq vm-pop-read-point (point-marker))
(goto-char start)
@@ -946,7 +946,7 @@ popdrop
(vm-pop-report-retrieval-status statblob)))))))
(after-change-functions (cons func after-change-functions)))
(vm-pop-check-connection process)
- (accept-process-output process)
+ (vm-accept-process-output process)
(goto-char opoint)))
(vm-set-pop-stat-x-need statblob nil)
(setq vm-pop-read-point (point-marker))
@@ -1050,7 +1050,7 @@ popdrop
;; save-excursion doesn't work right
(let ((opoint (point)))
(vm-pop-check-connection process)
- (accept-process-output process)
+ (vm-accept-process-output process)
(goto-char opoint)))
(setq vm-pop-read-point (point-marker))
(goto-char start)
diff --git a/lisp/vm-save.el b/lisp/vm-save.el
index 5fb7b40dce..05db7a4bb9 100644
--- a/lisp/vm-save.el
+++ b/lisp/vm-save.el
@@ -809,9 +809,9 @@ arguments after the command finished."
(process-send-eof process)
- (when (not no-wait)
+ (when (not no-wait)
(while (and (eq 'run (process-status process)))
- (accept-process-output process)
+ (vm-accept-process-output process)
(sit-for 0))
(vm-pipe-command-exit-handler process command discard-output))
buffer))
