X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-start.el;h=96f60556ea183e8ac6977cdd8fcb6a11abc2e838;hp=a349475dbf5c64356f95fe085d2969916c684f47;hb=1c4e3c3a0fa8a01ce010dcaad75b26b0e0f8e3e2;hpb=344d90c95e1451fd3fbc070f2e2fd7eeefabb2c1 diff --git a/lisp/gnus-start.el b/lisp/gnus-start.el index a349475db..0c0246a4e 100644 --- a/lisp/gnus-start.el +++ b/lisp/gnus-start.el @@ -1,7 +1,6 @@ ;;; gnus-start.el --- startup functions for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1996-2015 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -31,6 +30,7 @@ (require 'gnus-spec) (require 'gnus-range) (require 'gnus-util) +(require 'gnus-cloud) (autoload 'message-make-date "message") (autoload 'gnus-agent-read-servers-validate "gnus-agent") (autoload 'gnus-agent-save-local "gnus-agent") @@ -86,14 +86,6 @@ If a file with the `.el' or `.elc' suffixes exists, it will be read instead." :group 'gnus-start :type '(choice file (const nil))) -(defcustom gnus-default-subscribed-newsgroups nil - "List of newsgroups to subscribe, when a user runs Gnus the first time. -The value should be a list of strings. -If it is t, Gnus will not do anything special the first time it is -started; it'll just use the normal newsgroups subscription methods." - :group 'gnus-start - :type '(choice (repeat string) (const :tag "Nothing special" t))) - (defcustom gnus-use-dribble-file t "*Non-nil means that Gnus will use a dribble file to store user updates. If Emacs should crash without saving the .newsrc files, complete @@ -119,7 +111,7 @@ ask the servers (primary, secondary, and archive servers) to list new groups since the last time it checked: 1. This variable is `ask-server'. 2. This variable is a list of select methods (see below). - 3. `gnus-read-active-file' is nil or `some'. + 3. Option `gnus-read-active-file' is nil or `some'. 4. A prefix argument is given to `gnus-find-new-newsgroups' interactively. Thus, if this variable is `ask-server' or a list of select methods or @@ -130,7 +122,7 @@ This variable can be a list of select methods which Gnus will query with the `ask-server' method in addition to the primary, secondary, and archive servers. -Eg. +E.g.: (setq gnus-check-new-newsgroups '((nntp \"some.server\") (nntp \"other.server\"))) @@ -268,7 +260,7 @@ not match this regexp will be removed before saving the list." (mapconcat 'identity '("^to\\." ; not "real" groups "^[0-9. \t]+\\( \\|$\\)" ; all digits in name - "^[\"][]\"[#'()]" ; bogus characters + "^[\"][\"#'()]" ; bogus characters ) "\\|") "*A regexp to match uninteresting newsgroups in the active file. @@ -300,7 +292,9 @@ claim them." function (repeat function))) -(defcustom gnus-subscribe-newsgroup-hooks nil +(define-obsolete-variable-alias 'gnus-subscribe-newsgroup-hooks + 'gnus-subscribe-newsgroup-functions "24.3") +(defcustom gnus-subscribe-newsgroup-functions nil "*Hooks run after you subscribe to a new group. The hooks will be called with new group's name as argument." :version "22.1" @@ -341,8 +335,17 @@ hierarchy in its entirety." :group 'gnus-group-new :type 'boolean) +(defcustom gnus-auto-subscribed-categories '(mail post-mail) + "*New groups from methods of these categories will be subscribed automatically. +Note that this variable only deals with new groups. It has no +effect whatsoever on old groups. The default is to automatically +subscribe all groups from mail-like backends." + :version "24.1" + :group 'gnus-group-new + :type '(repeat symbol)) + (defcustom gnus-auto-subscribed-groups - "^nnml\\|^nnfolder\\|^nnmbox\\|^nnmh\\|^nnbabyl\\|^nnmaildir" + "^nnml\\|^nnfolder\\|^nnmbox\\|^nnmh\\|^nnbabyl\\|^nnmaildir\\|^nnimap" "*All new groups that match this regexp will be subscribed automatically. Note that this variable only deals with new groups. It has no effect whatsoever on old groups. @@ -393,7 +396,16 @@ This hook is called after Gnus is connected to the NNTP server." (defcustom gnus-before-startup-hook nil "A hook called before startup. -This hook is called as the first thing when Gnus is started." +This hook is called as the first thing when Gnus is started. +See also `gnus-before-resume-hook'." + :group 'gnus-start + :type 'hook) + +(defcustom gnus-before-resume-hook nil + "A hook called before resuming Gnus after suspend. +This hook is called as the first thing when Gnus is resumed after a suspend. +See also `gnus-before-startup-hook'." + :version "24.4" :group 'gnus-start :type 'hook) @@ -402,8 +414,7 @@ This hook is called as the first thing when Gnus is started." :group 'gnus-start :type 'hook) -(defcustom gnus-setup-news-hook - '(gnus-fixup-nnimap-unread-after-getting-new-news) +(defcustom gnus-setup-news-hook nil "A hook after reading the .newsrc file, but before generating the buffer." :group 'gnus-start :type 'hook) @@ -420,9 +431,9 @@ This hook is called as the first thing when Gnus is started." :type 'hook) (defcustom gnus-after-getting-new-news-hook - '(gnus-display-time-event-handler - gnus-fixup-nnimap-unread-after-getting-new-news) + '(gnus-display-time-event-handler) "*A hook run after Gnus checks for new news when Gnus is already running." + :version "24.1" :group 'gnus-group-new :type 'hook) @@ -594,8 +605,7 @@ Can be used to turn version control on or off." (defun gnus-subscribe-hierarchically (newgroup) "Subscribe new NEWGROUP and insert it in hierarchical newsgroup order." ;; Basic ideas by mike-w@cs.aukuni.ac.nz (Mike Williams) - (save-excursion - (set-buffer (nnheader-find-file-noselect gnus-current-startup-file)) + (with-current-buffer (nnheader-find-file-noselect gnus-current-startup-file) (prog1 (let ((groupkey newgroup) before) (while (and (not before) groupkey) @@ -639,8 +649,9 @@ the first newsgroup." (gnus-group-change-level newsgroup gnus-level-default-subscribed gnus-level-killed (gnus-group-entry (or next "dummy.group"))) + (gnus-request-update-group-status newsgroup 'subscribe) (gnus-message 5 "Subscribe newsgroup: %s" newsgroup) - (run-hook-with-args 'gnus-subscribe-newsgroup-hooks newsgroup) + (run-hook-with-args 'gnus-subscribe-newsgroup-functions newsgroup) t)) (defun gnus-read-active-file-p () @@ -706,6 +717,7 @@ the first newsgroup." nnoo-state-alist nil gnus-current-select-method nil nnmail-split-history nil + gnus-extended-servers nil gnus-ephemeral-servers nil) (gnus-shutdown 'gnus) ;; Kill the startup file. @@ -747,6 +759,7 @@ prompt the user for the name of an NNTP server to use." (if (gnus-alive-p) (progn + (gnus-run-hooks 'gnus-before-resume-hook) (switch-to-buffer gnus-group-buffer) (gnus-group-get-new-news (and (numberp arg) @@ -763,20 +776,12 @@ prompt the user for the name of an NNTP server to use." ;; Add "native" to gnus-predefined-server-alist just to have a ;; name for the native select method. (when gnus-select-method - (push (cons "native" gnus-select-method) - gnus-predefined-server-alist)) + (add-to-list 'gnus-predefined-server-alist + (cons "native" gnus-select-method))) (if gnus-agent (gnus-agentize)) - (when gnus-simple-splash - (setq gnus-simple-splash nil) - (cond - ((featurep 'xemacs) - (gnus-xmas-splash)) - (window-system - (gnus-x-splash)))) - (let ((level (and (numberp arg) (> arg 0) arg)) did-connect) (unwind-protect @@ -786,10 +791,9 @@ prompt the user for the name of an NNTP server to use." (gnus-start-news-server (and arg (not level)))))) (if (and (not dont-connect) (not did-connect)) + ;; Couldn't connect to the server, so bail out. (gnus-group-quit) (gnus-run-hooks 'gnus-startup-hook) - ;; NNTP server is successfully open. - ;; Find the current startup file name. (setq gnus-current-startup-file (gnus-make-newsrc-file gnus-startup-file)) @@ -799,11 +803,10 @@ prompt the user for the name of an NNTP server to use." (gnus-dribble-read-file)) ;; Do the actual startup. - (if gnus-agent - (gnus-request-create-group "queue" '(nndraft ""))) - (gnus-request-create-group "drafts" '(nndraft "")) (gnus-setup-news nil level dont-connect) (gnus-run-hooks 'gnus-setup-news-hook) + (when gnus-agent + (gnus-request-create-group "queue" '(nndraft ""))) (gnus-start-draft-setup) ;; Generate the group buffer. (gnus-group-list-groups level) @@ -818,10 +821,10 @@ prompt the user for the name of an NNTP server to use." (gnus-request-create-group "drafts" '(nndraft "")) (unless (gnus-group-entry "nndraft:drafts") (let ((gnus-level-default-subscribed 1)) - (gnus-subscribe-group "nndraft:drafts" nil '(nndraft "")))) + (gnus-subscribe-group "nndraft:drafts" nil '(nndraft ""))) + (setcar (gnus-group-entry "nndraft:drafts") 0)) (unless (equal (gnus-group-get-parameter "nndraft:drafts" 'gnus-dummy t) '((gnus-draft-mode))) - (gnus-message 3 "Setting up drafts group") (gnus-group-set-parameter "nndraft:drafts" 'gnus-dummy '((gnus-draft-mode))))) @@ -842,13 +845,22 @@ prompt the user for the name of an NNTP server to use." gnus-current-startup-file) "-dribble")) -(defun gnus-dribble-enter (string) - "Enter STRING into the dribble buffer." +(defun gnus-dribble-enter (string &optional regexp) + "Enter STRING into the dribble buffer. +If REGEXP is given, lines that match it will be deleted." (when (and (not gnus-dribble-ignore) gnus-dribble-buffer (buffer-name gnus-dribble-buffer)) (let ((obuf (current-buffer))) (set-buffer gnus-dribble-buffer) + (when regexp + (goto-char (point-min)) + (let (end) + (while (re-search-forward regexp nil t) + (unless (bolp) (forward-line 1)) + (setq end (point)) + (goto-char (match-beginning 0)) + (delete-region (point-at-bol) end)))) (goto-char (point-max)) (insert string "\n") ;; This has been commented by Josh Huber @@ -857,8 +869,7 @@ prompt the user for the name of an NNTP server to use." ;; it's not needed). ;; (set-window-point (get-buffer-window (current-buffer)) (point-max)) (bury-buffer gnus-dribble-buffer) - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (gnus-group-set-mode-line)) (set-buffer obuf)))) @@ -871,13 +882,18 @@ prompt the user for the name of an NNTP server to use." (let ((dribble-file (gnus-dribble-file-name))) (unless (file-exists-p (file-name-directory dribble-file)) (make-directory (file-name-directory dribble-file) t)) - (save-excursion - (set-buffer (setq gnus-dribble-buffer - (gnus-get-buffer-create - (file-name-nondirectory dribble-file)))) + (with-current-buffer (setq gnus-dribble-buffer + (gnus-get-buffer-create + (file-name-nondirectory dribble-file))) (set (make-local-variable 'file-precious-flag) t) + (setq buffer-save-without-query t) (erase-buffer) (setq buffer-file-name dribble-file) + ;; The buffer may be shrunk a lot when deleting old entries. + ;; It caused the auto-saving to stop. + (if (featurep 'emacs) + (set (make-local-variable 'auto-save-include-big-deletions) t) + (set (make-local-variable 'disable-auto-save-when-buffer-shrinks) nil)) (auto-save-mode t) (buffer-disable-undo) (bury-buffer (current-buffer)) @@ -923,8 +939,7 @@ prompt the user for the name of an NNTP server to use." (when (file-exists-p (gnus-dribble-file-name)) (delete-file (gnus-dribble-file-name))) (when gnus-dribble-buffer - (save-excursion - (set-buffer gnus-dribble-buffer) + (with-current-buffer gnus-dribble-buffer (let ((auto (make-auto-save-file-name))) (when (file-exists-p auto) (delete-file auto)) @@ -934,14 +949,13 @@ prompt the user for the name of an NNTP server to use." (defun gnus-dribble-save () (when (and gnus-dribble-buffer (buffer-name gnus-dribble-buffer)) - (save-excursion - (set-buffer gnus-dribble-buffer) - (save-buffer)))) + (with-current-buffer gnus-dribble-buffer + (when (> (buffer-size) 0) + (save-buffer))))) (defun gnus-dribble-clear () (when (gnus-buffer-exists-p gnus-dribble-buffer) - (save-excursion - (set-buffer gnus-dribble-buffer) + (with-current-buffer gnus-dribble-buffer (erase-buffer) (set-buffer-modified-p nil) (setq buffer-saved-size (buffer-size))))) @@ -1003,27 +1017,8 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." (when (or (null gnus-read-active-file) (eq gnus-read-active-file 'some)) (gnus-update-active-hashtb-from-killed)) - - ;; Validate agent covered methods now that gnus-server-alist has - ;; been initialized. - ;; NOTE: This is here for one purpose only. By validating the - ;; agentized server's, it converts the old 5.10.3, and earlier, - ;; format to the current format. That enables the agent code - ;; within gnus-read-active-file to function correctly. - (if gnus-agent - (gnus-agent-read-servers-validate)) - - ;; Read the active file and create `gnus-active-hashtb'. - ;; If `gnus-read-active-file' is nil, then we just create an empty - ;; hash table. The partial filling out of the hash table will be - ;; done in `gnus-get-unread-articles'. - (and gnus-read-active-file - (not level) - (gnus-read-active-file nil dont-connect)) - (unless gnus-active-hashtb (setq gnus-active-hashtb (gnus-make-hashtable 4096))) - ;; Initialize the cache. (when gnus-use-cache (gnus-cache-open)) @@ -1062,21 +1057,12 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." (gnus-server-opened gnus-select-method)) (gnus-check-bogus-newsgroups)) - ;; We might read in new NoCeM messages here. - (when (and (not dont-connect) - gnus-use-nocem - (or (and (numberp gnus-use-nocem) - (numberp level) - (>= level gnus-use-nocem)) - (not level))) - (gnus-nocem-scan-groups)) - ;; Read any slave files. (gnus-master-read-slave-newsrc) ;; Find the number of unread articles in each non-dead group. (let ((gnus-read-active-file (and (not level) gnus-read-active-file))) - (gnus-get-unread-articles level)))) + (gnus-get-unread-articles level dont-connect)))) (defun gnus-call-subscribe-functions (method group) "Call METHOD to subscribe GROUP. @@ -1116,53 +1102,53 @@ for new groups, and subscribe the new groups as zombies." 'gnus-subscribe-zombies) t) (t gnus-check-new-newsgroups)))) - (unless (gnus-check-first-time-used) - (if (or (consp check) - (eq check 'ask-server)) - ;; Ask the server for new groups. - (gnus-ask-server-for-new-groups) - ;; Go through the active hashtb and look for new groups. - (let ((groups 0) - group new-newsgroups) - (gnus-message 5 "Looking for new newsgroups...") - (unless gnus-have-read-active-file - (gnus-read-active-file)) - (setq gnus-newsrc-last-checked-date (message-make-date)) - (unless gnus-killed-hashtb - (gnus-make-hashtable-from-killed)) - ;; Go though every newsgroup in `gnus-active-hashtb' and compare - ;; with `gnus-newsrc-hashtb' and `gnus-killed-hashtb'. - (mapatoms - (lambda (sym) - (if (or (null (setq group (symbol-name sym))) - (not (boundp sym)) - (null (symbol-value sym)) - (gnus-gethash group gnus-killed-hashtb) - (gnus-gethash group gnus-newsrc-hashtb)) - () - (let ((do-sub (gnus-matches-options-n group))) - (cond - ((eq do-sub 'subscribe) - (setq groups (1+ groups)) - (gnus-sethash group group gnus-killed-hashtb) - (gnus-call-subscribe-functions - gnus-subscribe-options-newsgroup-method group)) - ((eq do-sub 'ignore) - nil) - (t - (setq groups (1+ groups)) - (gnus-sethash group group gnus-killed-hashtb) - (if gnus-subscribe-hierarchical-interactive - (push group new-newsgroups) - (gnus-call-subscribe-functions - gnus-subscribe-newsgroup-method group))))))) - gnus-active-hashtb) - (when new-newsgroups - (gnus-subscribe-hierarchical-interactive new-newsgroups)) - (if (> groups 0) - (gnus-message 5 "%d new newsgroup%s arrived." - groups (if (> groups 1) "s have" " has")) - (gnus-message 5 "No new newsgroups."))))))) + (if (or (consp check) + (eq check 'ask-server)) + ;; Ask the server for new groups. + (gnus-ask-server-for-new-groups) + ;; Go through the active hashtb and look for new groups. + (let ((groups 0) + group new-newsgroups) + (gnus-message 5 "Looking for new newsgroups...") + (unless gnus-have-read-active-file + (gnus-read-active-file)) + (setq gnus-newsrc-last-checked-date (message-make-date)) + (unless gnus-killed-hashtb + (gnus-make-hashtable-from-killed)) + ;; Go though every newsgroup in `gnus-active-hashtb' and compare + ;; with `gnus-newsrc-hashtb' and `gnus-killed-hashtb'. + (mapatoms + (lambda (sym) + (if (or (null (setq group (symbol-name sym))) + (not (boundp sym)) + (null (symbol-value sym)) + (gnus-gethash group gnus-killed-hashtb) + (gnus-gethash group gnus-newsrc-hashtb)) + () + (let ((do-sub (gnus-matches-options-n group))) + (cond + ((eq do-sub 'subscribe) + (setq groups (1+ groups)) + (gnus-sethash group group gnus-killed-hashtb) + (gnus-call-subscribe-functions + gnus-subscribe-options-newsgroup-method group)) + ((eq do-sub 'ignore) + nil) + (t + (setq groups (1+ groups)) + (gnus-sethash group group gnus-killed-hashtb) + (if gnus-subscribe-hierarchical-interactive + (push group new-newsgroups) + (gnus-call-subscribe-functions + gnus-subscribe-newsgroup-method group))))))) + gnus-active-hashtb) + (when new-newsgroups + (gnus-subscribe-hierarchical-interactive new-newsgroups)) + (if (> groups 0) + (gnus-message 5 "%d new newsgroup%s arrived." + groups (if (> groups 1) "s have" " has")) + (gnus-message 5 "No new newsgroups.")) + groups)))) (defun gnus-matches-options-n (group) ;; Returns `subscribe' if the group is to be unconditionally @@ -1174,6 +1160,12 @@ for new groups, and subscribe the new groups as zombies." ((and gnus-options-subscribe (string-match gnus-options-subscribe group)) 'subscribe) + ((let ((do-subscribe nil)) + (dolist (category gnus-auto-subscribed-categories) + (when (gnus-member-of-valid category group) + (setq do-subscribe t))) + do-subscribe) + 'subscribe) ((and gnus-auto-subscribed-groups (string-match gnus-auto-subscribed-groups group)) 'subscribe) @@ -1260,55 +1252,7 @@ for new groups, and subscribe the new groups as zombies." (gnus-message 5 "No new newsgroups")) (when got-new (setq gnus-newsrc-last-checked-date new-date)) - got-new)) - -(defun gnus-check-first-time-used () - (catch 'ended - ;; First check if any of the following files exist. If they do, - ;; it's not the first time the user has used Gnus. - (dolist (file (list (concat gnus-current-startup-file ".el") - (concat gnus-current-startup-file ".eld") - (concat gnus-startup-file ".el") - (concat gnus-startup-file ".eld"))) - (when (file-exists-p file) - (throw 'ended nil))) - (gnus-message 6 "First time user; subscribing you to default groups") - (unless (gnus-read-active-file-p) - (let ((gnus-read-active-file t)) - (gnus-read-active-file))) - (setq gnus-newsrc-last-checked-date (message-make-date)) - ;; Subscribe to the default newsgroups. - (let ((groups (or gnus-default-subscribed-newsgroups - gnus-backup-default-subscribed-newsgroups)) - group) - (if (eq groups t) - ;; If t, we subscribe (or not) all groups as if they were new. - (mapatoms - (lambda (sym) - (when (setq group (symbol-name sym)) - (let ((do-sub (gnus-matches-options-n group))) - (cond - ((eq do-sub 'subscribe) - (gnus-sethash group group gnus-killed-hashtb) - (gnus-call-subscribe-functions - gnus-subscribe-options-newsgroup-method group)) - ((eq do-sub 'ignore) - nil) - (t - (push group gnus-killed-list)))))) - gnus-active-hashtb) - (dolist (group groups) - ;; Only subscribe the default groups that are activated. - (when (gnus-active group) - (gnus-group-change-level - group gnus-level-default-subscribed gnus-level-killed))) - (save-excursion - (set-buffer gnus-group-buffer) - ;; Don't error if the group already exists. This happens when a - ;; first-time user types 'F'. -- didier - (gnus-group-make-help-group t)) - (when gnus-novice-user - (gnus-message 7 "`A k' to list killed groups")))))) + new-newsgroups)) (defun gnus-subscribe-group (group &optional previous method) "Subscribe GROUP and put it after PREVIOUS." @@ -1390,16 +1334,13 @@ for new groups, and subscribe the new groups as zombies." ((>= level gnus-level-zombie) ;; Remove from the hash table. (gnus-sethash group nil gnus-newsrc-hashtb) - ;; We do not enter foreign groups into the list of dead - ;; groups. - (unless (gnus-group-foreign-p group) - (if (= level gnus-level-zombie) - (push group gnus-zombie-list) - (if (= oldlevel gnus-level-killed) - ;; Remove from active hashtb. - (unintern group gnus-active-hashtb) - ;; Don't add it into killed-list if it was killed. - (push group gnus-killed-list))))) + (if (= level gnus-level-zombie) + (push group gnus-zombie-list) + (if (= oldlevel gnus-level-killed) + ;; Remove from active hashtb. + (unintern group gnus-active-hashtb) + ;; Don't add it into killed-list if it was killed. + (push group gnus-killed-list)))) (t ;; If the list is to be entered into the newsrc assoc, and ;; it was killed, we have to create an entry in the newsrc @@ -1441,17 +1382,12 @@ for new groups, and subscribe the new groups as zombies." (when (cdr entry) (setcdr (gnus-group-entry (caadr entry)) entry)) (gnus-dribble-enter - (format - "(gnus-group-set-info '%S)" info))))) + (format "(gnus-group-set-info '%S)" info) + (concat "^(gnus-group-set-info '(\"" (regexp-quote group) "\""))))) (when gnus-group-change-level-function (funcall gnus-group-change-level-function group level oldlevel previous))))) -(defun gnus-kill-newsgroup (newsgroup) - "Obsolete function. Kills a newsgroup." - (gnus-group-change-level - (gnus-group-entry newsgroup) gnus-level-killed)) - (defun gnus-check-bogus-newsgroups (&optional confirm) "Remove bogus newsgroups. If CONFIRM is non-nil, the user has to confirm the deletion of every @@ -1474,7 +1410,7 @@ newsgroup." (push group bogus))) (if confirm (map-y-or-n-p - "Remove bogus group %s? " + (format "Remove bogus group %%s (of %d groups)? " (length bogus)) (lambda (group) ;; Remove all bogus subscribed groups by first killing them, and ;; then removing them from the list of killed groups. @@ -1529,7 +1465,11 @@ newsgroup." (defun gnus-activate-group (group &optional scan dont-check method dont-sub-check) "Check whether a group has been activated or not. -If SCAN, request a scan of that group as well." +If SCAN, request a scan of that group as well. If METHOD, use +that select method instead of determining the method based on the +group name. If DONT-CHECK, don't check whether the group +actually exists. If DONT-SUB-CHECK or DONT-CHECK, don't let the +backend check whether the group actually exists." (let ((method (or method (inline (gnus-find-method-for-group group)))) active) (and (inline (gnus-check-server method)) @@ -1543,13 +1483,16 @@ If SCAN, request a scan of that group as well." t) (if (or debug-on-error debug-on-quit) (inline (gnus-request-group group (or dont-sub-check dont-check) - method)) + method + (gnus-get-info group))) (condition-case nil (inline (gnus-request-group group (or dont-sub-check dont-check) - method)) - ;;(error nil) + method + (gnus-get-info group))) (quit - (message "Quit activating %s" group) + (if debug-on-quit + (debug "Quit") + (message "Quit activating %s" group)) nil))) (unless dont-check (setq active (gnus-parse-active)) @@ -1588,7 +1531,7 @@ If SCAN, request a scan of that group as well." (num 0)) ;; These checks are present in gnus-activate-group but skipped - ;; due to setting dont-check in the preceeding call. + ;; due to setting dont-check in the preceding call. ;; If a cache is present, we may have to alter the active info. (when (and gnus-use-cache info) @@ -1672,52 +1615,46 @@ If SCAN, request a scan of that group as well." ;; Go though `gnus-newsrc-alist' and compare with `gnus-active-hashtb' ;; and compute how many unread articles there are in each group. -(defun gnus-get-unread-articles (&optional level) +(defun gnus-get-unread-articles (&optional level dont-connect one-level) (setq gnus-server-method-cache nil) + (require 'gnus-agent) (let* ((newsrc (cdr gnus-newsrc-alist)) (alevel (or level gnus-activate-level (1+ gnus-level-subscribed))) (foreign-level - (min - (cond ((and gnus-activate-foreign-newsgroups - (not (numberp gnus-activate-foreign-newsgroups))) - (1+ gnus-level-subscribed)) - ((numberp gnus-activate-foreign-newsgroups) - gnus-activate-foreign-newsgroups) - (t 0)) - alevel)) + (or + level + (min + (cond ((and gnus-activate-foreign-newsgroups + (not (numberp gnus-activate-foreign-newsgroups))) + (1+ gnus-level-subscribed)) + ((numberp gnus-activate-foreign-newsgroups) + gnus-activate-foreign-newsgroups) + (t 0)) + alevel))) (methods-cache nil) (type-cache nil) (gnus-agent-article-local-times 0) (archive-method (gnus-server-to-method "archive")) infos info group active method cmethod - method-type method-group-list) + method-type method-group-list entry) (gnus-message 6 "Checking new news...") (while newsrc (setq active (gnus-active (setq group (gnus-info-group (setq info (pop newsrc)))))) - - ;; Check newsgroups. If the user doesn't want to check them, or - ;; they can't be checked (for instance, if the news server can't - ;; be reached) we just set the number of unread articles in this - ;; newsgroup to t. This means that Gnus thinks that there are - ;; unread articles, but it has no idea how many. - - ;; To be more explicit: - ;; >0 for an active group with messages - ;; 0 for an active group with no unread messages - ;; nil for non-foreign groups that the user has requested not be checked - ;; t for unchecked foreign groups or bogus groups, or groups that can't - ;; be checked, for one reason or other. - ;; First go through all the groups, see what select methods they ;; belong to, and then collect them into lists per unique select ;; method. (if (not (setq method (gnus-info-method info))) (setq method gnus-select-method) + ;; There may be several similar methods. Possibly extend the + ;; method. (if (setq cmethod (assoc method methods-cache)) (setq method (cdr cmethod)) - (setq cmethod (inline (gnus-server-get-method nil method))) + (setq cmethod (if (stringp method) + (gnus-server-to-method method) + (inline (gnus-find-method-for-group + (gnus-info-group info) info)))) (push (cons method cmethod) methods-cache) (setq method cmethod))) (setq method-group-list (assoc method type-cache)) @@ -1732,39 +1669,117 @@ If SCAN, request a scan of that group as well." 'primary) (t 'foreign))) - (push (setq method-group-list (list method method-type nil)) + (push (setq method-group-list (list method method-type nil nil)) type-cache)) ;; Only add groups that need updating. - (when (<= (gnus-info-level info) - (if (eq (cadr method-group-list) 'foreign) - foreign-level - alevel)) - (setcar (nthcdr 2 method-group-list) - (cons info (nth 2 method-group-list))))) + (if (funcall (if one-level #'= #'<=) (gnus-info-level info) + (if (eq (cadr method-group-list) 'foreign) + foreign-level + alevel)) + (setcar (nthcdr 2 method-group-list) + (cons info (nth 2 method-group-list))) + ;; The group is inactive, so we nix out the number of unread articles. + ;; It leads `(gnus-group-unread group)' to return t. See also + ;; `gnus-group-prepare-flat'. + (unless active + (when (setq entry (gnus-group-entry group)) + (setcar entry t))))) ;; Sort the methods based so that the primary and secondary ;; methods come first. This is done for legacy reasons to try to - ;; ensure that side-effect behaviour doesn't change from previous + ;; ensure that side-effect behavior doesn't change from previous ;; Gnus versions. (setq type-cache (sort (nreverse type-cache) (lambda (c1 c2) (< (gnus-method-rank (cadr c1) (car c1)) (gnus-method-rank (cadr c2) (car c2)))))) - - (while type-cache - (setq method (nth 0 (car type-cache)) - method-type (nth 1 (car type-cache)) - infos (nth 2 (car type-cache))) - (pop type-cache) - - (when (and method - infos) - ;; See if any of the groups from this method require updating. - (gnus-read-active-for-groups method infos) - (dolist (info infos) - (inline (gnus-get-unread-articles-in-group - info (gnus-active (gnus-info-group info))))))) + ;; Go through the list of servers and possibly extend methods that + ;; aren't equal (and that need extension; i.e., they are async). + (let ((methods nil)) + (dolist (elem type-cache) + (destructuring-bind (method method-type infos dummy) elem + (let ((gnus-opened-servers methods)) + (when (and (gnus-similar-server-opened method) + (gnus-check-backend-function + 'retrieve-group-data-early (car method))) + (setq method (gnus-server-extend-method + (gnus-info-group (car infos)) + method)) + (setcar elem method)) + (push (list method 'ok) methods))))) + + ;; If we have primary/secondary select methods, but no groups from + ;; them, we still want to issue a retrieval request from them. + (unless dont-connect + (dolist (method (cons gnus-select-method + 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))))) + + ;; Clear out all the early methods. + (dolist (elem type-cache) + (destructuring-bind (method method-type infos dummy) elem + (when (and method + infos + (gnus-check-backend-function + '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)))))) + + ;; Start early async retrieval of data. + (let ((done-methods nil) + sanity-spec) + (dolist (elem type-cache) + (destructuring-bind (method method-type infos dummy) elem + (setq sanity-spec (list (car method) (cadr method))) + (when (and method infos + (not (gnus-method-denied-p method))) + ;; If the open-server method doesn't exist, then the method + ;; itself doesn't exist, so we ignore it. + (if (not (ignore-errors (gnus-get-function method 'open-server))) + (setq type-cache (delq elem type-cache)) + (unless (gnus-server-opened method) + (gnus-open-server method)) + (when (and + ;; This is a sanity check, so that we never + ;; attempt to start two async requests to the + ;; same server, because that will fail. This + ;; should never happen, since the methods should + ;; 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) + (when (gnus-check-backend-function 'request-scan (car method)) + (gnus-request-scan nil method)) + ;; Store the token we get back from -early so that we + ;; can pass it to -finish later. + (setcar (nthcdr 3 elem) + (gnus-retrieve-group-data-early method infos)))))))) + + ;; Do the rest of the retrieval. + (dolist (elem type-cache) + (destructuring-bind (method method-type infos early-data) elem + (when (and method infos + (not (gnus-method-denied-p method))) + (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"))) (defun gnus-method-rank (type method) @@ -1788,19 +1803,35 @@ If SCAN, request a scan of that group as well." (t 100))) -(defun gnus-read-active-for-groups (method infos) +(defun gnus-read-active-for-groups (method infos early-data) (with-current-buffer nntp-server-buffer (cond + ;; Finish up getting the data from the methods that have -early + ;; methods. + ((and + early-data + (gnus-check-backend-function 'finish-retrieve-group-infos (car method)) + (or (not (gnus-agent-method-p method)) + (gnus-online method))) + (gnus-finish-retrieve-group-infos method infos early-data) + ;; We may have altered the data now, so mark the dribble buffer + ;; as dirty so that it gets saved. + (gnus-dribble-touch) + (gnus-agent-save-active method)) + ;; Most backends have -retrieve-groups. ((gnus-check-backend-function 'retrieve-groups (car method)) (when (gnus-check-backend-function 'request-scan (car method)) (gnus-request-scan nil method)) - (gnus-read-active-file-2 - (mapcar (lambda (info) - (gnus-group-real-name (gnus-info-group info))) - infos) - method)) + (let (groups) + (gnus-read-active-file-2 + (dolist (info infos (nreverse groups)) + (push (gnus-group-real-name (gnus-info-group info)) groups)) + method))) + ;; Virtually all backends have -request-list. ((gnus-check-backend-function 'request-list (car method)) (gnus-read-active-file-1 method nil)) + ;; Except nnvirtual and friends, where we request each group, one + ;; by one. (t (dolist (info infos) (gnus-activate-group (gnus-info-group info) nil nil method t)))))) @@ -1858,8 +1889,7 @@ If SCAN, request a scan of that group as well." (defun gnus-parse-active () "Parse active info in the nntp server buffer." - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) ;; Parse the result we got from `gnus-request-group'. (when (looking-at "[0-9]+ [0-9]+ \\([0-9]+\\) [0-9]+") @@ -1907,7 +1937,7 @@ If SCAN, request a scan of that group as well." ;; OK - I'm done (setq articles nil)) ((< range article) - ;; this range preceeds the article. Leave the range unmodified. + ;; this range precedes the article. Leave the range unmodified. (pop ranges) ranges) ((= range article) @@ -1930,11 +1960,11 @@ If SCAN, request a scan of that group as well." (setcar ranges min) ranges) ((< max article) - ;; this range preceeds the article. Leave the range unmodified. + ;; this range precedes the article. Leave the range unmodified. (pop ranges) ranges) ((< article min) - ;; this article preceeds the range. Return null to move to the + ;; this article precedes the range. Return null to move to the ;; next article nil) (t @@ -2013,12 +2043,13 @@ If SCAN, request a scan of that group as well." (list "archive"))))) method) (setq gnus-have-read-active-file nil) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (while (setq method (pop methods)) ;; Only do each method once, in case the methods appear more ;; than once in this list. - (unless (member method methods) + (when (and (not (member method methods)) + ;; Check whether the backend exists. + (ignore-errors (gnus-get-function method 'open-server))) (if (or debug-on-error debug-on-quit) (gnus-read-active-file-1 method force) (condition-case () @@ -2026,7 +2057,9 @@ If SCAN, request a scan of that group as well." ;; We catch C-g so that we can continue past servers ;; that do not respond. (quit - (message "Quit reading the active file") + (if debug-on-quit + (debug "Quit") + (message "Quit reading the active file")) nil)))))))) (defun gnus-read-active-file-1 (method force) @@ -2036,11 +2069,12 @@ If SCAN, request a scan of that group as well." (if (and where (not (zerop (length where)))) (concat " from " where) "") (car method))) - (gnus-message 5 mesg) + (gnus-message 5 "%s" mesg) (when (gnus-check-server method) ;; Request that the backend scan its incoming messages. - (when (and gnus-agent - (gnus-online method) + (when (and (or (and gnus-agent + (gnus-online method)) + (not gnus-agent)) (gnus-check-backend-function 'request-scan (car method))) (gnus-request-scan nil method)) (cond @@ -2067,17 +2101,16 @@ If SCAN, request a scan of that group as well." (unless (equal method gnus-message-archive-method) (gnus-error 1 "Cannot read active file from %s server" (car method))) - (gnus-message 5 mesg) + (gnus-message 5 "%s" mesg) (gnus-active-to-gnus-format method gnus-active-hashtb nil t) ;; We mark this active file as read. - (push method gnus-have-read-active-file) + (add-to-list 'gnus-have-read-active-file method) (gnus-message 5 "%sdone" mesg))))))) (defun gnus-read-active-file-2 (groups method) "Read an active file for GROUPS in METHOD using `gnus-retrieve-groups'." (when groups - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (gnus-check-server method) (let ((list-type (gnus-retrieve-groups groups method))) (cond ((not list-type) @@ -2205,7 +2238,7 @@ If SCAN, request a scan of that group as well." (gnus-online method) (gnus-agent-method-p method)) (progn - (gnus-agent-save-active method) + (gnus-agent-save-active method t) (gnus-active-to-gnus-format method hashtb nil real-active)) (goto-char (point-min)) @@ -2278,7 +2311,12 @@ If FORCE is non-nil, the .newsrc file is read." (gnus-message 5 "Reading %s...done" newsrc-file))) ;; Convert old to new. - (gnus-convert-old-newsrc)))) + (gnus-convert-old-newsrc) + (gnus-clean-old-newsrc)))) + +(defun gnus-clean-old-newsrc (&optional force) + ;; Currently no cleanups. + ) (defun gnus-convert-old-newsrc () "Convert old newsrc formats into the current format, if needed." @@ -2417,7 +2455,9 @@ If FORCE is non-nil, the .newsrc file is read." (when gnus-newsrc-assoc (setq gnus-newsrc-alist gnus-newsrc-assoc)))) (dolist (elem gnus-newsrc-alist) - (setcar elem (mm-string-as-unibyte (car elem)))) + ;; Protect against broken .newsrc.el files. + (when (car elem) + (setcar elem (mm-string-as-unibyte (car elem))))) (gnus-make-hashtable-from-newsrc-alist) (when (file-newer-than-file-p file ding-file) ;; Old format quick file @@ -2527,7 +2567,7 @@ If FORCE is non-nil, the .newsrc file is read." ((or (eq symbol options-symbol) (eq symbol Options-symbol)) (setq gnus-newsrc-options - ;; This concating is quite inefficient, but since our + ;; This concatting is quite inefficient, but since our ;; thorough studies show that approx 99.37% of all ;; .newsrc files only contain a single options line, we ;; don't give a damn, frankly, my dear. @@ -2743,6 +2783,7 @@ If FORCE is non-nil, the .newsrc file is read." 'msdos-long-file-names (lambda () t)))) +(defvar gnus-save-newsrc-file-last-timestamp nil) (defun gnus-save-newsrc-file (&optional force) "Save .newsrc file." ;; Note: We cannot save .newsrc file if all newsgroups are removed @@ -2758,8 +2799,7 @@ If FORCE is non-nil, the .newsrc file is read." (not force) (or (not gnus-dribble-buffer) (not (buffer-name gnus-dribble-buffer)) - (zerop (save-excursion - (set-buffer gnus-dribble-buffer) + (zerop (with-current-buffer gnus-dribble-buffer (buffer-size))))) (gnus-message 4 "(No changes need to be saved)") (gnus-run-hooks 'gnus-save-newsrc-hook) @@ -2782,12 +2822,29 @@ If FORCE is non-nil, the .newsrc file is read." (erase-buffer) (gnus-message 5 "Saving %s.eld..." gnus-current-startup-file) + ;; check timestamp of `gnus-current-startup-file'.eld against + ;; `gnus-save-newsrc-file-last-timestamp' + (let* ((checkfile (concat gnus-current-startup-file ".eld")) + (mtime (nth 5 (file-attributes checkfile)))) + (when (and gnus-save-newsrc-file-last-timestamp + (time-less-p gnus-save-newsrc-file-last-timestamp + mtime)) + (unless (y-or-n-p + (format "%s was updated externally after %s, save?" + checkfile + (format-time-string + "%c" + gnus-save-newsrc-file-last-timestamp))) + (error "Couldn't save %s: updated externally" checkfile)))) + (if gnus-save-startup-file-via-temp-buffer (let ((coding-system-for-write gnus-ding-file-coding-system) (standard-output (current-buffer))) (gnus-gnus-to-quick-newsrc-format) (gnus-run-hooks 'gnus-save-quick-newsrc-hook) - (save-buffer)) + (save-buffer) + (setq gnus-save-newsrc-file-last-timestamp + (nth 5 (file-attributes buffer-file-name)))) (let ((coding-system-for-write gnus-ding-file-coding-system) (version-control gnus-backup-startup-file) (startup-file (concat gnus-current-startup-file ".eld")) @@ -2822,7 +2879,9 @@ If FORCE is non-nil, the .newsrc file is read." ;; Replace the existing startup file with the temp file. (rename-file working-file startup-file t) - (gnus-set-file-modes startup-file setmodes))) + (gnus-set-file-modes startup-file setmodes) + (setq gnus-save-newsrc-file-last-timestamp + (nth 5 (file-attributes startup-file))))) (condition-case nil (delete-file working-file) (file-error nil))))) @@ -2891,10 +2950,10 @@ If FORCE is non-nil, the .newsrc file is read." (pop list)) (nreverse olist))) -(defun gnus-gnus-to-newsrc-format () +(defun gnus-gnus-to-newsrc-format (&optional foreign-ok) + (interactive (list (gnus-y-or-n-p "write foreign groups too? "))) ;; Generate and save the .newsrc file. - (save-excursion - (set-buffer (create-file-buffer gnus-current-startup-file)) + (with-current-buffer (create-file-buffer gnus-current-startup-file) (let ((newsrc (cdr gnus-newsrc-alist)) (standard-output (current-buffer)) info ranges range method) @@ -2914,7 +2973,8 @@ If FORCE is non-nil, the .newsrc file is read." ;; Don't write foreign groups to .newsrc. (when (or (null (setq method (gnus-info-method info))) (equal method "native") - (inline (gnus-server-equal method gnus-select-method))) + (inline (gnus-server-equal method gnus-select-method)) + foreign-ok) (insert (gnus-info-group info) (if (> (gnus-info-level info) gnus-level-subscribed) "!" ":")) @@ -2967,8 +3027,7 @@ If FORCE is non-nil, the .newsrc file is read." (gnus-run-hooks 'gnus-slave-mode-hook)) (defun gnus-slave-save-newsrc () - (save-excursion - (set-buffer gnus-dribble-buffer) + (with-current-buffer gnus-dribble-buffer (let ((slave-name (mm-make-temp-file (concat gnus-current-startup-file "-slave-"))) (modes (ignore-errors @@ -2992,8 +3051,7 @@ If FORCE is non-nil, the .newsrc file is read." (if (not slave-files) () ; There are no slave files to read. (gnus-message 7 "Reading slave newsrcs...") - (save-excursion - (set-buffer (gnus-get-buffer-create " *gnus slave*")) + (with-current-buffer (gnus-get-buffer-create " *gnus slave*") (setq slave-files (sort (mapcar (lambda (file) (list (nth 5 (file-attributes file)) file)) @@ -3113,8 +3171,7 @@ If FORCE is non-nil, the .newsrc file is read." (defun gnus-group-get-description (group) "Get the description of a group by sending XGTITLE to the server." (when (gnus-request-group-description group) - (save-excursion - (set-buffer nntp-server-buffer) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) (when (looking-at "[^ \t]+[ \t]+\\(.*\\)") (match-string 1))))) @@ -3141,20 +3198,6 @@ If this variable is nil, don't do anything." (gnus-boundp 'display-time-timer)) (display-time-event-handler))) -;;;###autoload -(defun gnus-fixup-nnimap-unread-after-getting-new-news () - (let (server group info) - (mapatoms - (lambda (sym) - (when (and (setq group (symbol-name sym)) - (gnus-group-entry group) - (setq info (symbol-value sym))) - (gnus-sethash group (cons (nth 2 info) (cdr (gnus-group-entry group))) - gnus-newsrc-hashtb))) - (if (boundp 'nnimap-mailbox-info) - (symbol-value 'nnimap-mailbox-info) - (make-vector 1 0))))) - (defun gnus-check-reasonable-setup () ;; Check whether nnml and nnfolder share a directory. (let ((display-warn