Merge from gnus--devo--0

Revision: emacs@sv.gnu.org/emacs--devo--0--patch-1128

5 files changed, 121 insertions, 42 deletions

diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 0282e4151e7..d5f72bc4846 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,9 +1,34 @@
+2008-04-25  Teodor Zlatanov  <tzz@lifelogs.com>
+
+        * mail-source.el: Load auth-source.el.
+        (mail-source-bind): Add comments.  Call auth-source-user-or-password to
+        get user name or password, if auth-sources is set up.
+
+        * gnus-registry.el (gnus-registry-split-strategy): New variable for
+        strategy of splitting with parent.
+        (gnus-registry-split-fancy-with-parent)
+        (gnus-registry-post-process-groups): Use it and fix prior
+        bug (returning a list as the split result).
+
+        * auth-source.el (auth-sources): Remove server parameter.
+        (auth-source-pick, auth-source-user-or-password)
+        (auth-source-user-or-password-imap)
+        (auth-source-user-or-password-pop3, auth-source-user-or-password-ssh)
+        (auth-source-user-or-password-sftp)
+        (auth-source-user-or-password-smtp): Remove server parameter.
+
 2008-04-25  Juanma Barranquero  <lekktu@gmail.com>
 
         * smime.el (smime-sign-region, smime-encrypt-region)
         (smime-decrypt-region):
         Remove redundant calls to `generate-new-buffer-name'.
 
+2008-04-24  Luca Capello  <luca@pca.it>  (tiny change)
+
+        * mm-encode.el (mm-safer-encoding): Add optional argument `type'.
+        Don't use QP for message/rfc822.
+        (mm-content-transfer-encoding): Pass `type' to mm-safer-encoding.
+
 2008-04-24  Stefan Monnier  <monnier@iro.umontreal.ca>
 
         * sieve-manage.el (sieve-string-bytes): Remove.
diff --git a/lisp/gnus/auth-source.el b/lisp/gnus/auth-source.el
index 9883eb64acc..a2a4dcf24cc 100644
--- a/lisp/gnus/auth-source.el
+++ b/lisp/gnus/auth-source.el
@@ -86,11 +86,6 @@ Each entry is the authentication type with optional properties."
                  (list :tag "Source definition"
                        (const :format "" :value :source)
                        (string :tag "Authentication Source")
-                       (const :format "" :value :server)
-                       (choice :tag "Server (logical name) choice"
-                               (const :tag "Any" t)
-                               (regexp :tag "Server regular expression (TODO)")
-                               (const :tag "Fallback" nil))
                        (const :format "" :value :host)
                        (choice :tag "Host (machine) choice"
                                (const :tag "Any" t)
@@ -118,20 +113,16 @@ Each entry is the authentication type with optional properties."
 ;; (auth-source-user-or-password-imap "password" "imap.myhost.com")
 ;; (auth-source-protocol-defaults 'imap)
 
-(defun auth-source-pick (server host protocol &optional fallback)
-  "Parse `auth-sources' for SERVER, HOST, and PROTOCOL matches.
+(defun auth-source-pick (host protocol &optional fallback)
+  "Parse `auth-sources' for HOST, and PROTOCOL matches.
 
-Returns fallback choices (where SERVER. PROTOCOL or HOST are nil) with FALLBACK t."
+Returns fallback choices (where PROTOCOL or HOST are nil) with FALLBACK t."
   (interactive "sHost: \nsProtocol: \n") ;for testing
   (let (choices)
     (dolist (choice auth-sources)
-      (let ((s (plist-get choice :server))
-            (h (plist-get choice :host))
+      (let ((h (plist-get choice :host))
             (p (plist-get choice :protocol)))
         (when (and
-               (or (equal t s)
-                   (and (stringp s) (string-match s server))
-                   (and fallback (equal s nil)))
                (or (equal t h)
                    (and (stringp h) (string-match h host))
                    (and fallback (equal h nil)))
@@ -142,12 +133,12 @@ Returns fallback choices (where SERVER. PROTOCOL or HOST are nil) with FALLBACK
     (if choices
         choices
       (unless fallback
-        (auth-source-pick server host protocol t)))))
+        (auth-source-pick host protocol t)))))
 
-(defun auth-source-user-or-password (mode server host protocol)
-  "Find user or password (from the string MODE) matching SERVER, HOST, and PROTOCOL."
+(defun auth-source-user-or-password (mode host protocol)
+  "Find user or password (from the string MODE) matching HOST and PROTOCOL."
   (let (found)
-    (dolist (choice (auth-source-pick server host protocol))
+    (dolist (choice (auth-source-pick host protocol))
       (setq found (netrc-machine-user-or-password 
                    mode
                    (plist-get choice :source)
@@ -161,20 +152,20 @@ Returns fallback choices (where SERVER. PROTOCOL or HOST are nil) with FALLBACK
   "Return a list of default ports and names for PROTOCOL."
   (cdr-safe (assoc protocol auth-source-protocols)))
 
-(defun auth-source-user-or-password-imap (mode server host)
-  (auth-source-user-or-password mode server host 'imap))
+(defun auth-source-user-or-password-imap (mode host)
+  (auth-source-user-or-password mode host 'imap))
 
-(defun auth-source-user-or-password-pop3 (mode server host)
-  (auth-source-user-or-password mode server host 'pop3))
+(defun auth-source-user-or-password-pop3 (mode host)
+  (auth-source-user-or-password mode host 'pop3))
 
-(defun auth-source-user-or-password-ssh (mode server host)
-  (auth-source-user-or-password mode server host 'ssh))
+(defun auth-source-user-or-password-ssh (mode host)
+  (auth-source-user-or-password mode host 'ssh))
 
-(defun auth-source-user-or-password-sftp (mode server host)
-  (auth-source-user-or-password mode server host 'sftp))
+(defun auth-source-user-or-password-sftp (mode host)
+  (auth-source-user-or-password mode host 'sftp))
 
-(defun auth-source-user-or-password-smtp (mode server host)
-  (auth-source-user-or-password mode server host 'smtp))
+(defun auth-source-user-or-password-smtp (mode host)
+  (auth-source-user-or-password mode host 'smtp))
 
 (provide 'auth-source)
 
diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el
index fd08d4d1e39..93ee0efce85 100644
--- a/lisp/gnus/gnus-registry.el
+++ b/lisp/gnus/gnus-registry.el
@@ -161,6 +161,17 @@ way."
     (const :tag "Track by subject (Subject: header)" subject)
     (const :tag "Track by sender (From: header)"  sender)))
 
+(defcustom gnus-registry-split-strategy nil
+  "Whether the registry should track extra data about a message.
+The Subject and Sender (From:) headers are currently tracked this
+way."
+  :group 'gnus-registry
+  :type
+  '(choice :tag "Tracking choices"
+           (const :tag "Only use single choices, discard multiple matches" nil)
+           (const :tag "Majority of matches wins" majority)
+           (const :tag "First found wins"  first)))
+
 (defcustom gnus-registry-entry-caching t
   "Whether the registry should cache extra information."
   :group 'gnus-registry
@@ -486,7 +497,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
               nnmail-split-fancy-with-parent-ignore-groups
             (list nnmail-split-fancy-with-parent-ignore-groups)))
          (log-agent "gnus-registry-split-fancy-with-parent")
-         found)
+         found found-full)
 
     ;; this is a big if-else statement.  it uses
     ;; gnus-registry-post-process-groups to filter the results after
@@ -507,9 +518,10 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
              log-agent reference refstr 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 
-                   "references" refstr found)))
-
+                   "references" refstr found found)))
+     
      ;; else: there were no matches, now try the extra tracking by sender
      ((and (gnus-registry-track-sender-p) 
            sender)
@@ -522,6 +534,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
                       (equal sender this-sender))
              (let ((groups (gnus-registry-fetch-groups key)))
                (dolist (group groups)
+                 (push group found-full)
                  (setq found (append (list group) (delete group found)))))
              (push key matches)
              (gnus-message
@@ -531,7 +544,9 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
               log-agent sender found matches))))
        gnus-registry-hashtb)
       ;; filter the found groups and return them
-      (setq found (gnus-registry-post-process-groups "sender" sender found)))
+      ;; the found groups are NOT the full groups
+      (setq found (gnus-registry-post-process-groups 
+                   "sender" sender found found-full)))
       
      ;; else: there were no matches, now try the extra tracking by subject
      ((and (gnus-registry-track-subject-p)
@@ -546,6 +561,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
                       (equal subject this-subject))
              (let ((groups (gnus-registry-fetch-groups key)))
                (dolist (group groups)
+                 (push group found-full)
                  (setq found (append (list group) (delete group found)))))
              (push key matches)
              (gnus-message
@@ -555,10 +571,13 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
               log-agent subject found matches))))
        gnus-registry-hashtb)
       ;; filter the found groups and return them
+      ;; the found groups are NOT the full groups
       (setq found (gnus-registry-post-process-groups 
-                   "subject" subject found))))))
+                   "subject" subject found found-full))))
+    ;; after the (cond) we extract the actual value safely
+    (car-safe found)))
 
