mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-12-27 10:54:40 +00:00
Merge from gnus--devo--0
Revision: emacs@sv.gnu.org/emacs--devo--0--patch-1128
This commit is contained in:
Miles Bader
parent
1ea193a2b6
commit
58a67d68bf
@ -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.
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)))))
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user