;;; mail-source.el --- functions for fetching mail
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;; 2008, 2009, 2010 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 3, 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., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
(eval-when-compile
(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"))
+(autoload 'auth-source-user-or-password "auth-source")
+(autoload 'pop3-streaming-movemail "pop3")
+(autoload 'pop3-get-message-count "pop3")
+(autoload 'nnheader-cancel-timer "nnheader")
(require 'mm-util)
(require 'message) ;; for `message-directory'
(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 user-auth pass-auth)
+ default value keyword auth-info user-auth pass-auth)
(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
;; 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
+ (cond
((and
(eq keyword :user)
- (setq user-auth
- (auth-source-user-or-password
- "login"
- ;; this is "host" in auth-sources
- (if (boundp 'server) (symbol-value 'server) "")
- type)))
+ (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
- (auth-source-user-or-password
- "password"
- ;; this is "host" in auth-sources
- (if (boundp 'server) (symbol-value 'server) "")
- type)))
+ (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)
(t
value)))
-(defun mail-source-fetch (source callback)
+(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
(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
0)
(funcall callback mail-source-crash-box info)))
+(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.
(rename-file mail-source-crash-box incoming t)
;; remove old incoming files?
(when (natnump mail-source-delete-incoming)
- (mail-source-delete-old-incoming
- mail-source-delete-incoming
- mail-source-delete-old-incoming-confirm))))))
+ ;; 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
+ (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."
(if (eq authentication 'apop) 'apop 'pass))
(pop3-stream-type stream))
(if (or debug-on-quit debug-on-error)
- (save-excursion (pop3-movemail mail-source-crash-box))
+ (save-excursion (pop3-streaming-movemail
+ mail-source-crash-box))
(condition-case err
- (save-excursion (pop3-movemail mail-source-crash-box))
+ (save-excursion (pop3-streaming-movemail
+ mail-source-crash-box))
(error
;; We nix out the password in case the error
;; was because of a wrong password being given.
(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")
?s server ?P port ?u user))
found)))
-(eval-and-compile
- (autoload 'webmail-fetch "webmail"))
+(autoload 'webmail-fetch "webmail")
(defun mail-source-fetch-webmail (source callback)
"Fetch for webmail source."
(provide 'mail-source)
-;; arch-tag: 72948025-1d17-4d6c-bb12-ef1aa2c490fd
;;; mail-source.el ends here
projects / gnus / blobdiff