X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmail-source.el;h=f4a9e191010f0264b1135b8351f8539cc2d5b36b;hb=b52037f4a9c6bee1ff556c22750e158da1208d4b;hp=662b999c288cbf7552e102a85cebfd9ef3d10220;hpb=119a867afc587c9261730362a6478fc3801df1b5;p=gnus diff --git a/lisp/mail-source.el b/lisp/mail-source.el index 662b999c2..f4a9e1910 100644 --- a/lisp/mail-source.el +++ b/lisp/mail-source.el @@ -1,7 +1,6 @@ ;;; mail-source.el --- functions for fetching mail -;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, -;; 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1999-2016 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news, mail @@ -25,15 +24,11 @@ ;;; Code: -;; For Emacs < 22.2. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (require 'format-spec) (eval-when-compile (require 'cl) (require 'imap)) -(autoload 'auth-source-user-or-password "auth-source") +(autoload 'auth-source-search "auth-source") (autoload 'pop3-movemail "pop3") (autoload 'pop3-get-message-count "pop3") (autoload 'nnheader-cancel-timer "nnheader") @@ -64,7 +59,7 @@ This variable is a list of mail source specifiers. See Info node `(gnus)Mail Source Specifiers'." :group 'mail-source - :version "23.1" ;; No Gnus + :version "24.4" :link '(custom-manual "(gnus)Mail Source Specifiers") :type `(choice (const :tag "None" nil) @@ -160,7 +155,18 @@ See Info node `(gnus)Mail Source Specifiers'." :value nil (const :tag "Clear" nil) (const starttls) - (const :tag "SSL/TLS" ssl))))) + (const :tag "SSL/TLS" ssl))) + (group :inline t + (const :format "" :value :leave) + (choice :format "\ +%{Leave mail on server%}:\n\t\t%[Value Menu%] %v" + :value nil + (const :tag "\ +Don't leave mails" nil) + (const :tag "\ +Leave all mails" t) + (number :tag "\ +Leave mails for this many days" :value 14))))) (cons :tag "Maildir (qmail, postfix...)" (const :format "" maildir) (checklist :tag "Options" :greedy t @@ -217,34 +223,6 @@ See Info node `(gnus)Mail Source Specifiers'." (const :format "" :value :dontexpunge) (boolean :tag "Dontexpunge")) - (group :inline t - (const :format "" :value :plugged) - (boolean :tag "Plugged")))) - (cons :tag "Webmail server" - (const :format "" webmail) - (checklist :tag "Options" :greedy t - (group :inline t - (const :format "" :value :subtype) - ;; Should be generated from - ;; `webmail-type-definition', but we - ;; can't require webmail without W3. - (choice :tag "Subtype" - :value hotmail - (const hotmail) - (const yahoo) - (const netaddress) - (const netscape) - (const my-deja))) - (group :inline t - (const :format "" :value :user) - (string :tag "User")) - (group :inline t - (const :format "" :value :password) - (string :tag "Password")) - (group :inline t - (const :format "" - :value :dontexpunge) - (boolean :tag "Dontexpunge")) (group :inline t (const :format "" :value :plugged) (boolean :tag "Plugged")))))))) @@ -361,6 +339,7 @@ Common keywords should be listed here.") (:prescript) (:prescript-delay) (:postscript) + ;; note server and port need to come before user and password (:server (getenv "MAILHOST")) (:port 110) (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER"))) @@ -368,12 +347,14 @@ Common keywords should be listed here.") (:function) (:password) (:authentication password) - (:stream nil)) + (:stream nil) + (:leave)) (maildir (:path (or (getenv "MAILDIR") "~/Maildir/")) (:subdirs ("cur" "new")) (:function)) (imap + ;; note server and port need to come before user and password (:server (getenv "MAILHOST")) (:port) (:stream) @@ -387,13 +368,7 @@ Common keywords should be listed here.") (:prescript) (:prescript-delay) (:postscript) - (:dontexpunge)) - (webmail - (:subtype hotmail) - (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER"))) - (:password) - (:dontexpunge) - (:authentication password))) + (:dontexpunge))) "Mapping from keywords to default values. All keywords that can be used must be listed here.")) @@ -402,8 +377,7 @@ All keywords that can be used must be listed here.")) (directory mail-source-fetch-directory) (pop mail-source-fetch-pop) (maildir mail-source-fetch-maildir) - (imap mail-source-fetch-imap) - (webmail mail-source-fetch-webmail)) + (imap mail-source-fetch-imap)) "A mapping from source type to fetcher function.") (defvar mail-source-password-cache nil) @@ -453,42 +427,66 @@ the `mail-source-keyword-map' variable." (put 'mail-source-bind 'lisp-indent-function 1) (put 'mail-source-bind 'edebug-form-spec '(sexp body)) -;; TODO: use the list format for auth-source-user-or-password modes (defun mail-source-set-1 (source) (let* ((type (pop source)) - (defaults (cdr (assq type mail-source-keyword-map))) - default value keyword auth-info user-auth pass-auth) + (defaults (cdr (assq type mail-source-keyword-map))) + (search '(:max 1)) + found default value keyword auth-info user-auth pass-auth) + + ;; append to the search the useful info from the source and the defaults: + ;; user, host, and port + + ;; the msname is the mail-source parameter + (dolist (msname '(:server :user :port)) + ;; the asname is the auth-source parameter + (let* ((asname (case msname + (:server :host) ; auth-source uses :host + (t msname))) + ;; this is the mail-source default + (msdef1 (or (plist-get source msname) + (nth 1 (assoc msname defaults)))) + ;; ...evaluated + (msdef (mail-source-value msdef1))) + (setq search (append (list asname + (if msdef msdef t)) + search)))) + ;; if the port is unknown yet, get it from the mail-source type + (unless (plist-get search :port) + (setq search (append (list :port (symbol-name type))))) + (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))) - ;; note the following reasons for this structure: - ;; 1) the auth-sources user and password override everything - ;; 2) it avoids macros, so it's cleaner - ;; 3) it falls through to the mail-sources and then default values - (cond - ((and - (eq keyword :user) - (setq user-auth - (nth 0 (auth-source-user-or-password - '("login" "password") - ;; this is "host" in auth-sources - (if (boundp 'server) (symbol-value 'server) "") - type)))) - user-auth) - ((and - (eq keyword :password) - (setq pass-auth - (nth 1 - (auth-source-user-or-password - '("login" "password") - ;; this is "host" in auth-sources - (if (boundp 'server) (symbol-value 'server) "") - type)))) - pass-auth) - (t (if (setq value (plist-get source keyword)) - (mail-source-value value) - (mail-source-value (cadr default))))))))) + ;; note the following reasons for this structure: + ;; 1) the auth-sources user and password override everything + ;; 2) it avoids macros, so it's cleaner + ;; 3) it falls through to the mail-sources and then default values + (cond + ((and + (eq keyword :user) + (setq user-auth (plist-get + ;; cache the search result in `found' + (or found + (setq found (nth 0 (apply 'auth-source-search + search)))) + :user))) + user-auth) + ((and + (eq keyword :password) + (setq pass-auth (plist-get + ;; cache the search result in `found' + (or found + (setq found (nth 0 (apply 'auth-source-search + search)))) + :secret))) + ;; maybe set the password to the return of the :secret function + (if (functionp pass-auth) + (setq pass-auth (funcall pass-auth)) + pass-auth)) + (t (if (setq value (plist-get source keyword)) + (mail-source-value value) + (mail-source-value (cadr default))))))))) (eval-and-compile (defun mail-source-bind-common-1 () @@ -536,6 +534,8 @@ See `mail-source-bind'." (t value))) +(autoload 'nnheader-message "nnheader") + (defun mail-source-fetch (source callback &optional method) "Fetch mail from SOURCE and call CALLBACK zero or more times. CALLBACK will be called with the name of the file where (some of) @@ -612,7 +612,7 @@ If CONFIRM is non-nil, ask for confirmation before removing a file." (when (and (> (- currday fileday) diff) (if confirm (y-or-n-p - (format "\ + (gnus-format-message "\ Delete old (> %s day(s)) incoming mail file `%s'? " diff bfile)) (gnus-message 8 "\ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) @@ -629,6 +629,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) 0) (funcall callback mail-source-crash-box info))) +(autoload 'gnus-float-time "gnus-util") + (defvar mail-source-incoming-last-checked-time nil) (defun mail-source-delete-crash-box () @@ -649,7 +651,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) ;; Don't check for old incoming files more than once per day to ;; save a lot of file accesses. (when (or (null mail-source-incoming-last-checked-time) - (> (time-to-seconds + (> (gnus-float-time (time-since mail-source-incoming-last-checked-time)) (* 24 60 60))) (setq mail-source-incoming-last-checked-time (current-time)) @@ -727,12 +729,6 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) ;; Return whether we moved successfully or not. to))) -(defun mail-source-movemail-and-remove (from to) - "Move FROM to TO using movemail, then remove FROM if empty." - (or (not (mail-source-movemail from to)) - (not (zerop (nth 7 (file-attributes from)))) - (delete-file from))) - (defun mail-source-fetch-with-program (program) (eq 0 (call-process shell-file-name nil nil nil shell-command-switch program))) @@ -754,13 +750,16 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (setq script (substring script 0 (match-beginning 0)) background 0)) (setq result - (call-process shell-file-name nil background nil + (call-process shell-file-name nil stderr nil shell-command-switch script)) - (when (and result - (not (zerop result))) - (set-buffer stderr) - (message "Mail source error: %s" (buffer-string))) - (kill-buffer stderr))) + (if (and result + (not (zerop result))) + (progn + (split-window-vertically) + (other-window 1) + (switch-to-buffer stderr) + (message "Mail source error: %s " (buffer-string))) + (kill-buffer stderr)))) ;;; ;;; Different fetchers @@ -809,6 +808,10 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) prescript-delay) (let ((from (format "%s:%s:%s" server user port)) (mail-source-string (format "pop:%s@%s" user server)) + (process-environment (if server + (cons (concat "MAILHOST=" server) + process-environment) + process-environment)) result) (when (eq authentication 'password) (setq password @@ -816,8 +819,6 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (cdr (assoc from mail-source-password-cache)) (read-passwd (format "Password for %s at %s: " user server))))) - (when server - (setenv "MAILHOST" server)) (setq result (cond (program @@ -837,7 +838,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (pop3-port port) (pop3-authentication-scheme (if (eq authentication 'apop) 'apop 'pass)) - (pop3-stream-type stream)) + (pop3-stream-type stream) + (pop3-leave-mail-on-server leave)) (if (or debug-on-quit debug-on-error) (save-excursion (pop3-movemail mail-source-crash-box)) (condition-case err @@ -876,6 +878,10 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (mail-source-bind (pop source) (let ((from (format "%s:%s:%s" server user port)) (mail-source-string (format "pop:%s@%s" user server)) + (process-environment (if server + (cons (concat "MAILHOST=" server) + process-environment) + process-environment)) result) (when (eq authentication 'password) (setq password @@ -885,8 +891,6 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (format "Password for %s at %s: " user server)))) (unless (assoc from mail-source-password-cache) (push (cons from password) mail-source-password-cache))) - (when server - (setenv "MAILHOST" server)) (setq result (cond ;; No easy way to check whether mail is waiting for these. @@ -930,7 +934,7 @@ authentication. To do that, you need to set the `message-send-mail-function' variable as `message-smtpmail-send-it' and put the following line in your ~/.gnus.el file: -\(add-hook 'message-send-mail-hook 'mail-source-touch-pop) +\(add-hook \\='message-send-mail-hook \\='mail-source-touch-pop) See the Gnus manual for details." (let ((sources (if mail-source-primary-source @@ -993,7 +997,7 @@ This only works when `display-time' is enabled." (if on (progn (require 'time) - ;; display-time-mail-function is an Emacs 21 feature. + ;; display-time-mail-function is an Emacs feature. (setq display-time-mail-function #'mail-source-new-mail-p) ;; Set up the main timer. (setq mail-source-report-new-mail-timer @@ -1023,6 +1027,7 @@ This only works when `display-time' is enabled." (dolist (file (directory-files (concat path subdir) t)) (when (and (not (file-directory-p file)) (not (if function + ;; `function' should return nil if successful. (funcall function file mail-source-crash-box) (let ((coding-system-for-write mm-text-coding-system) @@ -1041,7 +1046,8 @@ This only works when `display-time' is enabled." ;;; (insert "\n\n") ;; MMDF mail format (insert "\001\001\001\001\n")) - (delete-file file))))) + (delete-file file) + nil)))) (incf found (mail-source-callback callback file)) (mail-source-delete-crash-box))))) found))) @@ -1084,10 +1090,13 @@ This only works when `display-time' is enabled." (if (and (imap-open server port stream authentication buf) (imap-authenticate user (or (cdr (assoc from mail-source-password-cache)) - password) buf) - (imap-mailbox-select mailbox nil buf)) + password) buf)) + (let ((mailbox-list (if (listp mailbox) mailbox (list mailbox)))) + (dolist (mailbox mailbox-list) + (when (imap-mailbox-select mailbox nil buf) (let ((coding-system-for-write mail-source-imap-file-coding-system) str) + (message "Fetching from %s..." mailbox) (with-temp-file mail-source-crash-box ;; Avoid converting 8-bit chars from inserted strings to ;; multibyte. @@ -1122,8 +1131,8 @@ This only works when `display-time' is enabled." fetchflag nil buf)) (if dontexpunge (imap-mailbox-unselect buf) - (imap-mailbox-close nil buf)) - (imap-close buf)) + (imap-mailbox-close nil buf))))) + (imap-close buf)) (imap-close buf) ;; We nix out the password in case the error ;; was because of a wrong password being given. @@ -1138,30 +1147,6 @@ This only works when `display-time' is enabled." ?s server ?P port ?u user)) found))) -(autoload 'webmail-fetch "webmail") - -(defun mail-source-fetch-webmail (source callback) - "Fetch for webmail source." - (mail-source-bind (webmail source) - (let ((mail-source-string (format "webmail:%s:%s" subtype user)) - (webmail-newmail-only dontexpunge) - (webmail-move-to-trash-can (not dontexpunge))) - (when (eq authentication 'password) - (setq password - (or password - (cdr (assoc (format "webmail:%s:%s" subtype user) - mail-source-password-cache)) - (read-passwd - (format "Password for %s at %s: " user subtype)))) - (when (and password - (not (assoc (format "webmail:%s:%s" subtype user) - mail-source-password-cache))) - (push (cons (format "webmail:%s:%s" subtype user) password) - mail-source-password-cache))) - (webmail-fetch mail-source-crash-box subtype user password) - (mail-source-callback callback (symbol-name subtype)) - (mail-source-delete-crash-box)))) - (provide 'mail-source) ;;; mail-source.el ends here