diff options
Diffstat (limited to 'lisp/gnus/mail-source.el')
| -rw-r--r-- | lisp/gnus/mail-source.el | 736 |
1 files changed, 736 insertions, 0 deletions
diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el new file mode 100644 index 00000000000..f2a431dc265 --- /dev/null +++ b/lisp/gnus/mail-source.el @@ -0,0 +1,736 @@ +;;; mail-source.el --- functions for fetching mail +;; Copyright (C) 1999, 2000 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 +;; 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. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; 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. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) +(eval-and-compile + (autoload 'pop3-movemail "pop3") + (autoload 'pop3-get-message-count "pop3")) +(require 'format-spec) + +(defgroup mail-source nil + "The mail-fetching library." + :group 'gnus) + +(defcustom mail-sources nil + "*Where the mail backends will look for incoming mail. +This variable is a list of mail source specifiers." + :group 'mail-source + :type 'sexp) + +(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) + +(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 "~/Mail/" + "Directory where files (if any) will be stored." + :group 'mail-source + :type 'directory) + +(defcustom mail-source-default-file-modes 384 + "Set the mode bits of all new mail files to this integer." + :group 'mail-source + :type 'integer) + +(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)) + "Mapping from keywords to default values. +Common keywords should be listed here.") + + (defvar mail-source-keyword-map + '((file + (:prescript) + (:prescript-delay) + (:postscript) + (:path (or (getenv "MAIL") + (concat "/usr/spool/mail/" (user-login-name))))) + (directory + (:path) + (:suffix ".spool") + (:predicate identity)) + (pop + (:prescript) + (:prescript-delay) + (:postscript) + (:server (getenv "MAILHOST")) + (:port 110) + (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER"))) + (:program) + (:function) + (:password) + (:authentication password)) + (maildir + (:path (or (getenv "MAILDIR") "~/Maildir/")) + (:subdirs ("new" "cur")) + (:function)) + (imap + (:server (getenv "MAILHOST")) + (:port) + (:stream) + (:authentication) + (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER"))) + (:password) + (:mailbox "INBOX") + (:predicate "UNSEEN UNDELETED") + (: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.")) + +(defvar mail-source-fetcher-alist + '((file mail-source-fetch-file) + (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)) + "A mapping from source type to fetcher function.") + +(defvar mail-source-password-cache nil) + +(defvar mail-source-plugged t) + +;;; Functions + +(eval-and-compile + (defun mail-source-strip-keyword (keyword) + "Strip the leading colon off the KEYWORD." + (intern (substring (symbol-name keyword) 1)))) + +(eval-and-compile + (defun mail-source-bind-1 (type) + (let* ((defaults (cdr (assq type mail-source-keyword-map))) + default bind) + (while (setq default (pop defaults)) + (push (list (mail-source-strip-keyword (car default)) + nil) + bind)) + bind))) + +(defmacro mail-source-bind (type-source &rest body) + "Return a `let' form that binds all variables in source TYPE. +TYPE-SOURCE is a list where the first element is the TYPE, and +the second variable is the SOURCE. +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. + +After this is done, BODY will be executed in the scope +of the `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)) + (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)) + +(defun mail-source-set-1 (source) + (let* ((type (pop source)) + (defaults (cdr (assq type mail-source-keyword-map))) + default value keyword) + (while (setq default (pop defaults)) + (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))))))) + +(eval-and-compile + (defun mail-source-bind-common-1 () + (let* ((defaults mail-source-common-keyword-map) + default bind) + (while (setq default (pop defaults)) + (push (list (mail-source-strip-keyword (car default)) + nil) + bind)) + bind))) + +(defun mail-source-set-common-1 (source) + (let* ((type (pop source)) + (defaults mail-source-common-keyword-map) + (defaults-1 (cdr (assq type mail-source-keyword-map))) + default value keyword) + (while (setq default (pop defaults)) + (set (mail-source-strip-keyword (setq keyword (car default))) + (if (setq value (plist-get source 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) + "Return a `let' form that binds all common variables. +See `mail-source-bind'." + `(let ,(mail-source-bind-common-1) + (mail-source-set-common-1 source) + ,@body)) + +(put 'mail-source-bind-common 'lisp-indent-function 1) +(put 'mail-source-bind-common 'edebug-form-spec '(form body)) + +(defun mail-source-value (value) + "Return the value of VALUE." + (cond + ;; String + ((stringp value) + value) + ;; Function + ((and (listp value) + (functionp (car value))) + (eval value)) + ;; Just return the value. + (t + value))) + +(defun mail-source-fetch (source callback) + "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. +Return the number of files that were found." + (mail-source-bind-common source + (if (or mail-source-plugged plugged) + (save-excursion + (let ((function (cadr (assq (car source) mail-source-fetcher-alist))) + (found 0)) + (unless function + (error "%S is an invalid mail source specification" source)) + ;; If there's anything in the crash box, we do it first. + (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))) + (+ found + (condition-case err + (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)) + +(defun mail-source-callback (callback info) + "Call CALLBACK on the mail file, and then remove 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))))))) + +(defun mail-source-movemail (from to) + "Move FROM to TO using movemail." + (if (not (file-writable-p to)) + (error "Can't write to crash box %s. Not moving mail" to) + (let ((to (file-truename (expand-file-name to))) + errors result) + (setq to (file-truename to) + from (file-truename from)) + ;; Set TO if have not already done so, and rename or copy + ;; the file FROM to TO if and as appropriate. + (cond + ((file-exists-p to) + ;; The crash box exists already. + t) + ((not (file-exists-p from)) + ;; There is no inbox. + (setq to nil)) + ((zerop (nth 7 (file-attributes from))) + ;; Empty file. + (setq to nil)) + (t + ;; If getting from mail spool directory, use movemail to move + ;; rather than just renaming, so as to interlock with the + ;; mailer. + (unwind-protect + (save-excursion + (setq errors (generate-new-buffer " *mail source loss*")) + (let ((default-directory "/")) + (setq result + (apply + 'call-process + (append + (list + (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)) + ;; No output => movemail won. + t + (set-buffer errors) + ;; There may be a warning about older revisions. We + ;; ignore that. + (goto-char (point-min)) + (if (search-forward "older revision" nil t) + t + ;; Probably a real error. + (subst-char-in-region (point-min) (point-max) ?\n ?\ ) + (goto-char (point-max)) + (skip-chars-backward " \t") + (delete-region (point) (point-max)) + (goto-char (point-min)) + (when (looking-at "movemail: ") + (delete-region (point-min) (match-end 0))) + (unless (yes-or-no-p + (format "movemail: %s (%d return). Continue? " + (buffer-string) result)) + (error "%s" (buffer-string))) + (setq to nil))))))) + (when (and errors + (buffer-name errors)) + (kill-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))) + +(defun mail-source-run-script (script spec &optional delay) + (when script + (if (and (symbolp script) (fboundp script)) + (funcall script) + (mail-source-call-script + (format-spec script spec)))) + (when delay + (sleep-for delay))) + +(defun mail-source-call-script (script) + (let ((background nil)) + (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))) + +;;; +;;; Different fetchers +;;; + +(defun mail-source-fetch-file (source callback) + "Fetcher for single-file sources." + (mail-source-bind (file source) + (mail-source-run-script + prescript (format-spec-make ?t mail-source-crash-box) + prescript-delay) + (let ((mail-source-string (format "file:%s" path))) + (if (mail-source-movemail path mail-source-crash-box) + (prog1 + (mail-source-callback callback path) + (mail-source-run-script + postscript (format-spec-make ?t mail-source-crash-box))) + 0)))) + +(defun mail-source-fetch-directory (source callback) + "Fetcher for directory sources." + (mail-source-bind (directory source) + (let ((found 0) + (mail-source-string (format "directory:%s" path))) + (dolist (file (directory-files + path t (concat (regexp-quote suffix) "$"))) + (when (and (file-regular-p file) + (funcall predicate file) + (mail-source-movemail file mail-source-crash-box)) + (incf found (mail-source-callback callback file)))) + found))) + +(defun mail-source-fetch-pop (source callback) + "Fetcher for single-file sources." + (mail-source-bind (pop 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)) + (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))))) + (when server + (setenv "MAILHOST" server)) + (setq result + (cond + (program + (mail-source-fetch-with-program + (format-spec + program + (format-spec-make ?p password ?t mail-source-crash-box + ?s server ?P port ?u user)))) + (function + (funcall function mail-source-crash-box)) + ;; 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-movemail mail-source-crash-box)))))) + (if result + (progn + (when (eq authentication 'password) + (unless (assoc from mail-source-password-cache) + (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 + ?s server ?P port ?u user)))) + ;; 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)) + 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 (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 + (cancel-timer mail-source-report-new-mail-timer)) + (and mail-source-report-new-mail-idle-timer + (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) + (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) + (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 ")) + ;; MMDF mail format + (insert "\001\001\001\001\n") + (goto-char (point-max)) + (insert "\n\n")) + (delete-file file))))) + (incf found (mail-source-callback callback file)))))) + 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 'nnheader-ms-strip-cr "nnheader")) + +(defun mail-source-fetch-imap (source callback) + "Fetcher for imap sources." + (mail-source-bind (imap source) + (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 (or (cdr (assoc from mail-source-password-cache)) + password) buf) + (imap-mailbox-select mailbox nil buf)) + (let (str (coding-system-for-write 'binary)) + (with-temp-file mail-source-crash-box + ;; 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)) + (push uid remove) + (insert "From imap " (current-time-string) "\n") + (save-excursion + (insert str "\n\n")) + (while (re-search-forward "^From " nil t) + (replace-match ">From ")) + (goto-char (point-max)))) + (nnheader-ms-strip-cr)) + (incf found (mail-source-callback callback server)) + (when (and remove fetchflag) + (imap-message-flags-add + (imap-list-to-message-set 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))) + +(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 |