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)