-(defun gnus-registry-post-process-groups (mode key groups)
+(defun gnus-registry-post-process-groups (mode key groups groups-full)
   "Modifies GROUPS found by MODE for KEY to determine which ones to follow.
 
 MODE can be 'subject' or 'sender' for example.  The KEY is the
@@ -572,9 +591,28 @@ This is not possible if gnus-registry-use-long-group-names is
 false.  Foreign methods are not supported so they are rejected.
 
 Reduces the list to a single group, or complains if that's not
-possible."
+possible.  Uses `gnus-registry-split-strategy' and GROUPS-FULL if
+necessary."
   (let ((log-agent "gnus-registry-post-process-group")
         out)
+
+    ;; the strategy can be 'first, 'majority, or nil
+    (when (eq gnus-registry-split-strategy 'first)
+      (when groups
+        (setq groups (list (car-safe groups)))))
+
+    (when (eq gnus-registry-split-strategy 'majority)
+      (let ((freq (make-hash-table
+                   :size 256
+                   :test 'equal)))
+        (mapc (lambda(x) (puthash x (1+ (gethash x freq 0)) freq)) groups-full)
+        (setq groups (list (car-safe
+                            (sort
+                             groups
+                             (lambda (a b)
+                               (> (gethash a freq 0)
+                                  (gethash b freq 0)))))))))
+    
     (if gnus-registry-use-long-group-names
         (dolist (group groups)
           (let ((m1 (gnus-find-method-for-group group))
diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el
index a26f885894d..d8633b7a6a4 100644
--- a/lisp/gnus/mail-source.el
+++ b/lisp/gnus/mail-source.el
@@ -36,6 +36,7 @@
   (require 'cl)
   (require 'imap))
 (eval-and-compile
+  (autoload 'auth-source-user-or-password "auth-source")
   (autoload 'pop3-movemail "pop3")
   (autoload 'pop3-get-message-count "pop3")
   (autoload 'nnheader-cancel-timer "nnheader"))
@@ -44,7 +45,6 @@
 
 (defvar display-time-mail-function)
 
-
 (defgroup mail-source nil
   "The mail-fetching library."
   :version "21.1"
@@ -420,6 +420,8 @@ All keywords that can be used must be listed here."))
     "Strip the leading colon off the KEYWORD."
     (intern (substring (symbol-name keyword) 1))))
 
+;; generate a list of variable names paired with nil values
+;; suitable for usage in a `let' form
 (eval-and-compile
   (defun mail-source-bind-1 (type)
     (let* ((defaults (cdr (assq type mail-source-keyword-map)))
@@ -438,14 +440,30 @@ At run time, the mail source specifier SOURCE will be inspected,
 and the variables will be set according to it.  Variables not
 specified will be given default values.
 
+The user and password will be loaded from the auth-source values
+if those are available.  They override the original user and
+password in a second `let' form.
+
 After this is done, BODY will be executed in the scope
-of the `let' form.
+of the second `let' form.
 
 The variables bound and their default values are described by
 the `mail-source-keyword-map' variable."
-  `(let ,(mail-source-bind-1 (car type-source))
+  `(let* ,(mail-source-bind-1 (car type-source))
      (mail-source-set-1 ,(cadr type-source))
-     ,@body))
+     (let ((user (or
+                  (auth-source-user-or-password 
+                   "login"
+                   server             ; this is "host" in auth-sources
+                   ',(car type-source))
+                  user))
+           (password (or
+                      (auth-source-user-or-password 
+                       "password"
+                       server         ; this is "host" in auth-sources
+                       ',(car type-source))
+                      password)))
+       ,@body)))
 
 (put 'mail-source-bind 'lisp-indent-function 1)
 (put 'mail-source-bind 'edebug-form-spec '(sexp body))
@@ -455,6 +473,8 @@ the `mail-source-keyword-map' variable."
          (defaults (cdr (assq type mail-source-keyword-map)))
          default value keyword)
     (while (setq default (pop defaults))
+      ;; for each default :SYMBOL, set SYMBOL to the plist value for :SYMBOL
+      ;; using `mail-source-value' to evaluate the plist value
       (set (mail-source-strip-keyword (setq keyword (car default)))
            (if (setq value (plist-get source keyword))
                (mail-source-value value)
diff --git a/lisp/gnus/mm-encode.el b/lisp/gnus/mm-encode.el
index 2597a5d5d97..3dce8d1920f 100644
--- a/lisp/gnus/mm-encode.el
+++ b/lisp/gnus/mm-encode.el
@@ -96,14 +96,19 @@ This variable should never be set directly, but bound before a call to
       "application/octet-stream"
     (mailcap-extension-to-mime (match-string 0 file))))
 
-(defun mm-safer-encoding (encoding)
+(defun mm-safer-encoding (encoding &optional type)
   "Return an encoding similar to ENCODING but safer than it."
   (cond
    ((eq encoding '7bit) '7bit) ;; 7bit is considered safe.
-   ((memq encoding '(8bit quoted-printable)) 'quoted-printable)
+   ((memq encoding '(8bit quoted-printable))
+    ;; According to RFC2046, 5.2.1, RFC822 Subtype, "quoted-printable" is not
+    ;; a valid encoding for message/rfc822:
+    ;; No encoding other than "7bit", "8bit", or "binary" is permitted for the
+    ;; body of a "message/rfc822" entity.
+    (if (string= type "message/rfc822") '8bit 'quoted-printable))
    ;; The remaining encodings are binary and base64 (and perhaps some
    ;; non-standard ones), which are both turned into base64.
-   (t 'base64)))
+   (t (if (string= type "message/rfc822") 'binary 'base64))))
 
 (defun mm-encode-content-transfer-encoding (encoding &optional type)
   "Encode the current buffer with ENCODING for MIME type TYPE.
@@ -178,7 +183,7 @@ The encoding used is returned."
                             (mm-qp-or-base64)
                           (cadr (car rules)))))
                    (if mm-use-ultra-safe-encoding
-                       (mm-safer-encoding encoding)
+                       (mm-safer-encoding encoding type)
                      encoding))))
         (pop rules)))))