;;; mail-source.el --- functions for fetching mail
-;; Copyright (C) 1999 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news, mail
(eval-when-compile (require 'cl))
(eval-and-compile
- (autoload 'pop3-movemail "pop3"))
+ (autoload 'pop3-movemail "pop3")
+ (autoload 'pop3-get-message-count "pop3"))
(require 'format-spec)
(defgroup mail-source nil
(defcustom mail-sources nil
"*Where the mail backends will look for incoming mail.
-This variable is a list of mail source specifiers."
+This variable is a list of mail source specifiers.
+See Info node `(gnus)Mail Source Specifiers'."
+ :group 'mail-source
+ ;; This specification should be tidied up, particularly to avoid
+ ;; constant items appearing. (Perhaps there's scope for improvment
+ ;; in the widget code.)
+ :type `(repeat
+ (choice (const :tag "Default spool file" (file))
+ (list :tag "Specified spool file"
+ (const file)
+ (const :value :path)
+ file)
+ (cons :tag "Several files in a directory"
+ (const directory)
+ (choice
+ :tag "Options"
+ (const :tag "None" nil)
+ (repeat
+ (choice
+ (list :inline t :tag "path"
+ (const :value :path) directory)
+ (list :inline t :tag "suffix"
+ (const :value :suffix) string)
+ (list :inline t :tag "predicate"
+ (const :value :predicate) function)
+ (list :inline t :tag "prescript"
+ (const :value :prescript) string)
+ (list :inline t :tag "postscript"
+ (const :value :postscript) string)
+ (list :inline t :tag "plugged"
+ (const :value :plugged) boolean)))))
+ (cons :tag "POP3 server"
+ (const pop)
+ (choice
+ :tag "Options"
+ (const :tag "None" nil)
+ (repeat
+ (choice
+ (list :inline t :tag "server"
+ (const :value :server) string)
+ (list :inline t :tag "port"
+ (const :value :port) (choice number string))
+ (list :inline t :tag "user"
+ (const :value :user) string)
+ (list :inline t :tag "password"
+ (const :value :password) string)
+ (list :inline t :tag "program"
+ (const :value :program) string)
+ (list :inline t :tag "prescript"
+ (const :value :prescript) string)
+ (list :inline t :tag "postscript"
+ (const :value :postscript) string)
+ (list :inline t :tag "function"
+ (const :value :function) function)
+ (list :inline t :tag "authentication"
+ (const :value :authentication)
+ (choice (const password)
+ (const apop)))
+ (list :inline t :tag "plugged"
+ (const :value :plugged) boolean)))))
+ (cons :tag "Maildir (qmail, postfix...)"
+ (const maildir)
+ (choice
+ :tag "Options"
+ (const :tag "None" nil)
+ (repeat
+ (choice
+ (list :inline t :tag "path"
+ (const :value :path) directory)
+ (list :inline t :tag "plugged"
+ (const :value :plugged) boolean)))))
+ (cons :tag "IMAP server"
+ (const imap)
+ (choice
+ :tag "Options"
+ (const :tag "None" nil)
+ (repeat
+ (choice
+ (list :inline t :tag "server"
+ (const :value :server) string)
+ (list :inline t :tag "port"
+ (const :value :port)
+ (choice number string))
+ (list :inline t :tag "user"
+ (const :value :user) string)
+ (list :inline t :tag "password"
+ (const :value :password) string)
+ (list :inline t :tag "stream"
+ (const :value :stream)
+ (choice ,@(progn (require 'imap)
+ (mapcar
+ (lambda (a)
+ (list 'const (car a)))
+ imap-stream-alist))))
+ (list :inline t :tag "authenticator"
+ (const :value :authenticator)
+ (choice ,@(progn (require 'imap)
+ (mapcar
+ (lambda (a)
+ (list 'const (car a)))
+ imap-authenticator-alist))))
+ (list :inline t :tag "mailbox"
+ (const :value :mailbox) string)
+ (list :inline t :tag "predicate"
+ (const :value :predicate) function)
+ (list :inline t :tag "fetchflag"
+ (const :value :fetchflag) string)
+ (list :inline t :tag "dontexpunge"
+ (const :value :dontexpunge) boolean)
+ (list :inline t :tag "plugged"
+ (const :value :plugged) )))))
+ (cons :tag "Webmail server"
+ (const webmail)
+ (choice
+ :tag "Options"
+ (const :tag "None" nil)
+ (repeat
+ (choice
+ (list :inline t :tag "subtype"
+ (const :value :subtype)
+ ;; Should be generated from
+ ;; `webmail-type-definition', but we
+ ;; can't require webmail without W3.
+ (choice (const hotmail) (const yahoo)
+ (const netaddress) (const netscape)
+ (const my-deja)))
+ (list :inline t :tag "user"
+ (const :value :user) string)
+ (list :inline t :tag "password"
+ (const :value :password) string)
+ (list :inline t :tag "dontexpunge"
+ (const :value :dontexpunge) boolean)
+ (list :inline t :tag "plugged"
+ (const :value :plugged) boolean))))))))
+
+(defcustom mail-source-primary-source nil
+ "*Primary source for incoming mail.
+If non-nil, this maildrop will be checked periodically for new mail."
:group 'mail-source
:type 'sexp)
:group 'mail-source
:type 'integer)
-(defcustom mail-source-delete-incoming t
+(defcustom mail-source-delete-incoming nil
"*If non-nil, delete incoming files after handling."
:group 'mail-source
:type 'boolean)
+(defcustom mail-source-incoming-file-prefix "Incoming"
+ "Prefix for file name for storing incoming mail"
+ :group 'mail-source
+ :type 'string)
+
+(defcustom mail-source-report-new-mail-interval 5
+ "Interval in minutes between checks for new mail."
+ :group 'mail-source
+ :type 'number)
+
+(defcustom mail-source-idle-time-delay 5
+ "Number of idle seconds to wait before checking for new mail."
+ :group 'mail-source
+ :type 'number)
+
;;; Internal variables.
(defvar mail-source-string ""
"A dynamically bound string that says what the current mail source is.")
+(defvar mail-source-new-mail-available nil
+ "Flag indicating when new mail is available.")
+
(eval-and-compile
(defvar mail-source-common-keyword-map
'((:plugged))
(:password)
(:authentication password))
(maildir
- (:path "~/Maildir/new/")
+ (:path (or (getenv "MAILDIR") "~/Maildir/"))
+ (:subdirs ("new" "cur"))
(:function))
(imap
(:server (getenv "MAILHOST"))
(:password)
(:mailbox "INBOX")
(:predicate "UNSEEN UNDELETED")
- (:fetchflag "\Deleted")
+ (:fetchflag "\\Deleted")
(:dontexpunge))
(webmail
(:subtype hotmail)
(:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
(:password)
+ (:dontexpunge)
(:authentication password)))
"Mapping from keywords to default values.
All keywords that can be used must be listed here."))
(eval-and-compile
(defun mail-source-strip-keyword (keyword)
- "Strip the leading colon off the KEYWORD."
- (intern (substring (symbol-name keyword) 1))))
+ "Strip the leading colon off the KEYWORD."
+ (intern (substring (symbol-name keyword) 1))))
(eval-and-compile
(defun mail-source-bind-1 (type)
(set (mail-source-strip-keyword (setq keyword (car default)))
(if (setq value (plist-get source keyword))
(mail-source-value value)
- (if (setq value (plist-get defaults-1 keyword))
- (mail-source-value value)
+ (if (setq value (assq keyword defaults-1))
+ (mail-source-value (cadr value))
(mail-source-value (cadr default))))))))
(defmacro mail-source-bind-common (source &rest body)
(let ((incoming
(mail-source-make-complex-temp-name
(expand-file-name
- "Incoming" mail-source-directory))))
+ 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)))))))
(defun mail-source-fetch-with-program (program)
(zerop (call-process shell-file-name nil nil nil
- shell-command-switch program)))
+ shell-command-switch program)))
(defun mail-source-run-script (script spec &optional delay)
(when script
(mail-source-run-script
prescript
(format-spec-make ?p password ?t mail-source-crash-box
- ?s server ?P port ?u user)
+ ?s server ?P port ?u user)
prescript-delay)
(let ((from (format "%s:%s:%s" server user port))
(mail-source-string (format "pop:%s@%s" user server))
(push (cons from password) mail-source-password-cache)))
(prog1
(mail-source-callback callback server)
+ ;; Update display-time's mail flag, if relevant.
+ (if (equal source mail-source-primary-source)
+ (setq mail-source-new-mail-available nil))
(mail-source-run-script
postscript
(format-spec-make ?p password ?t mail-source-crash-box
mail-source-password-cache))
0))))
+(defun mail-source-check-pop (source)
+ "Check whether there is new mail."
+ (mail-source-bind (pop source)
+ (let ((from (format "%s:%s:%s" server user port))
+ (mail-source-string (format "pop:%s@%s" user server))
+ result)
+ (when (eq authentication 'password)
+ (setq password
+ (or password
+ (cdr (assoc from mail-source-password-cache))
+ (mail-source-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.
+ (program)
+ (function)
+ ;; The default is to use pop3.el.
+ (t
+ (let ((pop3-password password)
+ (pop3-maildrop user)
+ (pop3-mailhost server)
+ (pop3-port port)
+ (pop3-authentication-scheme
+ (if (eq authentication 'apop) 'apop 'pass)))
+ (save-excursion (pop3-get-message-count))))))
+ (if result
+ ;; Inform display-time that we have new mail.
+ (setq mail-source-new-mail-available (> result 0))
+ ;; 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)))
+ result)))
+
+(defun mail-source-new-mail-p ()
+ "Handler for `display-time' to indicate when new mail is available."
+ ;; Only report flag setting; flag is updated on a different schedule.
+ mail-source-new-mail-available)
+
+
+(defvar mail-source-report-new-mail nil)
+(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.
+ (unless mail-source-report-new-mail-idle-timer
+ (setq mail-source-report-new-mail-idle-timer
+ (run-with-idle-timer
+ mail-source-idle-time-delay
+ nil
+ (lambda ()
+ (setq mail-source-report-new-mail-idle-timer nil)
+ (mail-source-check-pop mail-source-primary-source))))
+ ;; 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
+ ;; this by being naughty and poking the timer internals directly
+ ;; (element 0 of the vector is nil if the timer is active).
+ (aset mail-source-report-new-mail-idle-timer 0 nil)))
+
+(defun mail-source-report-new-mail (arg)
+ "Toggle whether to report when new mail is available.
+This only works when `display-time' is enabled."
+ (interactive "P")
+ (if (not mail-source-primary-source)
+ (error "Need to set `mail-source-primary-source' to check for new mail."))
+ (let ((on (if (null arg)
+ (not mail-source-report-new-mail)
+ (> (prefix-numeric-value arg) 0))))
+ (setq mail-source-report-new-mail on)
+ (and mail-source-report-new-mail-timer
+ (nnheader-cancel-timer mail-source-report-new-mail-timer))
+ (and mail-source-report-new-mail-idle-timer
+ (nnheader-cancel-timer mail-source-report-new-mail-idle-timer))
+ (setq mail-source-report-new-mail-timer nil)
+ (setq mail-source-report-new-mail-idle-timer nil)
+ (if on
+ (progn
+ (require 'time)
+ ;; display-time-mail-function is an Emacs 21 feature.
+ (setq display-time-mail-function #'mail-source-new-mail-p)
+ ;; Set up the main timer.
+ (setq mail-source-report-new-mail-timer
+ (run-at-time t (* 60 mail-source-report-new-mail-interval)
+ #'mail-source-start-idle-timer))
+ ;; When you get new mail, clear "Mail" from the mode line.
+ (add-hook 'nnmail-post-get-new-mail-hook
+ 'display-time-event-handler)
+ (message "Mail check enabled"))
+ (setq display-time-mail-function nil)
+ (remove-hook 'nnmail-post-get-new-mail-hook
+ 'display-time-event-handler)
+ (message "Mail check disabled"))))
+
(defun mail-source-fetch-maildir (source callback)
"Fetcher for maildir sources."
(mail-source-bind (maildir source)
(let ((found 0)
- (mail-source-string (format "maildir:%s" path)))
- (dolist (file (directory-files path t))
- (when (and (not (file-directory-p file))
- (not (if function
- (funcall function file mail-source-crash-box)
- (rename-file file mail-source-crash-box))))
- (incf found (mail-source-callback callback file))))
+ mail-source-string)
+ (unless (string-match "/$" path)
+ (setq path (concat path "/")))
+ (dolist (subdir subdirs)
+ (when (file-directory-p (concat path subdir))
+ (setq mail-source-string (format "maildir:%s%s" path subdir))
+ (dolist (file (directory-files (concat path subdir) t))
+ (when (and (not (file-directory-p file))
+ (not (if function
+ (funcall function file mail-source-crash-box)
+ (let ((coding-system-for-write
+ mm-text-coding-system)
+ (coding-system-for-read
+ 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))
+;;; (insert "\n\n")
+ ;; MMDF mail format
+ (insert "\001\001\001\001\n"))
+ (delete-file file)))))
+ (incf found (mail-source-callback callback file))))))
found)))
(eval-and-compile
(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"))
+(defvar mail-source-imap-file-coding-system 'binary
+ "Coding system for the crashbox made by `mail-source-fetch-imap'.")
+
(defun mail-source-fetch-imap (source callback)
"Fetcher for imap sources."
(mail-source-bind (imap source)
- (let ((found 0)
+ (let ((from (format "%s:%s:%s" server user port))
+ (found 0)
(buf (get-buffer-create (generate-new-buffer-name " *imap source*")))
(mail-source-string (format "imap:%s:%s" server mailbox))
remove)
(if (and (imap-open server port stream authentication buf)
- (imap-authenticate user password buf)
+ (imap-authenticate
+ user (or (cdr (assoc from mail-source-password-cache))
+ password) buf)
(imap-mailbox-select mailbox nil buf))
- (let (str (coding-system-for-write 'binary))
+ (let (str (coding-system-for-write mail-source-imap-file-coding-system))
(with-temp-file mail-source-crash-box
+ ;; In some versions of FSF Emacs, inserting unibyte
+ ;; string into multibyte buffer may convert 8-bit chars
+ ;; into latin-iso8859-1 chars, which results \201's.
+ (mm-disable-multibyte)
+ ;; remember password
+ (with-current-buffer buf
+ (when (or imap-password
+ (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))
(incf found (mail-source-callback callback server))
(when (and remove fetchflag)
(imap-message-flags-add
- (imap-list-to-message-set remove) fetchflag nil buf))
+ (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-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)))
(kill-buffer buf)
found)))
(defun mail-source-fetch-webmail (source callback)
"Fetch for webmail source."
(mail-source-bind (webmail source)
- (when (eq authentication 'password)
- (setq password
- (or password
- (mail-source-read-passwd
- (format "Password for %s at %s: " user subtype)))))
- (webmail-fetch mail-source-crash-box subtype user password)
- (mail-source-callback callback (symbol-name subtype))))
+ (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)