Mercurial > emacs
changeset 110189:821c596efa5f
Rewrite the Gnus group activation method to be more efficient; nnmh.el (nnmh-request-list-1): Fix up the recursion behavior; Add more changes related to the new methodology for requesting backend data.
| author | Katsumi Yamaoka <yamaoka@jpl.org> |
|---|---|
| date | Sun, 05 Sep 2010 00:34:16 +0000 |
| parents | 92e4fa270c92 |
| children | 896692b6eb7b |
| files | lisp/gnus/ChangeLog lisp/gnus/gnus-group.el lisp/gnus/gnus-int.el lisp/gnus/gnus-start.el lisp/gnus/mail-source.el lisp/gnus/nnmail.el lisp/gnus/nnmh.el lisp/gnus/nnvirtual.el |
| diffstat | 8 files changed, 123 insertions(+), 138 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/gnus/ChangeLog Sun Sep 05 00:54:58 2010 +0200 +++ b/lisp/gnus/ChangeLog Sun Sep 05 00:34:16 2010 +0000 @@ -1,5 +1,16 @@ 2010-09-04 Lars Magne Ingebrigtsen <larsi@gnus.org> + * gnus-start.el (gnus-get-unread-articles): Rewrite the way we request + data from the backends, so that we only request the list of groups from + each method once. This should speed things up considerably. + + * nnvirtual.el (nnvirtual-request-list): Remove function so that we can + detect that it's not implemented. + + * nnmh.el (nnmh-request-list-1): Fix up the recursion behavior so that + we actually do recurse down into the tree, but don't stat all leaf + nodes. + * gnus-html.el (gnus-html-show-images): If there are no images to show, then say so instead of bugging out.
--- a/lisp/gnus/gnus-group.el Sun Sep 05 00:54:58 2010 +0200 +++ b/lisp/gnus/gnus-group.el Sun Sep 05 00:34:16 2010 +0000 @@ -3982,23 +3982,13 @@ (>= arg gnus-use-nocem)) (not arg))) (gnus-nocem-scan-groups)) - ;; If ARG is not a number, then we read the active file. - (when (and arg (not (numberp arg))) - (let ((gnus-read-active-file t)) - (gnus-read-active-file)) - (setq arg nil) - - ;; If the user wants it, we scan for new groups. - (when (eq gnus-check-new-newsgroups 'always) - (gnus-find-new-newsgroups))) - - (setq arg (gnus-group-default-level arg t)) - (if (and gnus-read-active-file (not arg)) - (progn - (gnus-read-active-file) - (gnus-get-unread-articles arg)) - (let ((gnus-read-active-file (if arg nil gnus-read-active-file))) - (gnus-get-unread-articles arg))) + + (gnus-get-unread-articles arg) + + ;; If the user wants it, we scan for new groups. + (when (eq gnus-check-new-newsgroups 'always) + (gnus-find-new-newsgroups)) + (gnus-check-reasonable-setup) (gnus-run-hooks 'gnus-after-getting-new-news-hook) (gnus-group-list-groups (and (numberp arg)
--- a/lisp/gnus/gnus-int.el Sun Sep 05 00:54:58 2010 +0200 +++ b/lisp/gnus/gnus-int.el Sun Sep 05 00:34:16 2010 +0000 @@ -544,7 +544,8 @@ (if group (gnus-find-method-for-group group) gnus-command-method)) (gnus-inhibit-demon t) (mail-source-plugged gnus-plugged)) - (when (or gnus-plugged (not (gnus-agent-method-p gnus-command-method))) + (when (or gnus-plugged + (not (gnus-agent-method-p gnus-command-method))) (setq gnus-internal-registry-spool-current-method gnus-command-method) (funcall (gnus-get-function gnus-command-method 'request-scan) (and group (gnus-group-real-name group))
--- a/lisp/gnus/gnus-start.el Sun Sep 05 00:54:58 2010 +0200 +++ b/lisp/gnus/gnus-start.el Sun Sep 05 00:34:16 2010 +0000 @@ -1684,8 +1684,8 @@ alevel)) (methods-cache nil) (type-cache nil) - scanned-methods info group active method retrieve-groups cmethod - method-type) + infos info group active method cmethod + method-type method-group-list) (gnus-message 6 "Checking new news...") (while newsrc @@ -1704,14 +1704,19 @@ ;; 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. - (when (setq method (gnus-info-method info)) + + ;; 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) (if (setq cmethod (assoc method methods-cache)) (setq method (cdr cmethod)) (setq cmethod (inline (gnus-server-get-method nil method))) (push (cons method cmethod) methods-cache) (setq method cmethod))) - (when (and method - (not (setq method-type (cdr (assoc method type-cache))))) + (setq method-group-list (assoc method type-cache)) + (unless method-group-list (setq method-type (cond ((gnus-secondary-method-p method) @@ -1720,98 +1725,73 @@ 'primary) (t 'foreign))) - (push (cons method method-type) type-cache)) + (push (setq method-group-list (list method method-type nil)) + type-cache)) + (setcar (nthcdr 2 method-group-list) + (cons info (nth 2 method-group-list)))) + + ;; 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 + ;; 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) - (cond ((and method (eq method-type 'foreign)) - ;; These groups are foreign. Check the level. - (if (<= (gnus-info-level info) foreign-level) - (when (setq active (gnus-activate-group group 'scan)) - ;; Let the Gnus agent save the active file. - (when (and gnus-agent active (gnus-online method)) - (gnus-agent-save-group-info - method (gnus-group-real-name group) active)) - (unless (inline (gnus-virtual-group-p group)) - (inline (gnus-close-group group))) - (when (fboundp (intern (concat (symbol-name (car method)) - "-request-update-info"))) - (inline (gnus-request-update-info info method)))) - (if (and level - ;; If `active' is nil that means the group has - ;; never been read, the group should be marked - ;; as having never been checked (see below). - active - (> (gnus-info-level info) level)) - ;; Don't check groups of which levels are higher - ;; than the one that a user specified. - (setq active 'ignore)))) - ;; These groups are native or secondary. - ((> (gnus-info-level info) alevel) - ;; We don't want these groups. - (setq active 'ignore)) - ;; Activate groups. - ((not gnus-read-active-file) - (if (gnus-check-backend-function 'retrieve-groups group) - ;; if server support gnus-retrieve-groups we push - ;; the group onto retrievegroups for later checking - (if (assoc method retrieve-groups) - (setcdr (assoc method retrieve-groups) - (cons group (cdr (assoc method retrieve-groups)))) - (push (list method group) retrieve-groups)) - ;; hack: `nnmail-get-new-mail' changes the mail-source depending - ;; on the group, so we must perform a scan for every group - ;; if the users has any directory mail sources. - ;; hack: if `nnmail-scan-directory-mail-source-once' is non-nil, - ;; for it scan all spool files even when the groups are - ;; not required. - (if (and - (or nnmail-scan-directory-mail-source-once - (null (assq 'directory mail-sources))) - (member method scanned-methods)) - (setq active (gnus-activate-group group)) - (setq active (gnus-activate-group group 'scan)) - (push method scanned-methods)) - (when active - (gnus-close-group group))))) + ;; See if any of the groups from this method require updating. + (when (block nil + (dolist (info infos) + (when (<= (gnus-info-level info) + (if (eq method-type 'foreign) + foreign-level + alevel)) + (return t)))) + (gnus-read-active-for-groups method infos) + (dolist (info infos) + (inline (gnus-get-unread-articles-in-group + info (gnus-active (gnus-info-group info))))))) + (gnus-message 6 "Checking new news...done"))) - ;; Get the number of unread articles in the group. - (cond - ((eq active 'ignore) - ;; Don't do anything. - ) - (active - (inline (gnus-get-unread-articles-in-group info active t))) - (t - ;; The group couldn't be reached, so we nix out the number of - ;; unread articles and stuff. - (gnus-set-active group nil) - (let ((tmp (gnus-group-entry group))) - (when tmp - (setcar tmp t)))))) +(defun gnus-method-rank (type method) + (cond + ((eq type 'primary) + 1) + ;; Compute the rank of the secondary methods based on where they + ;; are in the secondary select list. + ((eq type 'secondary) + (let ((i 2)) + (block nil + (dolist (smethod gnus-secondary-select-methods) + (when (equalp method smethod) + (return i)) + (incf i)) + i))) + ;; Just say that all foreign groups have the same rank. + (t + 100))) - ;; iterate through groups on methods which support gnus-retrieve-groups - ;; and fetch a partial active file and use it to find new news. - (dolist (rg retrieve-groups) - (let ((method (or (car rg) gnus-select-method)) - (groups (cdr rg))) - (when (gnus-check-server method) - ;; Request that the backend scan its incoming messages. - (when (gnus-check-backend-function 'request-scan (car method)) - (gnus-request-scan nil method)) - (gnus-read-active-file-2 - (mapcar (lambda (group) (gnus-group-real-name group)) groups) - method) - (dolist (group groups) - (cond - ((setq active (gnus-active (gnus-info-group - (setq info (gnus-get-info group))))) - (inline (gnus-get-unread-articles-in-group info active t))) - (t - ;; The group couldn't be reached, so we nix out the number of - ;; unread articles and stuff. - (gnus-set-active group nil) - (setcar (gnus-group-entry group) t))))))) - - (gnus-message 6 "Checking new news...done"))) +(defun gnus-read-active-for-groups (method infos) + (with-current-buffer nntp-server-buffer + (cond + ((gnus-check-backend-function 'retrieve-groups (car method)) + (gnus-read-active-file-2 + (mapcar (lambda (info) + (gnus-group-real-name (gnus-info-group info))) + infos) + method)) + ((gnus-check-backend-function 'request-list (car method)) + (gnus-read-active-file-1 method nil)) + (t + (dolist (info infos) + (gnus-activate-group (gnus-info-group info) nil nil method)))))) ;; Create a hash table out of the newsrc alist. The `car's of the ;; alist elements are used as keys. @@ -2043,7 +2023,9 @@ (gnus-message 5 mesg) (when (gnus-check-server method) ;; Request that the backend scan its incoming messages. - (when (gnus-check-backend-function 'request-scan (car method)) + (when (and gnus-agent + (gnus-online method) + (gnus-check-backend-function 'request-scan (car method))) (gnus-request-scan nil method)) (cond ((and (eq gnus-read-active-file 'some)
--- a/lisp/gnus/mail-source.el Sun Sep 05 00:54:58 2010 +0200 +++ b/lisp/gnus/mail-source.el Sun Sep 05 00:34:16 2010 +0000 @@ -536,7 +536,7 @@ (t value))) -(defun mail-source-fetch (source callback) +(defun mail-source-fetch (source callback &optional method) "Fetch mail from SOURCE and call CALLBACK zero or more times. CALLBACK will be called with the name of the file where (some of) the mail from SOURCE is put. @@ -544,6 +544,11 @@ (mail-source-bind-common source (if (or mail-source-plugged plugged) (save-excursion + (nnheader-message 4 "%sReading incoming mail from %s..." + (if method + (format "%s: " method) + "") + (car source)) (let ((function (cadr (assq (car source) mail-source-fetcher-alist))) (found 0)) (unless function
--- a/lisp/gnus/nnmail.el Sun Sep 05 00:54:58 2010 +0200 +++ b/lisp/gnus/nnmail.el Sun Sep 05 00:34:16 2010 +0000 @@ -1823,8 +1823,6 @@ ;; The we go through all the existing mail source specification ;; and fetch the mail from each. (while (setq source (pop fetching-sources)) - (nnheader-message 4 "%s: Reading incoming mail from %s..." - method (car source)) (when (setq new (mail-source-fetch source @@ -1842,8 +1840,9 @@ (incf i))) ;; If we did indeed read any incoming spools, we save all info. (if (zerop total) - (nnheader-message 4 "%s: Reading incoming mail (no new mail)...done" - method (car source)) + (when mail-source-plugged + (nnheader-message 4 "%s: Reading incoming mail (no new mail)...done" + method (car source))) (nnmail-save-active (nnmail-get-value "%s-group-alist" method) (nnmail-get-value "%s-active-file" method))
--- a/lisp/gnus/nnmh.el Sun Sep 05 00:54:58 2010 +0200 +++ b/lisp/gnus/nnmh.el Sun Sep 05 00:34:16 2010 +0000 @@ -209,24 +209,25 @@ ;; Recurse down all directories. (let ((files (nnheader-directory-files dir t nil t)) (max 0) - min rdir attributes num) + min rdir num subdirectoriesp) ;; Recurse down directories. + (setq subdirectoriesp (> (nth 1 (file-attributes dir)) 2)) (dolist (rdir files) - (setq attributes (file-attributes rdir)) - (when (null (nth 0 attributes)) - (setq file (file-name-nondirectory rdir)) - (when (string-match "^[0-9]+$" file) - (setq num (string-to-number file)) - (setq max (max max num)) - (when (or (null min) - (< num min)) - (setq min num)))) - (when (and (eq (nth 0 attributes) t) ; Is a directory - (> (nth 1 attributes) 2) ; Has sub-directories - (file-readable-p rdir) - (not (equal (file-truename rdir) - (file-truename dir)))) - (nnmh-request-list-1 rdir))) + (if (or (not subdirectoriesp) + (file-regular-p rdir)) + (progn + (setq file (file-name-nondirectory rdir)) + (when (string-match "^[0-9]+$" file) + (setq num (string-to-number file)) + (setq max (max max num)) + (when (or (null min) + (< num min)) + (setq min num)))) + ;; This is a directory. + (when (and (file-readable-p rdir) + (not (equal (file-truename rdir) + (file-truename dir)))) + (nnmh-request-list-1 rdir)))) ;; For each directory, generate an active file line. (unless (string= (expand-file-name nnmh-toplev) dir) (when min
--- a/lisp/gnus/nnvirtual.el Sun Sep 05 00:54:58 2010 +0200 +++ b/lisp/gnus/nnvirtual.el Sun Sep 05 00:34:16 2010 +0000 @@ -300,10 +300,6 @@ t) -(deffoo nnvirtual-request-list (&optional server) - (nnheader-report 'nnvirtual "LIST is not implemented.")) - - (deffoo nnvirtual-request-newgroups (date &optional server) (nnheader-report 'nnvirtual "NEWGROUPS is not supported."))