From 8aea120c49952bfc03c7436e7a2a2a9eea369070 Mon Sep 17 00:00:00 2001 From: Lars Magne Ingebrigtsen Date: Tue, 21 Sep 2010 22:43:18 +0200 Subject: [PATCH] When we have several similar methods, try to create as few extended methods as possible. --- lisp/ChangeLog | 5 +++ lisp/gnus-start.el | 15 +-------- lisp/gnus.el | 84 +++++++++++++++++++++++++++++----------------- lisp/nnimap.el | 1 + 4 files changed, 61 insertions(+), 44 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 6d7712878..845c3bd6d 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,10 @@ 2010-09-21 Lars Magne Ingebrigtsen + * gnus.el (gnus-sloppily-equal-method-parameters): Refactor out. + (gnus-same-method-different-name): New function. + + * nnimap.el (parse-time): Require. + * gnus-start.el (gnus-get-unread-articles): Fix the prefixed select method in the presence of many similar methods. diff --git a/lisp/gnus-start.el b/lisp/gnus-start.el index 97a920ac5..5f142091c 100644 --- a/lisp/gnus-start.el +++ b/lisp/gnus-start.el @@ -705,6 +705,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. @@ -1693,20 +1694,6 @@ If SCAN, request a scan of that group as well." (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. diff --git a/lisp/gnus.el b/lisp/gnus.el index 222992eef..eb20575dc 100644 --- a/lisp/gnus.el +++ b/lisp/gnus.el @@ -2681,6 +2681,7 @@ a string, be sure to use a valid format, see RFC 2616." (defvar gnus-newsgroup-name nil) (defvar gnus-ephemeral-servers nil) (defvar gnus-server-method-cache nil) +(defvar gnus-extended-servers nil) (defvar gnus-agent-fetching nil "Whether Gnus agent is in fetching mode.") @@ -3685,32 +3686,35 @@ that that variable is buffer-local to the summary buffers." (and (eq (car m1) (car m2)) (equal (cadr m1) (cadr m2)) - ;; Check parameters for sloppy equalness. - (let ((p1 (copy-list (cddr m1))) - (p2 (copy-list (cddr m2))) - e1 e2) - (block nil - (while (setq e1 (pop p1)) - (unless (setq e2 (assq (car e1) p2)) - ;; The parameter doesn't exist in p2. - (return nil)) - (setq p2 (delq e2 p2)) - (unless (equalp e1 e2) - (if (not (and (stringp (cadr e1)) - (stringp (cadr e2)))) - (return nil) - ;; Special-case string parameter comparison so that we - ;; can uniquify them. - (let ((s1 (cadr e1)) - (s2 (cadr e2))) - (when (string-match "/$" s1) - (setq s1 (directory-file-name s1))) - (when (string-match "/$" s2) - (setq s2 (directory-file-name s2))) - (unless (equal s1 s2) - (return nil)))))) - ;; If p2 now is empty, they were equal. - (null p2)))))) + (gnus-sloppily-equal-method-parameters m1 m2)))) + +(defsubst gnus-sloppily-equal-method-parameters (m1 m2) + ;; Check parameters for sloppy equalness. + (let ((p1 (copy-list (cddr m1))) + (p2 (copy-list (cddr m2))) + e1 e2) + (block nil + (while (setq e1 (pop p1)) + (unless (setq e2 (assq (car e1) p2)) + ;; The parameter doesn't exist in p2. + (return nil)) + (setq p2 (delq e2 p2)) + (unless (equalp e1 e2) + (if (not (and (stringp (cadr e1)) + (stringp (cadr e2)))) + (return nil) + ;; Special-case string parameter comparison so that we + ;; can uniquify them. + (let ((s1 (cadr e1)) + (s2 (cadr e2))) + (when (string-match "/$" s1) + (setq s1 (directory-file-name s1))) + (when (string-match "/$" s2) + (setq s2 (directory-file-name s2))) + (unless (equal s1 s2) + (return nil)))))) + ;; If p2 now is empty, they were equal. + (null p2)))) (defun gnus-server-equal (m1 m2) "Say whether two methods are equal." @@ -4199,9 +4203,12 @@ parameters." (if (or (not (inline (gnus-similar-server-opened method))) (not (cddr method))) method - `(,(car method) ,(concat (cadr method) "+" group) - (,(intern (format "%s-address" (car method))) ,(cadr method)) - ,@(cddr method)))) + (setq method + `(,(car method) ,(concat (cadr method) "+" group) + (,(intern (format "%s-address" (car method))) ,(cadr method)) + ,@(cddr method))) + (push method gnus-extended-servers) + method)) (defun gnus-server-status (method) "Return the status of METHOD." @@ -4226,6 +4233,20 @@ parameters." (format "%s using %s" address (car server)) (format "%s" (car server))))) +(defun gnus-same-method-different-name (method) + (let ((slot (intern (concat (symbol-name (car method)) "-address")))) + (unless (assq slot (cddr method)) + (setq method + (append method (list (list slot (nth 1 method))))))) + (let ((methods gnus-extended-servers) + open found) + (while (and (not found) + (setq open (pop methods))) + (when (and (eq (car method) (car open)) + (gnus-sloppily-equal-method-parameters method open)) + (setq found open))) + found)) + (defun gnus-find-method-for-group (group &optional info) "Find the select method that GROUP uses." (or gnus-override-method @@ -4248,7 +4269,10 @@ parameters." (cond ((stringp method) (inline (gnus-server-to-method method))) ((stringp (cadr method)) - (inline (gnus-server-extend-method group method))) + (or + (inline + (gnus-same-method-different-name method)) + (inline (gnus-server-extend-method group method)))) (t method))) (cond ((equal (cadr method) "") diff --git a/lisp/nnimap.el b/lisp/nnimap.el index 833e211d9..e43cd2d8a 100644 --- a/lisp/nnimap.el +++ b/lisp/nnimap.el @@ -37,6 +37,7 @@ (require 'gnus) (require 'nnoo) (require 'netrc) +(require 'parse-time) (nnoo-declare nnimap) -- 2.25.1