Merge from mainline.

6 files changed, 169 insertions, 25 deletions

diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 35531df0ad2..99a08de633b 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,68 @@
+2011-04-25  Teodor Zlatanov  <tzz@lifelogs.com>
+
+	* gnus-registry.el (gnus-registry-ignore-group-p): Don't call
+	`gnus-parameter-registry-ignore' if the *Group* buffer doesn't exist.
+
+2011-04-23  Glenn Morris  <rgm@gnu.org>
+
+	* gnus-sum.el (gnus-extra-headers): Bump :version.
+
+2011-04-24  Lars Magne Ingebrigtsen  <larsi@gnus.org>
+
+	* shr.el (shr-tag-sup): New function.
+	(shr-tag-sub): Ditto.
+
+2011-04-22  Teodor Zlatanov  <tzz@lifelogs.com>
+
+	* gnus-registry.el (gnus-registry-ignore-group-p): Test specifically
+	for the case where `gnus-registry-ignored-groups' is a list of lists,
+	and don't call `gnus-parameter-registry-ignore' otherwise.
+
+2011-04-21  Teodor Zlatanov  <tzz@lifelogs.com>
+
+	* nnimap.el (nnimap-user): New backend variable.
+	(nnimap-open-connection-1): Use it.
+	(nnimap-credentials): Accept user parameter so it's explicit what user
+	name is desired.
+
+	* gnus-sum.el (gnus-extra-headers): Add Keywords, Cc, and Gcc to
+	default.
+
+	* gnus.el (gnus-registry-ignored-groups): Provide default in gnus.el,
+	not gnus-registry.el.
+
+	* gnus-registry.el: Mention in comments how to modify
+	`gnus-extra-headers' for proper recipient tracking and that it may
+	already have To and Cc recently, which it does as of this commit.
+	(gnus-registry-ignored-groups): Remove defcustom.
+	Explain why in comments.
+	(gnus-registry-action): Fix data-header reference to use the extra
+	headers.  Explain in package commentary how to add To and Cc headers to
+	the gnus-extra-headers.
+	(gnus-registry-ignored-groups): Adjust defaults to match the parameter.
+	(gnus-registry-ignore-group-p): Adjust to take either a group/topic
+	parameter list or a string list in `gnus-registry-ignored-groups'.  Fix
+	logic error.
+
+2011-04-21  Lars Magne Ingebrigtsen  <larsi@gnus.org>
+
+	* shr.el (shr-expand-url): Protect against null urls.
+
+2011-04-20  Lars Magne Ingebrigtsen  <larsi@gnus.org>
+
+	* shr.el (shr-base): New binding.
+	(shr-tag-base): Keep track of <base>.
+	(shr-expand-url): New function used throughout.
+
+2011-04-20  Teodor Zlatanov  <tzz@lifelogs.com>
+
+	* gnus-registry.el
+	(gnus-registry--split-fancy-with-parent-internal): Fix loop bugs.
+	(gnus-registry-ignored-groups): New variable.
+	(gnus-registry-ignore-group-p): Use it.
+	(gnus-registry-handle-action): Use `gnus-registry-ignore-group-p' and
+	set the destination group to nil (same as delete) if it's ignored.
+
 2011-04-20  Katsumi Yamaoka  <yamaoka@jpl.org>
 
 	* gnus-registry.el (gnus-registry-action)
diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el
index 009786dec80..e6c96ab2b19 100644
--- a/lisp/gnus/gnus-registry.el
+++ b/lisp/gnus/gnus-registry.el
@@ -31,7 +31,17 @@
 ;; gnus-registry.el intercepts article respooling, moving, deleting,
 ;; and copying for all backends.  If it doesn't work correctly for
 ;; you, submit a bug report and I'll be glad to fix it.  It needs
-;; documentation in the manual (also on my to-do list).
+;; better documentation in the manual (also on my to-do list).
+
+;; If you want to track recipients (and you should to make the
+;; gnus-registry splitting work better), you need the To and Cc
+;; headers collected by Gnus.  Note that in more recent Gnus versions
+;; this is already the case: look at `gnus-extra-headers' to be sure.
+
+;; ;;; you may also want Gcc Newsgroups Keywords X-Face
+;; (add-to-list 'gnus-extra-headers 'To)
+;; (add-to-list 'gnus-extra-headers 'Cc)
+;; (setq nnmail-extra-headers gnus-extra-headers)
 
 ;; Put this in your startup file (~/.gnus.el for instance) or use Customize:
 
