--- /dev/null
+;;; mail-source.el --- functions for fetching mail
+
+;; Copyright (C) 1999-2016 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 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
+;; 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'format-spec)
+(eval-when-compile
+ (require 'cl)
+ (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"
+ :group 'gnus)
+
+;; Define these at compile time to avoid dragging in imap always.
+(defconst mail-source-imap-authenticators
+ (eval-when-compile
+ (mapcar (lambda (a)
+ (list 'const (car a)))
+ imap-authenticator-alist)))
+(defconst mail-source-imap-streams
+ (eval-when-compile
+ (mapcar (lambda (a)
+ (list 'const (car a)))
+ imap-stream-alist)))
+
+(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
+ :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.
+If non-nil, this maildrop will be checked periodically for new 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 incoming mail source 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
+ 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)
+
+(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)
+
+(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 ""
+ "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")
+ (expand-file-name (user-login-name) rmail-spool-directory))))
+ (directory
+ (:prescript)
+ (:prescript-delay)
+ (:postscript)
+ (:path)
+ (:suffix ".spool")
+ (:predicate identity))
+ (pop
+ (: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)
+ (: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)
+ (:program)
+ (:authentication)
+ (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
+ (:password)
+ (:mailbox "INBOX")
+ (:predicate "UNSEEN UNDELETED")
+ (:fetchflag "\\Deleted")
+ (:prescript)
+ (:prescript-delay)
+ (:postscript)
+ (:dontexpunge)))
+ "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))
+ "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))))
+
+;; 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)))
+ 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.
+
+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 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))
+ (mail-source-set-1 ,(cadr type-source))
+ ,@body))
+
+(put 'mail-source-bind 'lisp-indent-function 1)
+(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)))
+ (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 (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 ()
+ (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 '(sexp body))
+
+(defun mail-source-value (value)
+ "Return the value of VALUE."
+ (cond
+ ;; String
+ ((stringp value)
+ value)
+ ;; Function
+ ((and (listp value) (symbolp (car value)) (fboundp (car value)))
+ (eval value))
+ ;; Just return the value.
+ (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)
+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
+ ;; 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 "%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))
+ (mail-source-delete-crash-box))
+ (+ found
+ (if (or debug-on-quit debug-on-error)
+ (funcall function source callback)
+ (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. 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)
+ (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."
+ (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
+ (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 (or (not (buffer-modified-p errors))
+ (zerop (buffer-size errors)))
+ (and (numberp result)
+ (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)))
+ ;; Result may be a signal description string.
+ (unless (yes-or-no-p
+ (format "movemail: %s (%s 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-fetch-with-program (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 (functionp 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)
+ (stderr (get-buffer-create " *mail-source-stderr*"))
+ result)
+ (when (string-match "& *$" script)
+ (setq script (substring script 0 (match-beginning 0))
+ background 0))
+ (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
+;;;
+
+(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))
+ (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
+ 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))
+ (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
+ ?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))
+ (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))
+ (read-passwd
+ (format "Password for %s at %s: " user 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
+ (require 'pop3)
+ (let ((pop3-password password)
+ (pop3-maildrop user)
+ (pop3-mailhost server)
+ (pop3-port port)
+ (pop3-authentication-scheme
+ (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))
+ (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)
+ (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))
+ (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
+ (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))
+ (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))
+ (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)))
+ (setq result
+ (cond
+ ;; No easy way to check whether mail is waiting for these.
+ (program)
+ (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)))
+ (if (or debug-on-quit debug-on-error)
+ (save-excursion (pop3-get-message-count))
+ (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))
+ ;; 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-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 nil)
+(defvar mail-source-report-new-mail-timer nil)
+(defvar mail-source-report-new-mail-idle-timer nil)
+
+(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 ()
+ (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
+ ;; 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 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
+ (* 60 mail-source-report-new-mail-interval)
+ (* 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
+ ;; `function' should return nil if successful.
+ (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)
+ nil))))
+ (incf found (mail-source-callback callback file))
+ (mail-source-delete-crash-box)))))
+ found)))
+
+(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 (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))
+ (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 (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
+ (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 (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 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: %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)))
+
+(provide 'mail-source)
+
+;;; mail-source.el ends here
projects / packages / blobdiff