Lars-Johan Liman <li...@liman.se> writes:
> Lol!
>
> Thanks. OK, so I wasn't off the mark, then. :-)
>
> I'm not even sure this needs to be fixed. It's good that the fact that
> the server couldn't be reached is signalled, but continuing seems like
> the right thing to do. The message is somewhat misleading though. How
> about changing the "question" to a "Please ack!" of some kind?
Looking over the code, I'm inclined to agree with Lars-Johan here: there
isn't really any need to halt the process, what's important is that the
user be made aware of the failure. I'm trying to imagine why the user
would _need_ to halt things here. Unless we've got some sort of restart
situation, where the user can eg put in the correct password and try
again, it doesn't seem useful.
Allow me to re-introduce my suggestion of using warnings! It's looking
better and better the more I consider it. `delay-warning' is just what
we want: it puts messages in the hopper, which aren't displayed until
the current command is completely finished, instead of messages
clobbering each other and getting buried. It has its own private buffer,
keeping information separate. There are plenty of user-facing knobs, and
facilities for hiding or silencing the warnings.
See attached!
diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el
index 606bd3a39a..3c1387b73f 100644
--- a/lisp/gnus/gnus-start.el
+++ b/lisp/gnus/gnus-start.el
@@ -45,6 +45,14 @@ gnus-agent-file-loading-local
(defvar gnus-agent-file-loading-cache)
(defvar gnus-topic-alist)
+(define-error 'gnus-error "Gnus error")
+(define-error 'gnus-mail-source-error
+ "Gnus mail source error" 'gnus-error)
+(define-error 'gnus-server-error
+ "Gnus server error" 'gnus-error)
+(define-error 'gnus-server-connection-error
+ "Error connecting to server" 'gnus-server-error)
+
(defcustom gnus-startup-file (nnheader-concat gnus-home-directory ".newsrc")
"Your `.newsrc' file.
`.newsrc-SERVER' will be used instead if that exists."
@@ -1604,7 +1612,8 @@ gnus-get-unread-articles
(gnus-agent-article-local-times 0)
(archive-method (gnus-server-to-method "archive"))
info group active method cmethod
- method-type method-group-list entry)
+ method-type method-group-list entry
+ failed-methods)
(gnus-message 6 "Checking new news...")
(while newsrc
@@ -1685,8 +1694,11 @@ gnus-get-unread-articles
gnus-secondary-select-methods))
(when (and (not (assoc method type-cache))
(gnus-check-backend-function 'request-list (car method)))
- (with-current-buffer nntp-server-buffer
- (gnus-read-active-file-1 method nil)))))
+ (condition-case-unless-debug err
+ (with-current-buffer nntp-server-buffer
+ (gnus-read-active-file-1 method nil))
+ (gnus-server-connection-error
+ (push (cons method err) failed-methods))))))
;; Clear out all the early methods.
(dolist (elem type-cache)
@@ -1697,11 +1709,15 @@ gnus-get-unread-articles
'retrieve-group-data-early (car method))
(not (gnus-method-denied-p method)))
(when (ignore-errors (gnus-get-function method 'open-server))
- (unless (gnus-server-opened method)
- (gnus-open-server method))
- (when (gnus-server-opened method)
- ;; Just mark this server as "cleared".
- (gnus-retrieve-group-data-early method nil))))))
+ (condition-case-unless-debug err
+ (progn
+ (unless (gnus-server-opened method)
+ (gnus-open-server method))
+ ;; Just mark this server as "cleared".
+ (gnus-retrieve-group-data-early method nil))
+ (gnus-server-connection-error
+ (push (cons method err) failed-methods)
+ (setq type-cache (delq elem type-cache))))))))
;; Start early async retrieval of data.
(let ((done-methods nil)
@@ -1725,7 +1741,6 @@ gnus-get-unread-articles
;; be unique at this point, but apparently it
;; does happen in the wild with some setups.
(not (member sanity-spec done-methods))
- (gnus-server-opened method)
(gnus-check-backend-function
'retrieve-group-data-early (car method)))
(push sanity-spec done-methods)
@@ -1744,12 +1759,23 @@ gnus-get-unread-articles
(let ((updatep (gnus-check-backend-function
'request-update-info (car method))))
;; See if any of the groups from this method require updating.
- (gnus-read-active-for-groups method infos early-data)
- (dolist (info infos)
- (inline (gnus-get-unread-articles-in-group
- info (gnus-active (gnus-info-group info))
- updatep)))))))
- (gnus-message 6 "Checking new news...done")))
+ (condition-case-unless-debug err
+ (progn
+ (gnus-read-active-for-groups method infos early-data)
+ (dolist (info infos)
+ (inline (gnus-get-unread-articles-in-group
+ info (gnus-active (gnus-info-group info))
+ updatep))))
+ ((gnus-server-connection-error gnus-mail-source-error)
+ (push (cons method err) failed-methods)))))))
+ (gnus-message 6 "Checking new news...done")
+ (when failed-methods
+ (let ((warning-series t))
+ (dolist (m failed-methods)
+ (delay-warning
+ '(gnus)
+ (format "Failed to open %s: %S" (car m) (cdr m))
+ :error "*Gnus Warnings*"))))))
(defun gnus-method-rank (type method)
(cond
diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el
index af0a198376..2515a4261a 100644
--- a/lisp/gnus/mail-source.el
+++ b/lisp/gnus/mail-source.el
@@ -549,13 +549,10 @@ mail-source-fetch
callback mail-source-crash-box))
(mail-source-delete-crash-box))
(+ found
- (if (or debug-on-quit debug-on-error)
+ (condition-case-unless-debug err
(funcall function source callback)
- (condition-case err
- (funcall function source callback)
- (error
- (if (and (not mail-source-ignore-errors)
- (not
+ (error
+ (unless (or mail-source-ignore-errors
(yes-or-no-p
(format "Mail source %s error (%s). Continue? "
(if (memq ':password source)
@@ -563,10 +560,10 @@ mail-source-fetch
(setcar (cdr (memq ':password s))
"********")
s)
- source)
- (cadr err)))))
- (error "Cannot get new mail"))
- 0)))))))))
+ source)
+ (cadr err))))
+ (signal 'gnus-mail-source-error (list source err)))
+ 0))))))))
(declare-function gnus-message "gnus-util" (level &rest args))
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el
index 8a2acf6459..3305b6edd2 100644
--- a/lisp/gnus/nnimap.el
+++ b/lisp/gnus/nnimap.el
@@ -456,9 +456,7 @@ nnimap-open-connection
while (eq stream 'no-connect)
finally (return stream))
(nnimap-open-connection-1 buffer))))
- (if (eq stream 'no-connect)
- nil
- stream)))
+ stream))
;; This is only needed for Windows XP or earlier
(defun nnimap-map-port (port)
@@ -534,7 +532,8 @@ nnimap-open-connection-1
(progn
(nnheader-report 'nnimap "Unable to contact %s:%s via %s"
nnimap-address (car ports) nnimap-stream)
- 'no-connect)
+ (signal 'gnus-server-connection-error
+ (list nnimap-object)))
(set-process-query-on-exit-flag stream nil)
(if (not (string-match-p "[*.] \\(OK\\|PREAUTH\\)" greeting))
(nnheader-report 'nnimap "%s" greeting)
diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el
index bcf01cfa9e..1a9258273c 100644
--- a/lisp/gnus/nnmail.el
+++ b/lisp/gnus/nnmail.el
@@ -1825,25 +1825,22 @@ nnmail-get-new-mail-1
;; and fetch the mail from each.
(while (setq source (pop fetching-sources))
(when (setq new
- (condition-case cond
- (mail-source-fetch
- source
- (let ((smsym (intern (format "%s-save-mail" method)))
+ (or (mail-source-fetch
+ source
+ (let ((smsym (intern (format "%s-save-mail" method)))
(ansym (intern (format "%s-active-number" method)))
(src source))
- (lambda (file orig-file)
+ (lambda (file orig-file)
(nnmail-split-incoming
file smsym
spool-func
(or in-group
- (if (equal file orig-file)
+ (if (equal file orig-file)
nil
(nnmail-get-split-group orig-file
src)))
ansym))))
- ((error quit)
- (message "Mail source %s failed: %s" source cond)
- 0)))
+ 0))
(cl-incf total new)
(cl-incf i)))
;; If we did indeed read any incoming spools, we save all info.
diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el
index 690761a2d6..8d2b8d4cef 100644
--- a/lisp/gnus/nnmaildir.el
+++ b/lisp/gnus/nnmaildir.el
@@ -670,63 +670,65 @@ nnmaildir-open-server
(let ((server (alist-get server-string nnmaildir--servers
nil nil #'equal))
dir size x)
- (catch 'return
- (if server
- (and (nnmaildir--srv-groups server)
- (setq nnmaildir--cur-server server)
- (throw 'return t))
- (setq server (make-nnmaildir--srv :address server-string))
- (let ((inhibit-quit t))
- (setf (alist-get server-string nnmaildir--servers
- nil nil #'equal)
- server)))
- (setq dir (assq 'directory defs))
- (unless dir
- (setf (nnmaildir--srv-error server)
- "You must set \"directory\" in the select method")
- (throw 'return nil))
- (setq dir (cadr dir)
- dir (eval dir t) ;FIXME: Why `eval'?
- dir (expand-file-name dir)
- dir (file-name-as-directory dir))
- (unless (file-exists-p dir)
- (setf (nnmaildir--srv-error server) (concat "No such directory: " dir))
- (throw 'return nil))
- (setf (nnmaildir--srv-dir server) dir)
- (setq x (assq 'directory-files defs))
- (if (null x)
- (setq x (if nnheader-directory-files-is-safe 'directory-files
- 'nnheader-directory-files-safe))
- (setq x (cadr x))
- (unless (functionp x)
- (setf (nnmaildir--srv-error server)
- (concat "Not a function: " (prin1-to-string x)))
- (throw 'return nil)))
- (setf (nnmaildir--srv-ls server) x)
- (setq size (length (funcall x dir nil "\\`[^.]" 'nosort)))
- (and (setq x (assq 'get-new-mail defs))
- (setq x (cdr x))
- (car x)
- (setf (nnmaildir--srv-gnm server) t)
- (require 'nnmail))
- (setq x (assq 'target-prefix defs))
- (if x
- (progn
- (setq x (cadr x)
- x (eval x t)) ;FIXME: Why `eval'?
- (setf (nnmaildir--srv-target-prefix server) x))
- (setq x (assq 'create-directory defs))
- (if x
- (progn
- (setq x (cadr x)
- x (eval x t) ;FIXME: Why `eval'?
- x (file-name-as-directory x))
- (setf (nnmaildir--srv-target-prefix server) x))
- (setf (nnmaildir--srv-target-prefix server) "")))
- (setf (nnmaildir--srv-groups server)
- (gnus-make-hashtable size))
- (setq nnmaildir--cur-server server)
- t)))
+ (unless
+ (catch 'return
+ (if server
+ (and (nnmaildir--srv-groups server)
+ (setq nnmaildir--cur-server server)
+ (throw 'return t))
+ (setq server (make-nnmaildir--srv :address server-string))
+ (let ((inhibit-quit t))
+ (setf (alist-get server-string nnmaildir--servers
+ nil nil #'equal)
+ server)))
+ (setq dir (assq 'directory defs))
+ (unless dir
+ (setf (nnmaildir--srv-error server)
+ "You must set \"directory\" in the select method")
+ (throw 'return nil))
+ (setq dir (cadr dir)
+ dir (eval dir t) ;FIXME: Why `eval'?
+ dir (expand-file-name dir)
+ dir (file-name-as-directory dir))
+ (unless (file-exists-p dir)
+ (setf (nnmaildir--srv-error server) (concat "No such directory: " dir))
+ (throw 'return nil))
+ (setf (nnmaildir--srv-dir server) dir)
+ (setq x (assq 'directory-files defs))
+ (if (null x)
+ (setq x (if nnheader-directory-files-is-safe 'directory-files
+ 'nnheader-directory-files-safe))
+ (setq x (cadr x))
+ (unless (functionp x)
+ (setf (nnmaildir--srv-error server)
+ (concat "Not a function: " (prin1-to-string x)))
+ (throw 'return nil)))
+ (setf (nnmaildir--srv-ls server) x)
+ (setq size (length (funcall x dir nil "\\`[^.]" 'nosort)))
+ (and (setq x (assq 'get-new-mail defs))
+ (setq x (cdr x))
+ (car x)
+ (setf (nnmaildir--srv-gnm server) t)
+ (require 'nnmail))
+ (setq x (assq 'target-prefix defs))
+ (if x
+ (progn
+ (setq x (cadr x)
+ x (eval x t)) ;FIXME: Why `eval'?
+ (setf (nnmaildir--srv-target-prefix server) x))
+ (setq x (assq 'create-directory defs))
+ (if x
+ (progn
+ (setq x (cadr x)
+ x (eval x t) ;FIXME: Why `eval'?
+ x (file-name-as-directory x))
+ (setf (nnmaildir--srv-target-prefix server) x))
+ (setf (nnmaildir--srv-target-prefix server) "")))
+ (setf (nnmaildir--srv-groups server)
+ (gnus-make-hashtable size))
+ (setq nnmaildir--cur-server server)
+ t)
+ (signal 'gnus-server-connection-error (list server)))))
(defun nnmaildir--parse-filename (file)
(let ((prefix (car file))
diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el
index 18acc73aad..98cbe79e8b 100644
--- a/lisp/gnus/nnml.el
+++ b/lisp/gnus/nnml.el
@@ -163,17 +163,18 @@ nnml-open-server
(nnoo-change-server 'nnml server defs)
(when (not (file-exists-p nnml-directory))
(ignore-errors (make-directory nnml-directory t)))
- (cond
- ((not (file-exists-p nnml-directory))
- (nnml-close-server)
- (nnheader-report 'nnml "Couldn't create directory: %s" nnml-directory))
- ((not (file-directory-p (file-truename nnml-directory)))
- (nnml-close-server)
- (nnheader-report 'nnml "Not a directory: %s" nnml-directory))
- (t
- (nnheader-report 'nnml "Opened server %s using directory %s"
- server nnml-directory)
- t)))
+ (let (msg)
+ (if (or (and (not (file-exists-p nnml-directory))
+ (setq msg "Couldn't create directory: %s"))
+ (and (not (file-directory-p (file-truename nnml-directory)))
+ (setq msg "Not a directory: %s")))
+ (progn
+ (nnml-close-server)
+ (nnheader-report 'nnml msg nnml-directory)
+ (signal 'gnus-server-connection-error (list server)))
+ (nnheader-report 'nnml "Opened server %s using directory %s"
+ server nnml-directory)
+ t)))
(deffoo nnml-request-regenerate (server)
(nnml-possibly-change-directory nil server)
diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el
index 615a3c931b..2f8b271c55 100644
--- a/lisp/gnus/nntp.el
+++ b/lisp/gnus/nntp.el
@@ -1296,7 +1296,8 @@ nntp-open-connection
(goto-char (point-min))
(nnheader-report 'nntp "Error when connecting: %s"
(buffer-substring (point) (line-end-position))))
- (setq process nil))
+ (setq process nil)
+ (signal 'gnus-server-connection-error (list nntp-address)))
(unless process
(nntp-kill-buffer pbuffer))
(when (and (buffer-live-p pbuffer)