@@ -303,9 +313,10 @@ This is not required after changing `gnus-registry-cache-file'."
 (defun gnus-registry-action (action data-header from &optional to method)
   (let* ((id (mail-header-id data-header))
          (subject (mail-header-subject data-header))
+         (extra (mail-header-extra data-header))
          (recipients (gnus-registry-sort-addresses
-		      (or (cdr (assq "Cc" data-header)) "")
-		      (or (cdr (assq "To" data-header)) "")))
+                      (or (cdr-safe (assq 'Cc extra)) "")
+                      (or (cdr-safe (assq 'To extra)) "")))
          (sender (nth 0 (gnus-registry-extract-addresses
                          (mail-header-from data-header))))
          (from (gnus-group-guess-full-name-from-command-method from))
@@ -323,9 +334,9 @@ This is not required after changing `gnus-registry-cache-file'."
 (defun gnus-registry-spool-action (id group &optional subject sender recipients)
   (let ((to (gnus-group-guess-full-name-from-command-method group))
         (recipients (or recipients
-			(gnus-registry-sort-addresses
-			 (or (message-fetch-field "cc") "")
-			 (or (message-fetch-field "to") ""))))
+                        (gnus-registry-sort-addresses
+                         (or (message-fetch-field "cc") "")
+                         (or (message-fetch-field "to") ""))))
         (subject (or subject (message-fetch-field "subject")))
         (sender (or sender (message-fetch-field "from"))))
     (when (and (stringp id) (string-match "\r$" id))
@@ -341,6 +352,8 @@ This is not required after changing `gnus-registry-cache-file'."
    10
    "gnus-registry-handle-action %S" (list id from to subject sender recipients))
   (let ((db gnus-registry-db)
+        ;; if the group is ignored, set the destination to nil (same as delete)
+        (to (if (gnus-registry-ignore-group-p to) nil to))
         ;; safe if not found
         (entry (gnus-registry-get-or-make-entry id))
         (subject (gnus-string-remove-all-properties
@@ -402,8 +415,8 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
          (sender (gnus-string-remove-all-properties
                   (message-fetch-field "from")))
          (recipients (gnus-registry-sort-addresses
-		      (or (message-fetch-field "cc") "")
-		      (or (message-fetch-field "to") "")))
+                      (or (message-fetch-field "cc") "")
+                      (or (message-fetch-field "to") "")))
          (subject (gnus-string-remove-all-properties
                    (gnus-registry-simplify-subject
                     (message-fetch-field "subject"))))
@@ -442,8 +455,10 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
         (gnus-message 9 "%s is looking up %s" log-agent reference)
         (loop for group in (gnus-registry-get-id-key reference 'group)
               when (gnus-registry-follow-group-p group)
-              do (gnus-message 7 "%s traced %s to %s" log-agent reference group)
-              do (push group found)))
+              do
+              (progn
+                (gnus-message 7 "%s traced %s to %s" log-agent reference group)
+                (push group found))))
       ;; filter the found groups and return them
       ;; the found groups are the full groups
       (setq found (gnus-registry-post-process-groups
@@ -468,7 +483,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
                          (if gnus-registry-track-extra 7 9)
                          "%s (extra tracking) traced subject '%s' to %s"
                          log-agent subject group)
-                     collect group))
+                    and collect group))
          ;; filter the found groups and return them
          ;; the found groups are NOT the full groups
          (setq found (gnus-registry-post-process-groups
@@ -495,7 +510,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
                          (if gnus-registry-track-extra 7 9)
                          "%s (extra tracking) traced sender '%s' to %s"
                          log-agent sender group)
-                     collect group)))
+                     and collect group)))
 
        ;; filter the found groups and return them
        ;; the found groups are NOT the full groups
@@ -525,7 +540,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
                              (if gnus-registry-track-extra 7 9)
                              "%s (extra tracking) traced recipient '%s' to %s"
                              log-agent recp group)
-                         collect group)))))
+                        and collect group)))))
 
        ;; filter the found groups and return them
        ;; the found groups are NOT the full groups
@@ -641,6 +656,34 @@ Consults `gnus-registry-unfollowed-groups' and
                  group
                  nnmail-split-fancy-with-parent-ignore-groups)))))
 
