+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-22 Juri Linkov <juri@jurta.org>
* mailcap.el (mailcap-file-default-commands): New function.
(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)
;; (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)))
(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)
"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)
(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
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
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)
(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
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)
(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
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
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))
(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"))
(defvar display-time-mail-function)
-
(defgroup mail-source nil
"The mail-fetching library."
:version "21.1"
"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)))
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))
(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)
projects / gnus / commitdiff