Changes committed gnus/lisp (4 files)
"Ted Zlatanov" <[email protected]>
| Newsgroups | gmane.emacs.gnus.commits |
|---|---|
| Message-ID | <[email protected]> |
Modified: ChangeLog auth-source.el gnus-registry.el mail-source.el * 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. Index: ChangeLog diff -u gnus/lisp/ChangeLog:7.1835 gnus/lisp/ChangeLog:7.1836 --- ChangeLog:7.1835 Thu Apr 24 06:28:03 2008 +++ ChangeLog Fri Apr 25 20:42:18 2008 @@ -1,3 +1,22 @@ +2008-04-25 Teodor Zlatanov <[email protected]> + + * 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-22 Juri Linkov <[email protected]> * mailcap.el (mailcap-file-default-commands): New function. Index: auth-source.el diff -u gnus/lisp/auth-source.el:7.5 gnus/lisp/auth-source.el:7.6 --- auth-source.el:7.5 Wed Apr 9 22:16:17 2008 +++ auth-source.el Fri Apr 25 20:42:18 2008 @@ -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) Index: gnus-registry.el diff -u gnus/lisp/gnus-registry.el:7.57 gnus/lisp/gnus-registry.el:7.58 --- gnus-registry.el:7.57 Thu Apr 24 06:19:21 2008 +++ gnus-registry.el Fri Apr 25 20:42:18 2008 @@ -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)) Index: mail-source.el diff -u gnus/lisp/mail-source.el:7.32 gnus/lisp/mail-source.el:7.33 --- mail-source.el:7.32 Thu Apr 24 06:19:20 2008 +++ mail-source.el Fri Apr 25 20:42:18 2008 @@ -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)