+;; note that gnus-registry-ignored-groups is defined in gnus.el as a
+;; group/topic parameter and an associated variable!
+
+;; we do special logic for ignoring to accept regular expressions and
+;; nnmail-split-fancy-with-parent-ignore-groups as well
+(defun gnus-registry-ignore-group-p (group)
+  "Determines if a group name should be ignored.
+Consults `gnus-registry-ignored-groups' and
+`nnmail-split-fancy-with-parent-ignore-groups'."
+  (and group
+       (or (gnus-grep-in-list
+            group
+            (delq nil (mapcar (lambda (g)
+                                (cond
+                                 ((stringp g) g)
+                                 ((and (listp g) (nth 1 g))
+                                  (nth 0 g))
+                                 (t nil))) gnus-registry-ignored-groups)))
+           ;; only use `gnus-parameter-registry-ignore' if
+           ;; `gnus-registry-ignored-groups' is a list of lists
+           ;; (it can be a list of regexes)
+           (and (listp (nth 0 gnus-registry-ignored-groups))
+                (get-buffer "*Group*")  ; in automatic tests this is false
+                (gnus-parameter-registry-ignore group))
+           (gnus-grep-in-list
+            group
+            nnmail-split-fancy-with-parent-ignore-groups))))
+
 (defun gnus-registry-wash-for-keywords (&optional force)
   "Get the keywords of the current article.
 Overrides existing keywords with FORCE set non-nil."
@@ -712,7 +755,7 @@ Addresses without a name will say \"noname\"."
 (defun gnus-registry-sort-addresses (&rest addresses)
   "Return a normalized and sorted list of ADDRESSES."
   (sort (apply 'nconc (mapcar 'gnus-registry-extract-addresses addresses))
-	'string-lessp))
+        'string-lessp))
 
 (defun gnus-registry-simplify-subject (subject)
   (if (stringp subject)
@@ -743,7 +786,7 @@ Addresses without a name will say \"noname\"."
            (assoc article (gnus-data-list nil)))
       (gnus-string-remove-all-properties
        (cdr (assq header (gnus-data-header
-			  (assoc article (gnus-data-list nil))))))
+                          (assoc article (gnus-data-list nil))))))
     nil))
 
 ;; registry marks glue
@@ -972,7 +1015,7 @@ only the last one's marks are returned."
                extra-cell key val)
           ;; remove all the strings from the entry
           (dolist (elem rest)
-	    (if (stringp elem) (setq rest (delq elem rest))))
+            (if (stringp elem) (setq rest (delq elem rest))))
           (gnus-registry-set-id-key id 'group groups)
           ;; just use the first extra element
           (setq rest (car-safe rest))
diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el
index d023bc5bb63..807f133e481 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -1128,9 +1128,9 @@ which it may alter in any way."
   'mail-decode-encoded-address-string
   "Function used to decode addresses with encoded words.")
 
-(defcustom gnus-extra-headers '(To Newsgroups)
+(defcustom gnus-extra-headers '(To Cc Keywords Gcc Newsgroups)
   "*Extra headers to parse."
-  :version "21.1"
+  :version "24.1"                       ; added Cc Keywords Gcc
   :group 'gnus-summary
   :type '(repeat symbol))
 
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index f68ea41e6bd..5ff03572832 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -1875,7 +1875,10 @@ total number of articles in the group.")
  :function-document
  "Whether this group should be ignored by the registry."
  :variable gnus-registry-ignored-groups
- :variable-default nil
+ :variable-default (mapcar
+                    (lambda (g) (list g t))
+                    '("delayed$" "drafts$" "queue$" "INBOX$"
+                      "^nnmairix:" "archive"))
  :variable-document
  "*Groups in which the registry should be turned off."
  :variable-group gnus-registry
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el
index afdea185dd3..f819c17afe8 100644
--- a/lisp/gnus/nnimap.el
+++ b/lisp/gnus/nnimap.el
@@ -58,6 +58,9 @@
 (defvoo nnimap-address nil
   "The address of the IMAP server.")
 
+(defvoo nnimap-user nil
+  "Username to use for authentication to the IMAP server.")
+
 (defvoo nnimap-server-port nil
   "The IMAP port used.
 If nnimap-stream is `ssl', this will default to `imaps'.  If not,
@@ -283,13 +286,14 @@ textual parts.")
     (push (current-buffer) nnimap-process-buffers)
     (current-buffer)))
 
