Mercurial > emacs
changeset 94369:86c0a3e7c039
Merge from gnus--devo--0
Revision: emacs@sv.gnu.org/emacs--devo--0--patch-1128
| author | Miles Bader <miles@gnu.org> |
|---|---|
| date | Sat, 26 Apr 2008 04:29:42 +0000 |
| parents | e77a6227476d |
| children | 28e6262d77ad |
| files | lisp/gnus/ChangeLog lisp/gnus/auth-source.el lisp/gnus/gnus-registry.el lisp/gnus/mail-source.el lisp/gnus/mm-encode.el |
| diffstat | 5 files changed, 121 insertions(+), 42 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/gnus/ChangeLog Sat Apr 26 02:46:56 2008 +0000 +++ b/lisp/gnus/ChangeLog Sat Apr 26 04:29:42 2008 +0000 @@ -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.
--- a/lisp/gnus/auth-source.el Sat Apr 26 02:46:56 2008 +0000 +++ b/lisp/gnus/auth-source.el Sat Apr 26 04:29:42 2008 +0000 @@ -86,11 +86,6 @@ (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 @@ ;; (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 @@ (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 @@ "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)
--- a/lisp/gnus/gnus-registry.el Sat Apr 26 02:46:56 2008 +0000 +++ b/lisp/gnus/gnus-registry.el Sat Apr 26 04:29:42 2008 +0000 @@ -161,6 +161,17 @@ (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 @@ 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 @@ 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 @@ (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 @@ 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 @@ (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 @@ 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 @@ 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))
--- a/lisp/gnus/mail-source.el Sat Apr 26 02:46:56 2008 +0000 +++ b/lisp/gnus/mail-source.el Sat Apr 26 04:29:42 2008 +0000 @@ -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 @@ "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 @@ 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 @@ (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)
--- a/lisp/gnus/mm-encode.el Sat Apr 26 02:46:56 2008 +0000 +++ b/lisp/gnus/mm-encode.el Sat Apr 26 04:29:42 2008 +0000 @@ -96,14 +96,19 @@ "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 @@ (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)))))