;;; mail-source.el --- functions for fetching mail
-;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc.
+
+;; Copyright (C) 1999-2015 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news, mail
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
+(require 'format-spec)
(eval-when-compile
(require 'cl)
- (require 'imap)
- (eval-when-compile (defvar display-time-mail-function)))
-(eval-and-compile
- (autoload 'pop3-movemail "pop3")
- (autoload 'pop3-get-message-count "pop3")
- (autoload 'nnheader-cancel-timer "nnheader")
- (autoload 'nnheader-run-at-time "nnheader"))
-(require 'format-spec)
+ (require 'imap))
+(autoload 'auth-source-search "auth-source")
+(autoload 'pop3-movemail "pop3")
+(autoload 'pop3-get-message-count "pop3")
+(autoload 'nnheader-cancel-timer "nnheader")
(require 'mm-util)
(require 'message) ;; for `message-directory'
+(defvar display-time-mail-function)
+
(defgroup mail-source nil
"The mail-fetching library."
:version "21.1"
(list 'const (car a)))
imap-stream-alist)))
-(defcustom mail-sources nil
- "*Where the mail backends will look for incoming mail.
+(defcustom mail-sources '((file))
+ "Where the mail backends will look for incoming mail.
This variable is a list of mail source specifiers.
See Info node `(gnus)Mail Source Specifiers'."
:group 'mail-source
- :type `(repeat
- (choice :format "%[Value Menu%] %v"
- :value (file)
- (cons :tag "Spool file"
- (const :format "" file)
- (checklist :tag "Options" :greedy t
- (group :inline t
- (const :format "" :value :path)
- file)))
- (cons :tag "Several files in a directory"
- (const :format "" directory)
- (checklist :tag "Options" :greedy t
- (group :inline t
- (const :format "" :value :path)
- (directory :tag "Path"))
- (group :inline t
- (const :format "" :value :suffix)
- (string :tag "Suffix"))
- (group :inline t
- (const :format "" :value :predicate)
- (function :tag "Predicate"))
- (group :inline t
- (const :format "" :value :prescript)
- (string :tag "Prescript"))
- (group :inline t
- (const :format "" :value :postscript)
- (string :tag "Postscript"))
- (group :inline t
- (const :format "" :value :plugged)
- (boolean :tag "Plugged"))))
- (cons :tag "POP3 server"
- (const :format "" pop)
- (checklist :tag "Options" :greedy t
- (group :inline t
- (const :format "" :value :server)
- (string :tag "Server"))
- (group :inline t
- (const :format "" :value :port)
- (choice :tag "Port"
- :value "pop3"
- (number :format "%v")
- (string :format "%v")))
- (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 :program)
- (string :tag "Program"))
- (group :inline t
- (const :format "" :value :prescript)
- (string :tag "Prescript"))
- (group :inline t
- (const :format "" :value :postscript)
- (string :tag "Postscript"))
- (group :inline t
- (const :format "" :value :function)
- (function :tag "Function"))
- (group :inline t
- (const :format ""
- :value :authentication)
- (choice :tag "Authentication"
- :value apop
- (const password)
- (const apop)))
- (group :inline t
- (const :format "" :value :plugged)
- (boolean :tag "Plugged"))))
- (cons :tag "Maildir (qmail, postfix...)"
- (const :format "" maildir)
- (checklist :tag "Options" :greedy t
- (group :inline t
- (const :format "" :value :path)
- (directory :tag "Path"))
- (group :inline t
- (const :format "" :value :plugged)
- (boolean :tag "Plugged"))))
- (cons :tag "IMAP server"
- (const :format "" imap)
- (checklist :tag "Options" :greedy t
- (group :inline t
- (const :format "" :value :server)
- (string :tag "Server"))
- (group :inline t
- (const :format "" :value :port)
- (choice :tag "Port"
- :value 143
- number string))
- (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 :stream)
- (choice :tag "Stream"
- :value network
- ,@mail-source-imap-streams))
- (group :inline t
- (const :format "" :value :program)
- (string :tag "Program"))
- (group :inline t
- (const :format ""
- :value :authenticator)
- (choice :tag "Authenticator"
- :value login
- ,@mail-source-imap-authenticators))
- (group :inline t
- (const :format "" :value :mailbox)
- (string :tag "Mailbox"
- :value "INBOX"))
- (group :inline t
- (const :format "" :value :predicate)
- (string :tag "Predicate"
- :value "UNSEEN UNDELETED"))
- (group :inline t
- (const :format "" :value :fetchflag)
- (string :tag "Fetchflag"
- :value "\\Deleted"))
- (group :inline t
- (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")))))))
+ :version "24.4"
+ :link '(custom-manual "(gnus)Mail Source Specifiers")
+ :type `(choice
+ (const :tag "None" nil)
+ (repeat :tag "List"
+ (choice :format "%[Value Menu%] %v"
+ :value (file)
+ (cons :tag "Group parameter `mail-source'"
+ (const :format "" group))
+ (cons :tag "Spool file"
+ (const :format "" file)
+ (checklist :tag "Options" :greedy t
+ (group :inline t
+ (const :format "" :value :path)
+ file)))
+ (cons :tag "Several files in a directory"
+ (const :format "" directory)
+ (checklist :tag "Options" :greedy t
+ (group :inline t
+ (const :format "" :value :path)
+ (directory :tag "Path"))
+ (group :inline t
+ (const :format "" :value :suffix)
+ (string :tag "Suffix"))
+ (group :inline t
+ (const :format "" :value :predicate)
+ (function :tag "Predicate"))
+ (group :inline t
+ (const :format "" :value :prescript)
+ (choice :tag "Prescript"
+ :value nil
+ (string :format "%v")
+ (function :format "%v")))
+ (group :inline t
+ (const :format "" :value :postscript)
+ (choice :tag "Postscript"
+ :value nil
+ (string :format "%v")
+ (function :format "%v")))
+ (group :inline t
+ (const :format "" :value :plugged)
+ (boolean :tag "Plugged"))))
+ (cons :tag "POP3 server"
+ (const :format "" pop)
+ (checklist :tag "Options" :greedy t
+ (group :inline t
+ (const :format "" :value :server)
+ (string :tag "Server"))
+ (group :inline t
+ (const :format "" :value :port)
+ (choice :tag "Port"
+ :value "pop3"
+ (integer :format "%v")
+ (string :format "%v")))
+ (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 :program)
+ (string :tag "Program"))
+ (group :inline t
+ (const :format "" :value :prescript)
+ (choice :tag "Prescript"
+ :value nil
+ (string :format "%v")
+ (function :format "%v")
+ (const :tag "None" nil)))
+ (group :inline t
+ (const :format "" :value :postscript)
+ (choice :tag "Postscript"
+ :value nil
+ (string :format "%v")
+ (function :format "%v")
+ (const :tag "None" nil)))
+ (group :inline t
+ (const :format "" :value :function)
+ (function :tag "Function"))
+ (group :inline t
+ (const :format ""
+ :value :authentication)
+ (choice :tag "Authentication"
+ :value apop
+ (const password)
+ (const apop)))
+ (group :inline t
+ (const :format "" :value :plugged)
+ (boolean :tag "Plugged"))
+ (group :inline t
+ (const :format "" :value :stream)
+ (choice :tag "Stream"
+ :value nil
+ (const :tag "Clear" nil)
+ (const starttls)
+ (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
+ (group :inline t
+ (const :format "" :value :path)
+ (directory :tag "Path"))
+ (group :inline t
+ (const :format "" :value :plugged)
+ (boolean :tag "Plugged"))))
+ (cons :tag "IMAP server"
+ (const :format "" imap)
+ (checklist :tag "Options" :greedy t
+ (group :inline t
+ (const :format "" :value :server)
+ (string :tag "Server"))
+ (group :inline t
+ (const :format "" :value :port)
+ (choice :tag "Port"
+ :value 143
+ integer string))
+ (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 :stream)
+ (choice :tag "Stream"
+ :value network
+ ,@mail-source-imap-streams))
+ (group :inline t
+ (const :format "" :value :program)
+ (string :tag "Program"))
+ (group :inline t
+ (const :format ""
+ :value :authenticator)
+ (choice :tag "Authenticator"
+ :value login
+ ,@mail-source-imap-authenticators))
+ (group :inline t
+ (const :format "" :value :mailbox)
+ (string :tag "Mailbox"
+ :value "INBOX"))
+ (group :inline t
+ (const :format "" :value :predicate)
+ (string :tag "Predicate"
+ :value "UNSEEN UNDELETED"))
+ (group :inline t
+ (const :format "" :value :fetchflag)
+ (string :tag "Fetchflag"
+ :value "\\Deleted"))
+ (group :inline t
+ (const :format ""
+ :value :dontexpunge)
+ (boolean :tag "Dontexpunge"))
+ (group :inline t
+ (const :format "" :value :plugged)
+ (boolean :tag "Plugged"))))))))
+
+(defcustom mail-source-ignore-errors nil
+ "*Ignore errors when querying mail sources.
+If nil, the user will be prompted when an error occurs. If non-nil,
+the error will be ignored."
+ :version "22.1"
+ :group 'mail-source
+ :type 'boolean)
(defcustom mail-source-primary-source nil
"*Primary source for incoming mail.
:group 'mail-source
:type 'sexp)
+(defcustom mail-source-flash t
+ "*If non-nil, flash periodically when mail is available."
+ :group 'mail-source
+ :type 'boolean)
+
(defcustom mail-source-crash-box "~/.emacs-mail-crash-box"
"File where mail will be stored while processing it."
:group 'mail-source
:type 'file)
(defcustom mail-source-directory message-directory
- "Directory where files (if any) will be stored."
+ "Directory where incoming mail source files (if any) will be stored."
:group 'mail-source
:type 'directory)
:group 'mail-source
:type 'integer)
-(defcustom mail-source-delete-incoming nil
- "*If non-nil, delete incoming files after handling."
+(defcustom mail-source-delete-incoming
+ 10 ;; development versions
+ ;; 2 ;; released versions
+ "If non-nil, delete incoming files after handling.
+If t, delete immediately, if nil, never delete. If a positive number, delete
+files older than number of days.
+
+Removing of old files happens in `mail-source-callback', i.e. no
+old incoming files will be deleted unless you receive new mail.
+You may also set this variable to nil and call
+`mail-source-delete-old-incoming' interactively."
+ :group 'mail-source
+ :version "22.2" ;; No Gnus / Gnus 5.10.10 (default changed)
+ :type '(choice (const :tag "immediately" t)
+ (const :tag "never" nil)
+ (integer :tag "days")))
+
+(defcustom mail-source-delete-old-incoming-confirm nil
+ "If non-nil, ask for confirmation before deleting old incoming files.
+This variable only applies when `mail-source-delete-incoming' is a positive
+number."
+ :version "22.2" ;; No Gnus / Gnus 5.10.10 (default changed)
:group 'mail-source
:type 'boolean)
:group 'mail-source
:type 'number)
+(defcustom mail-source-movemail-program nil
+ "If non-nil, name of program for fetching new mail."
+ :version "22.1"
+ :group 'mail-source
+ :type '(choice (const nil) string))
+
;;; Internal variables.
(defvar mail-source-string ""
(:path (or (getenv "MAIL")
(expand-file-name (user-login-name) rmail-spool-directory))))
(directory
+ (:prescript)
+ (:prescript-delay)
+ (:postscript)
(:path)
(:suffix ".spool")
(:predicate identity))
(: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")))
(:program)
(:function)
(:password)
- (:authentication password))
+ (:authentication password)
+ (:stream nil)
+ (:leave))
(maildir
(:path (or (getenv "MAILDIR") "~/Maildir/"))
- (:subdirs ("new" "cur"))
+ (:subdirs ("cur" "new"))
(:function))
(imap
+ ;; note server and port need to come before user and password
(:server (getenv "MAILHOST"))
(:port)
(:stream)
(:mailbox "INBOX")
(:predicate "UNSEEN UNDELETED")
(:fetchflag "\\Deleted")
- (:dontexpunge))
- (webmail
- (:subtype hotmail)
- (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
- (:password)
- (:dontexpunge)
- (:authentication password)))
+ (:prescript)
+ (:prescript-delay)
+ (:postscript)
+ (:dontexpunge)))
"Mapping from keywords to default values.
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)
"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))
(put 'mail-source-bind 'lisp-indent-function 1)
-(put 'mail-source-bind 'edebug-form-spec '(form body))
+(put 'mail-source-bind 'edebug-form-spec '(sexp body))
(defun mail-source-set-1 (source)
(let* ((type (pop source))
- (defaults (cdr (assq type mail-source-keyword-map)))
- default value keyword)
+ (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)))
- (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 ()
,@body))
(put 'mail-source-bind-common 'lisp-indent-function 1)
-(put 'mail-source-bind-common 'edebug-form-spec '(form body))
+(put 'mail-source-bind-common 'edebug-form-spec '(sexp body))
(defun mail-source-value (value)
"Return the value of VALUE."
((stringp value)
value)
;; Function
- ((and (listp value)
- (functionp (car value)))
+ ((and (listp value) (symbolp (car value)) (fboundp (car value)))
(eval value))
;; Just return the value.
(t
value)))
-(defun mail-source-fetch (source callback)
+(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)
the mail from SOURCE is put.
(mail-source-bind-common source
(if (or mail-source-plugged plugged)
(save-excursion
+ ;; Special-case the `file' handler since it's so common and
+ ;; just adds noise.
+ (when (or (not (eq (car source) 'file))
+ (mail-source-bind (file source)
+ (file-exists-p path)))
+ (nnheader-message 4 "%sReading incoming mail from %s..."
+ (if method
+ (format "%s: " method)
+ "")
+ (car source)))
(let ((function (cadr (assq (car source) mail-source-fetcher-alist)))
(found 0))
(unless function
(when (file-exists-p mail-source-crash-box)
(message "Processing mail from %s..." mail-source-crash-box)
(setq found (mail-source-callback
- callback mail-source-crash-box)))
+ callback mail-source-crash-box))
+ (mail-source-delete-crash-box))
(+ found
- (condition-case err
+ (if (or debug-on-quit debug-on-error)
(funcall function source callback)
- (error
- (unless (yes-or-no-p
- (format "Mail source error (%s). Continue? " err))
- (error "Cannot get new mail"))
- 0))))))))
-
-(defun mail-source-make-complex-temp-name (prefix)
- (let ((newname (make-temp-name prefix))
- (newprefix prefix))
- (while (file-exists-p newname)
- (setq newprefix (concat newprefix "x"))
- (setq newname (make-temp-name newprefix)))
- newname))
+ (condition-case err
+ (funcall function source callback)
+ (error
+ (if (and (not mail-source-ignore-errors)
+ (not
+ (yes-or-no-p
+ (format "Mail source %s error (%s). Continue? "
+ (if (memq ':password source)
+ (let ((s (copy-sequence source)))
+ (setcar (cdr (memq ':password s))
+ "********")
+ s)
+ source)
+ (cadr err)))))
+ (error "Cannot get new mail"))
+ 0)))))))))
+
+(declare-function gnus-message "gnus-util" (level &rest args))
+
+(defun mail-source-delete-old-incoming (&optional age confirm)
+ "Remove incoming files older than AGE days.
+If CONFIRM is non-nil, ask for confirmation before removing a file."
+ (interactive "P")
+ (require 'gnus-util)
+ (let* ((high2days (/ 65536.0 60 60 24));; convert high bits to days
+ (low2days (/ 1.0 65536.0)) ;; convert low bits to days
+ (diff (if (natnump age) age 30));; fallback, if no valid AGE given
+ currday files)
+ (setq files (directory-files
+ mail-source-directory t
+ (concat "\\`"
+ (regexp-quote mail-source-incoming-file-prefix)))
+ currday (* (car (current-time)) high2days)
+ currday (+ currday (* low2days (nth 1 (current-time)))))
+ (while files
+ (let* ((ffile (car files))
+ (bfile (gnus-replace-in-string
+ ffile "\\`.*/\\([^/]+\\)\\'" "\\1"))
+ (filetime (nth 5 (file-attributes ffile)))
+ (fileday (* (car filetime) high2days))
+ (fileday (+ fileday (* low2days (nth 1 filetime)))))
+ (setq files (cdr files))
+ (when (and (> (- currday fileday) diff)
+ (if confirm
+ (y-or-n-p
+ (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)
+ t))
+ (delete-file ffile))))))
(defun mail-source-callback (callback info)
- "Call CALLBACK on the mail file, and then remove the mail file.
-Pass INFO on to CALLBACK."
+ "Call CALLBACK on the mail file. Pass INFO on to CALLBACK."
(if (or (not (file-exists-p mail-source-crash-box))
(zerop (nth 7 (file-attributes mail-source-crash-box))))
(progn
(when (file-exists-p mail-source-crash-box)
(delete-file mail-source-crash-box))
0)
- (prog1
- (funcall callback mail-source-crash-box info)
- (when (file-exists-p mail-source-crash-box)
- ;; Delete or move the incoming mail out of the way.
- (if mail-source-delete-incoming
- (delete-file mail-source-crash-box)
- (let ((incoming
- (mail-source-make-complex-temp-name
- (expand-file-name
- mail-source-incoming-file-prefix
- mail-source-directory))))
- (unless (file-exists-p (file-name-directory incoming))
- (make-directory (file-name-directory incoming) t))
- (rename-file mail-source-crash-box incoming t)))))))
+ (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 ()
+ (when (file-exists-p mail-source-crash-box)
+ ;; Delete or move the incoming mail out of the way.
+ (if (eq mail-source-delete-incoming t)
+ (delete-file mail-source-crash-box)
+ (let ((incoming
+ (mm-make-temp-file
+ (expand-file-name
+ mail-source-incoming-file-prefix
+ mail-source-directory))))
+ (unless (file-exists-p (file-name-directory incoming))
+ (make-directory (file-name-directory incoming) t))
+ (rename-file mail-source-crash-box incoming t)
+ ;; remove old incoming files?
+ (when (natnump mail-source-delete-incoming)
+ ;; 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)
+ (> (gnus-float-time
+ (time-since mail-source-incoming-last-checked-time))
+ (* 24 60 60)))
+ (setq mail-source-incoming-last-checked-time (current-time))
+ (mail-source-delete-old-incoming
+ mail-source-delete-incoming
+ mail-source-delete-old-incoming-confirm)))))))
(defun mail-source-movemail (from to)
"Move FROM to TO using movemail."
'call-process
(append
(list
- (expand-file-name "movemail" exec-directory)
+ (or mail-source-movemail-program
+ (expand-file-name "movemail" exec-directory))
nil errors nil from to)))))
(when (file-exists-p to)
(set-file-modes to mail-source-default-file-modes))
- (if (and (not (buffer-modified-p errors))
- (zerop result))
+ (if (and (or (not (buffer-modified-p errors))
+ (zerop (buffer-size errors)))
+ (and (numberp result)
+ (zerop result)))
;; No output => movemail won.
t
(set-buffer errors)
;; 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)))
-
-(defvar mail-source-read-passwd nil)
-(defun mail-source-read-passwd (prompt &rest args)
- "Read a password using PROMPT.
-If ARGS, PROMPT is used as an argument to `format'."
- (let ((prompt
- (if args
- (apply 'format prompt args)
- prompt)))
- (unless mail-source-read-passwd
- (if (or (fboundp 'read-passwd) (load "passwd" t))
- (setq mail-source-read-passwd 'read-passwd)
- (unless (fboundp 'ange-ftp-read-passwd)
- (autoload 'ange-ftp-read-passwd "ange-ftp"))
- (setq mail-source-read-passwd 'ange-ftp-read-passwd)))
- (funcall mail-source-read-passwd prompt)))
-
(defun mail-source-fetch-with-program (program)
- (zerop (call-process shell-file-name nil nil nil
- shell-command-switch program)))
+ (eq 0 (call-process shell-file-name nil nil nil
+ shell-command-switch program)))
(defun mail-source-run-script (script spec &optional delay)
(when script
- (if (and (symbolp script) (fboundp script))
+ (if (functionp script)
(funcall script)
(mail-source-call-script
(format-spec script spec))))
(sleep-for delay)))
(defun mail-source-call-script (script)
- (let ((background nil))
+ (let ((background nil)
+ (stderr (get-buffer-create " *mail-source-stderr*"))
+ result)
(when (string-match "& *$" script)
(setq script (substring script 0 (match-beginning 0))
background 0))
- (call-process shell-file-name nil background nil
- shell-command-switch script)))
+ (setq result
+ (call-process shell-file-name nil stderr nil
+ shell-command-switch script))
+ (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
(prog1
(mail-source-callback callback path)
(mail-source-run-script
- postscript (format-spec-make ?t mail-source-crash-box)))
+ postscript (format-spec-make ?t mail-source-crash-box))
+ (mail-source-delete-crash-box))
0))))
(defun mail-source-fetch-directory (source callback)
"Fetcher for directory sources."
(mail-source-bind (directory source)
+ (mail-source-run-script
+ prescript (format-spec-make ?t path) prescript-delay)
(let ((found 0)
(mail-source-string (format "directory:%s" path)))
(dolist (file (directory-files
(when (and (file-regular-p file)
(funcall predicate file)
(mail-source-movemail file mail-source-crash-box))
- (incf found (mail-source-callback callback file))))
+ (incf found (mail-source-callback callback file))
+ (mail-source-run-script postscript (format-spec-make ?t path))
+ (mail-source-delete-crash-box)))
found)))
(defun mail-source-fetch-pop (source callback)
"Fetcher for single-file sources."
(mail-source-bind (pop source)
+ ;; fixme: deal with stream type in format specs
(mail-source-run-script
prescript
(format-spec-make ?p password ?t mail-source-crash-box
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
(or password
(cdr (assoc from mail-source-password-cache))
- (mail-source-read-passwd
+ (read-passwd
(format "Password for %s at %s: " user server)))))
- (when server
- (setenv "MAILHOST" server))
(setq result
(cond
(program
(funcall function mail-source-crash-box))
;; The default is to use pop3.el.
(t
+ (require 'pop3)
(let ((pop3-password password)
(pop3-maildrop user)
(pop3-mailhost server)
(pop3-port port)
(pop3-authentication-scheme
- (if (eq authentication 'apop) 'apop 'pass)))
- (condition-case err
+ (if (eq authentication 'apop) 'apop 'pass))
+ (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))
- (error
- ;; We nix out the password in case the error
- ;; was because of a wrong password being given.
- (setq mail-source-password-cache
- (delq (assoc from mail-source-password-cache)
- mail-source-password-cache))
- (signal (car err) (cdr err))))))))
+ (condition-case err
+ (save-excursion (pop3-movemail mail-source-crash-box))
+ (error
+ ;; We nix out the password in case the error
+ ;; was because of a wrong password being given.
+ (setq mail-source-password-cache
+ (delq (assoc from mail-source-password-cache)
+ mail-source-password-cache))
+ (signal (car err) (cdr err)))))))))
(if result
(progn
(when (eq authentication 'password)
(mail-source-run-script
postscript
(format-spec-make ?p password ?t mail-source-crash-box
- ?s server ?P port ?u user))))
+ ?s server ?P port ?u user))
+ (mail-source-delete-crash-box)))
;; We nix out the password in case the error
;; was because of a wrong password being given.
(setq mail-source-password-cache
(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
(or password
(cdr (assoc from mail-source-password-cache))
- (mail-source-read-passwd
+ (read-passwd
(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.
(function)
;; The default is to use pop3.el.
(t
+ (require 'pop3)
(let ((pop3-password password)
(pop3-maildrop user)
(pop3-mailhost server)
(pop3-port port)
(pop3-authentication-scheme
(if (eq authentication 'apop) 'apop 'pass)))
- (condition-case err
+ (if (or debug-on-quit debug-on-error)
(save-excursion (pop3-get-message-count))
- (error
- ;; We nix out the password in case the error
- ;; was because of a wrong password being given.
- (setq mail-source-password-cache
- (delq (assoc from mail-source-password-cache)
- mail-source-password-cache))
- (signal (car err) (cdr err))))))))
+ (condition-case err
+ (save-excursion (pop3-get-message-count))
+ (error
+ ;; We nix out the password in case the error
+ ;; was because of a wrong password being given.
+ (setq mail-source-password-cache
+ (delq (assoc from mail-source-password-cache)
+ mail-source-password-cache))
+ (signal (car err) (cdr err)))))))))
(if result
;; Inform display-time that we have new mail.
(setq mail-source-new-mail-available (> result 0))
mail-source-password-cache)))
result)))
+(defun mail-source-touch-pop ()
+ "Open and close a POP connection shortly.
+POP server should be defined in `mail-source-primary-source' (which is
+preferred) or `mail-sources'. You may use it for the POP-before-SMTP
+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)
+
+See the Gnus manual for details."
+ (let ((sources (if mail-source-primary-source
+ (list mail-source-primary-source)
+ mail-sources)))
+ (while sources
+ (if (eq 'pop (car (car sources)))
+ (mail-source-check-pop (car sources)))
+ (setq sources (cdr sources)))))
+
(defun mail-source-new-mail-p ()
"Handler for `display-time' to indicate when new mail is available."
+ ;; Flash (ie. ring the visible bell) if mail is available.
+ (if (and mail-source-flash mail-source-new-mail-available)
+ (let ((visible-bell t))
+ (ding)))
;; Only report flag setting; flag is updated on a different schedule.
mail-source-new-mail-available)
(defvar mail-source-report-new-mail-timer nil)
(defvar mail-source-report-new-mail-idle-timer nil)
-(eval-when-compile
- (if (featurep 'xemacs)
- (require 'itimer)
- (require 'timer)))
-
(defun mail-source-start-idle-timer ()
;; Start our idle timer if necessary, so we delay the check until the
;; user isn't typing.
mail-source-idle-time-delay
nil
(lambda ()
- (mail-source-check-pop mail-source-primary-source)
- (setq mail-source-report-new-mail-idle-timer nil))))
+ (unwind-protect
+ (mail-source-check-pop mail-source-primary-source)
+ (setq mail-source-report-new-mail-idle-timer nil)))))
;; Since idle timers created when Emacs is already in the idle
;; state don't get activated until Emacs _next_ becomes idle, we
;; need to force our timer to be considered active now. We do
(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
- (nnheader-run-at-time
+ (run-at-time
(* 60 mail-source-report-new-mail-interval)
(* 60 mail-source-report-new-mail-interval)
#'mail-source-start-idle-timer))
(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)
(with-temp-file mail-source-crash-box
(insert-file-contents file)
(goto-char (point-min))
-;;; ;; Unix mail format
-;;; (unless (looking-at "\n*From ")
-;;; (insert "From maildir "
-;;; (current-time-string) "\n"))
-;;; (while (re-search-forward "^From " nil t)
-;;; (replace-match ">From "))
-;;; (goto-char (point-max))
+;;; ;; Unix mail format
+;;; (unless (looking-at "\n*From ")
+;;; (insert "From maildir "
+;;; (current-time-string) "\n"))
+;;; (while (re-search-forward "^From " nil t)
+;;; (replace-match ">From "))
+;;; (goto-char (point-max))
;;; (insert "\n\n")
;; MMDF mail format
(insert "\001\001\001\001\n"))
- (delete-file file)))))
- (incf found (mail-source-callback callback file))))))
+ (delete-file file)
+ nil))))
+ (incf found (mail-source-callback callback file))
+ (mail-source-delete-crash-box)))))
found)))
-(eval-and-compile
- (autoload 'imap-open "imap")
- (autoload 'imap-authenticate "imap")
- (autoload 'imap-mailbox-select "imap")
- (autoload 'imap-mailbox-unselect "imap")
- (autoload 'imap-mailbox-close "imap")
- (autoload 'imap-search "imap")
- (autoload 'imap-fetch "imap")
- (autoload 'imap-close "imap")
- (autoload 'imap-error-text "imap")
- (autoload 'imap-message-flags-add "imap")
- (autoload 'imap-list-to-message-set "imap")
- (autoload 'imap-range-to-message-set "imap")
- (autoload 'nnheader-ms-strip-cr "nnheader"))
+(autoload 'imap-open "imap")
+(autoload 'imap-authenticate "imap")
+(autoload 'imap-mailbox-select "imap")
+(autoload 'imap-mailbox-unselect "imap")
+(autoload 'imap-mailbox-close "imap")
+(autoload 'imap-search "imap")
+(autoload 'imap-fetch "imap")
+(autoload 'imap-close "imap")
+(autoload 'imap-error-text "imap")
+(autoload 'imap-message-flags-add "imap")
+(autoload 'imap-list-to-message-set "imap")
+(autoload 'imap-range-to-message-set "imap")
+(autoload 'nnheader-ms-strip-cr "nnheader")
+
+(autoload 'gnus-compress-sequence "gnus-range")
(defvar mail-source-imap-file-coding-system 'binary
"Coding system for the crashbox made by `mail-source-fetch-imap'.")
+;; Autoloads will bring in imap before this is called.
+(declare-function imap-capability "imap" (&optional identifier buffer))
+
(defun mail-source-fetch-imap (source callback)
"Fetcher for imap sources."
(mail-source-bind (imap source)
+ (mail-source-run-script
+ prescript (format-spec-make ?p password ?t mail-source-crash-box
+ ?s server ?P port ?u user)
+ prescript-delay)
(let ((from (format "%s:%s:%s" server user port))
(found 0)
- (buf (get-buffer-create (generate-new-buffer-name " *imap source*")))
+ (buf (generate-new-buffer " *imap source*"))
(mail-source-string (format "imap:%s:%s" server mailbox))
(imap-shell-program (or (list program) imap-shell-program))
remove)
(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.
(mm-disable-multibyte)
;; remember password
(with-current-buffer buf
- (when (or imap-password
- (assoc from mail-source-password-cache))
+ (when (and imap-password
+ (not (assoc from mail-source-password-cache)))
(push (cons from imap-password) mail-source-password-cache)))
;; if predicate is nil, use all uids
(dolist (uid (imap-search (or predicate "1:*") buf))
- (when (setq str (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf))
+ (when (setq str
+ (if (imap-capability 'IMAP4rev1 buf)
+ (caddar (imap-fetch uid "BODY.PEEK[]"
+ 'BODYDETAIL nil buf))
+ (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf)))
(push uid remove)
(insert "From imap " (current-time-string) "\n")
(save-excursion
(insert str "\n\n"))
- (while (re-search-forward "^From " nil t)
+ (while (let ((case-fold-search nil))
+ (re-search-forward "^From " nil t))
(replace-match ">From "))
(goto-char (point-max))))
(nnheader-ms-strip-cr))
(incf found (mail-source-callback callback server))
+ (mail-source-delete-crash-box)
(when (and remove fetchflag)
+ (setq remove (nreverse remove))
(imap-message-flags-add
(imap-range-to-message-set (gnus-compress-sequence remove))
fetchflag nil buf))
(if dontexpunge
(imap-mailbox-unselect buf)
- (imap-mailbox-close 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.
(setq mail-source-password-cache
(delq (assoc from mail-source-password-cache)
mail-source-password-cache))
- (error (imap-error-text buf)))
+ (error "IMAP error: %s" (imap-error-text buf)))
(kill-buffer buf)
+ (mail-source-run-script
+ postscript
+ (format-spec-make ?p password ?t mail-source-crash-box
+ ?s server ?P port ?u user))
found)))
-(eval-and-compile
- (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))
- (mail-source-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)))))
-
(provide 'mail-source)
;;; mail-source.el ends here
projects / gnus / blobdiff