Rewrite the Gnus group activation method to be more efficient; nnmh.el...

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.

lisp/gnus/ChangeLog

 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.
 

lisp/gnus/gnus-group.el

@@ -3982,23 +3982,13 @@ re-scanning.  If ARG is non-nil and not a number, this will force
 			(>= 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)

lisp/gnus/gnus-int.el

@@ -544,7 +544,8 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned."
 	 (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))

lisp/gnus/gnus-start.el

@@ -1684,8 +1684,8 @@ If SCAN, request a scan of that group as well."
 	   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 @@ If SCAN, request a scan of that group as well."
       ;; 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,99 +1725,74 @@ If SCAN, request a scan of that group as well."
 		'primary)
 	       (t
 		'foreign)))
-	(push (cons method method-type) 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)))))
-
-      ;; 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))))))
-
-    ;; 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)))))))
-
+	(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)
+
+      ;; 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")))
 
+(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)))
+
+(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.
 (defun gnus-make-hashtable-from-newsrc-alist ()
@@ -2043,7 +2023,9 @@ If SCAN, request a scan of that group as well."
     (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)

lisp/gnus/mail-source.el

@@ -536,7 +536,7 @@ See `mail-source-bind'."
    (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 @@ Return the number of files that were found."
   (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

lisp/gnus/nnmail.el

@@ -1823,8 +1823,6 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
       ;; 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 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
 	  (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))

lisp/gnus/nnmh.el

@@ -209,24 +209,25 @@ as unread by Gnus.")
   ;; 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

lisp/gnus/nnvirtual.el

@@ -300,10 +300,6 @@ component group will show up when you enter the virtual group.")
   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."))