-(defun nnimap-credentials (address ports)
+(defun nnimap-credentials (address ports user)
   (let* ((auth-source-creation-prompts
           '((user  . "IMAP user at %h: ")
             (secret . "IMAP password for %u@%h: ")))
          (found (nth 0 (auth-source-search :max 1
                                            :host address
                                            :port ports
+                                           :user user
                                            :require '(:user :secret)
                                            :create t))))
     (if found
@@ -408,7 +412,8 @@ textual parts.")
 				 (list
 				  nnimap-address
 				  (nnoo-current-server 'nnimap)))
-                                ports))))
+                                ports
+                                nnimap-user))))
 		  (setq nnimap-object nil)
 		(let ((nnimap-inhibit-logging t))
 		  (setq login-result
diff --git a/lisp/gnus/shr.el b/lisp/gnus/shr.el
index 113137a0046..1f6cb528c5d 100644
--- a/lisp/gnus/shr.el
+++ b/lisp/gnus/shr.el
@@ -99,6 +99,7 @@ cid: URL as the argument.")
 (defvar shr-kinsoku-shorten nil)
 (defvar shr-table-depth 0)
 (defvar shr-stylesheet nil)
+(defvar shr-base nil)
 
 (defvar shr-map
   (let ((map (make-sparse-keymap)))
@@ -127,6 +128,7 @@ cid: URL as the argument.")
   (setq shr-content-cache nil)
   (let ((shr-state nil)
 	(shr-start nil)
+	(shr-base nil)
 	(shr-width (or shr-width (window-width))))
     (shr-descend (shr-transform-dom dom))))
 
@@ -392,6 +394,19 @@ redirects somewhere else."
 	 (forward-char 1))))
     (not failed)))
 
+(defun shr-expand-url (url)
+  (cond
+   ;; Absolute URL.
+   ((or (not url)
+	(string-match "\\`[a-z]*:" url)
+	(not shr-base))
+    url)
+   ((and (not (string-match "/\\'" shr-base))
+	 (not (string-match "\\`/" url)))
+    (concat shr-base "/" url))
+   (t
+    (concat shr-base url))))
+
 (defun shr-ensure-newline ()
   (unless (zerop (current-column))
     (insert "\n")))
@@ -719,6 +734,16 @@ ones, in case fg and bg are nil."
 (defun shr-tag-script (cont)
   )
 
+(defun shr-tag-sup (cont)
+  (let ((start (point)))
+    (shr-generic cont)
+    (put-text-property start (point) 'display '(raise 0.5))))
+
+(defun shr-tag-sub (cont)
+  (let ((start (point)))
+    (shr-generic cont)
+    (put-text-property start (point) 'display '(raise -0.5))))
+
 (defun shr-tag-label (cont)
   (shr-generic cont)
   (shr-ensure-paragraph))
@@ -773,13 +798,16 @@ ones, in case fg and bg are nil."
 		    plist)))))
       plist)))
 
+(defun shr-tag-base (cont)
+  (setq shr-base (cdr (assq :href cont))))
+
 (defun shr-tag-a (cont)
   (let ((url (cdr (assq :href cont)))
         (title (cdr (assq :title cont)))
 	(start (point))
 	shr-start)
     (shr-generic cont)
-    (shr-urlify (or shr-start start) url title)))
+    (shr-urlify (or shr-start start) (shr-expand-url url) title)))
 
 (defun shr-tag-object (cont)
   (let ((start (point))
@@ -792,7 +820,7 @@ ones, in case fg and bg are nil."
 	(setq url (or url (cdr (assq :value (cdr elem)))))))
     (when url
       (shr-insert " [multimedia] ")
-      (shr-urlify start url))
+      (shr-urlify start (shr-expand-url url)))
     (shr-generic cont)))
 
 (defun shr-tag-video (cont)
@@ -800,7 +828,7 @@ ones, in case fg and bg are nil."
 	(url (cdr (assq :src cont)))
 	(start (point)))
     (shr-tag-img nil image)
-    (shr-urlify start url)))
+    (shr-urlify start (shr-expand-url url))))
 
 (defun shr-tag-img (cont &optional url)
   (when (or url
@@ -810,7 +838,7 @@ ones, in case fg and bg are nil."
 	       (not (eq shr-state 'image)))
       (insert "\n"))
     (let ((alt (cdr (assq :alt cont)))
-	  (url (or url (cdr (assq :src cont)))))
+	  (url (shr-expand-url (or url (cdr (assq :src cont))))))
       (let ((start (point-marker)))
 	(when (zerop (length alt))
 	  (setq alt "*"))