cgit.sxemacs.org Git - gnus/blob - lisp/mail-source.el

   1 ;;; mail-source.el --- functions for fetching mail
   2 ;; Copyright (C) 1999 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;; Keywords: news, mail
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-when-compile (require 'cl))
  29 (eval-and-compile
  30   (autoload 'pop3-movemail "pop3"))
  31 (require 'format-spec)
  32
  33 (defgroup mail-source nil
  34   "The mail-fetching library."
  35   :group 'gnus)
  36
  37 (defcustom mail-sources nil
  38   "*Where the mail backends will look for incoming mail.
  39 This variable is a list of mail source specifiers."
  40   :group 'mail-source
  41   :type 'sexp)
  42
  43 (defcustom mail-source-crash-box "~/.emacs-mail-crash-box"
  44   "File where mail will be stored while processing it."
  45   :group 'mail-source
  46   :type 'file)
  47
  48 (defcustom mail-source-directory "~/Mail/"
  49   "Directory where files (if any) will be stored."
  50   :group 'mail-source
  51   :type 'directory)
  52
  53 (defcustom mail-source-default-file-modes 384
  54   "Set the mode bits of all new mail files to this integer."
  55   :group 'mail-source
  56   :type 'integer)
  57
  58 (defcustom mail-source-delete-incoming nil
  59   "*If non-nil, delete incoming files after handling."
  60   :group 'mail-source
  61   :type 'boolean)
  62
  63 ;;; Internal variables.
  64
  65 (defvar mail-source-string ""
  66   "A dynamically bound string that says what the current mail source is.")
  67
  68 (eval-and-compile
  69   (defvar mail-source-keyword-map
  70     '((file
  71        (:prescript)
  72        (:postscript)
  73        (:path (or (getenv "MAIL")
  74                   (concat "/usr/spool/mail/" (user-login-name)))))
  75       (directory
  76        (:path)
  77        (:suffix ".spool")
  78        (:predicate identity))
  79       (pop
  80        (:prescript)
  81        (:postscript)
  82        (:server (getenv "MAILHOST"))
  83        (:port 110)
  84        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
  85        (:program)
  86        (:function)
  87        (:password)
  88        (:authentication password))
  89       (maildir
  90        (:path "~/Maildir/new/")))
  91     "Mapping from keywords to default values.
  92 All keywords that can be used must be listed here."))
  93
  94 (defvar mail-source-fetcher-alist
  95   '((file mail-source-fetch-file)
  96     (directory mail-source-fetch-directory)
  97     (pop mail-source-fetch-pop)
  98     (maildir mail-source-fetch-maildir))
  99   "A mapping from source type to fetcher function.")
 100
 101 (defvar mail-source-password-cache nil)
 102
 103 ;;; Functions
 104
 105 (eval-and-compile
 106   (defun mail-source-strip-keyword (keyword)
 107   "Strip the leading colon off the KEYWORD."
 108   (intern (substring (symbol-name keyword) 1))))
 109
 110 (eval-and-compile
 111   (defun mail-source-bind-1 (type)
 112     (let* ((defaults (cdr (assq type mail-source-keyword-map)))
 113            default bind)
 114       (while (setq default (pop defaults))
 115         (push (list (mail-source-strip-keyword (car default))
 116                     nil)
 117               bind))
 118       bind)))
 119
 120 (defmacro mail-source-bind (type-source &rest body)
 121   "Return a `let' form that binds all variables in source TYPE.
 122 TYPE-SOURCE is a list where the first element is the TYPE, and
 123 the second variable is the SOURCE.
 124 At run time, the mail source specifier SOURCE will be inspected,
 125 and the variables will be set according to it.  Variables not
 126 specified will be given default values.
 127
 128 After this is done, BODY will be executed in the scope
 129 of the `let' form.
 130
 131 The variables bound and their default values are described by
 132 the `mail-source-keyword-map' variable."
 133   `(let ,(mail-source-bind-1 (car type-source))
 134      (mail-source-set-1 ,(cadr type-source))
 135      ,@body))
 136
 137 (put 'mail-source-bind 'lisp-indent-function 1)
 138 (put 'mail-source-bind 'edebug-form-spec '(form body))
 139
 140 (defun mail-source-set-1 (source)
 141   (let* ((type (pop source))
 142          (defaults (cdr (assq type mail-source-keyword-map)))
 143          default value keyword)
 144     (while (setq default (pop defaults))
 145       (set (mail-source-strip-keyword (setq keyword (car default)))
 146            (if (setq value (plist-get source keyword))
 147                (mail-source-value value)
 148              (mail-source-value (cadr default)))))))
 149
 150 (defun mail-source-value (value)
 151   "Return the value of VALUE."
 152   (cond
 153    ;; String
 154    ((stringp value)
 155     value)
 156    ;; Function
 157    ((and (listp value)
 158          (functionp (car value)))
 159     (eval value))
 160    ;; Just return the value.
 161    (t
 162     value)))
 163
 164 (defun mail-source-fetch (source callback)
 165   "Fetch mail from SOURCE and call CALLBACK zero or more times.
 166 CALLBACK will be called with the name of the file where (some of)
 167 the mail from SOURCE is put.
 168 Return the number of files that were found."
 169   (save-excursion
 170     (let ((function (cadr (assq (car source) mail-source-fetcher-alist)))
 171           (found 0))
 172       (unless function
 173         (error "%S is an invalid mail source specification" source))
 174       ;; If there's anything in the crash box, we do it first.
 175       (when (file-exists-p mail-source-crash-box)
 176         (message "Processing mail from %s..." mail-source-crash-box)
 177         (setq found (mail-source-callback
 178                      callback mail-source-crash-box)))
 179       (+ found
 180          (condition-case err
 181              (funcall function source callback)
 182            (error
 183             (unless (yes-or-no-p
 184                      (format "Mail source error.  Continue? "))
 185               (error "Cannot get new mail."))
 186             0))))))
 187
 188 (defun mail-source-make-complex-temp-name (prefix)
 189   (let ((newname (make-temp-name prefix))
 190         (newprefix prefix))
 191     (while (file-exists-p newname)
 192       (setq newprefix (concat newprefix "x"))
 193       (setq newname (make-temp-name newprefix)))
 194     newname))
 195
 196 (defun mail-source-callback (callback info)
 197   "Call CALLBACK on the mail file, and then remove the mail file.
 198 Pass INFO on to CALLBACK."
 199   (if (or (not (file-exists-p mail-source-crash-box))
 200           (zerop (nth 7 (file-attributes mail-source-crash-box))))
 201       (progn
 202         (when (file-exists-p mail-source-crash-box)
 203           (delete-file mail-source-crash-box))
 204         0)
 205     (funcall callback mail-source-crash-box info)
 206     (when (file-exists-p mail-source-crash-box)
 207       ;; Delete or move the incoming mail out of the way.
 208       (if mail-source-delete-incoming
 209           (delete-file mail-source-crash-box)
 210         (let ((incoming
 211                (mail-source-make-complex-temp-name
 212                 (expand-file-name
 213                  "Incoming" mail-source-directory))))
 214           (unless (file-exists-p (file-name-directory incoming))
 215             (make-directory (file-name-directory incoming) t))
 216           (rename-file mail-source-crash-box incoming t))))
 217     1))
 218
 219 (defun mail-source-movemail (from to)
 220   "Move FROM to TO using movemail."
 221   (if (not (file-writable-p to))
 222       (error "Can't write to crash box %s.  Not moving mail" to)
 223     (let ((to (file-truename (expand-file-name to)))
 224           errors result)
 225       (setq to (file-truename to)
 226             from (file-truename from))
 227       ;; Set TO if have not already done so, and rename or copy
 228       ;; the file FROM to TO if and as appropriate.
 229       (cond
 230        ((file-exists-p to)
 231         ;; The crash box exists already.
 232         t)
 233        ((not (file-exists-p from))
 234         ;; There is no inbox.
 235         (setq to nil))
 236        ((zerop (nth 7 (file-attributes from)))
 237         ;; Empty file.
 238         (setq to nil))
 239        (t
 240         ;; If getting from mail spool directory, use movemail to move
 241         ;; rather than just renaming, so as to interlock with the
 242         ;; mailer.
 243         (unwind-protect
 244             (save-excursion
 245               (setq errors (generate-new-buffer " *mail source loss*"))
 246               (let ((default-directory "/"))
 247                 (setq result
 248                       (apply
 249                        'call-process
 250                        (append
 251                         (list
 252                          (expand-file-name "movemail" exec-directory)
 253                          nil errors nil from to)))))
 254               (when (file-exists-p to)
 255                 (set-file-modes to mail-source-default-file-modes))
 256               (if (and (not (buffer-modified-p errors))
 257                        (zerop result))
 258                   ;; No output => movemail won.
 259                   t
 260                 (set-buffer errors)
 261                 ;; There may be a warning about older revisions.  We
 262                 ;; ignore that.
 263                 (goto-char (point-min))
 264                 (if (search-forward "older revision" nil t)
 265                     t
 266                   ;; Probably a real error.
 267                   (subst-char-in-region (point-min) (point-max) ?\n ?\  )
 268                   (goto-char (point-max))
 269                   (skip-chars-backward " \t")
 270                   (delete-region (point) (point-max))
 271                   (goto-char (point-min))
 272                   (when (looking-at "movemail: ")
 273                     (delete-region (point-min) (match-end 0)))
 274                   (unless (yes-or-no-p
 275                            (format "movemail: %s (%d return).  Continue? "
 276                                    (buffer-string) result))
 277                     (error "%s" (buffer-string)))
 278                   (setq to nil)))))))
 279       (when (and errors
 280                  (buffer-name errors))
 281         (kill-buffer errors))
 282       ;; Return whether we moved successfully or not.
 283       to)))
 284
 285 (defvar mail-source-read-passwd nil)
 286 (defun mail-source-read-passwd (prompt &rest args)
 287   "Read a password using PROMPT.
 288 If ARGS, PROMPT is used as an argument to `format'."
 289   (let ((prompt
 290          (if args
 291              (apply 'format prompt args)
 292            prompt)))
 293     (unless mail-source-read-passwd
 294       (if (or (fboundp 'read-passwd) (load "passwd" t))
 295           (setq mail-source-read-passwd 'read-passwd)
 296         (unless (fboundp 'ange-ftp-read-passwd)
 297           (autoload 'ange-ftp-read-passwd "ange-ftp"))
 298         (setq mail-source-read-passwd 'ange-ftp-read-passwd)))
 299     (funcall mail-source-read-passwd prompt)))
 300
 301 (defun mail-source-fetch-with-program (program)
 302   (zerop (call-process shell-file-name nil nil nil
 303                        shell-command-switch program)))
 304
 305 ;;;
 306 ;;; Different fetchers
 307 ;;;
 308
 309 (defun mail-source-fetch-file (source callback)
 310   "Fetcher for single-file sources."
 311   (mail-source-bind (file source)
 312     (when prescript
 313       (if (and (symbolp prescript) (fboundp prescript))
 314           (funcall prescript)
 315         (call-process shell-file-name nil nil nil
 316                       shell-command-switch
 317                       (format-spec
 318                        prescript
 319                        (format-spec-make ?t mail-source-crash-box)))))
 320     (let ((mail-source-string (format "file:%s" path)))
 321       (if (mail-source-movemail path mail-source-crash-box)
 322           (prog1
 323               (mail-source-callback callback path)
 324             (when prescript
 325               (if (and (symbolp prescript) (fboundp prescript))
 326                   (funcall prescript)
 327                 (call-process shell-file-name nil nil nil
 328                               shell-command-switch
 329                               (format-spec
 330                                postscript
 331                                (format-spec-make ?t mail-source-crash-box))))))
 332         0))))
 333
 334 (defun mail-source-fetch-directory (source callback)
 335   "Fetcher for directory sources."
 336   (mail-source-bind (directory source)
 337     (let ((found 0)
 338           (mail-source-string (format "directory:%s" path)))
 339       (dolist (file (directory-files
 340                      path t (concat (regexp-quote suffix) "$")))
 341         (when (and (file-regular-p file)
 342                    (funcall predicate file)
 343                    (mail-source-movemail file mail-source-crash-box))
 344           (incf found (mail-source-callback callback file))))
 345       found)))
 346
 347 (defun mail-source-fetch-pop (source callback)
 348   "Fetcher for single-file sources."
 349   (mail-source-bind (pop source)
 350     (when prescript
 351       (if (and (symbolp prescript)
 352                (fboundp prescript))
 353           (funcall prescript)
 354         (call-process shell-file-name nil 0 nil
 355                       shell-command-switch
 356                       (format-spec
 357                        prescript
 358                        (format-spec-make ?p password ?t mail-source-crash-box
 359                                          ?s server ?P port ?u user)))))
 360     (let ((from (format "%s:%s:%s" server user port))
 361           (mail-source-string (format "pop:%s@%s" user server))
 362           result)
 363       (when (eq authentication 'password)
 364         (setq password
 365               (or password
 366                   (cdr (assoc from mail-source-password-cache))
 367                   (mail-source-read-passwd
 368                    (format "Password for %s at %s: " user server))))
 369         (unless (assoc from mail-source-password-cache)
 370           (push (cons from password) mail-source-password-cache)))
 371       (when server
 372         (setenv "MAILHOST" server))
 373       (setq result
 374             (cond
 375              (program
 376               (mail-source-fetch-with-program
 377                (format-spec
 378                 program
 379                 (format-spec-make ?p password ?t mail-source-crash-box
 380                                   ?s server ?P port ?u user))))
 381              (function
 382               (funcall function mail-source-crash-box))
 383              ;; The default is to use pop3.el.
 384              (t
 385               (let ((pop3-password password)
 386                     (pop3-maildrop user)
 387                     (pop3-mailhost server)
 388                     (pop3-port port)
 389                     (pop3-authentication-scheme
 390                      (if (eq authentication 'apop) 'apop 'pass)))
 391                 (save-excursion (pop3-movemail mail-source-crash-box))))))
 392       (if result
 393           (prog1
 394               (mail-source-callback callback server)
 395             (when postscript
 396               (if (and (symbolp postscript)
 397                        (fboundp postscript))
 398                   (funcall postscript)
 399                 (call-process shell-file-name nil 0 nil
 400                               shell-command-switch
 401                               (format-spec
 402                                postscript
 403                                (format-spec-make
 404                                 ?p password ?t mail-source-crash-box
 405                                 ?s server ?P port ?u user))))))
 406         ;; We nix out the password in case the error
 407         ;; was because of a wrong password being given.
 408         (setq mail-source-password-cache
 409               (delq (assoc from mail-source-password-cache)
 410                     mail-source-password-cache))
 411         0))))
 412
 413 (defun mail-source-fetch-maildir (source callback)
 414   "Fetcher for maildir sources."
 415   (mail-source-bind (maildir source)
 416     (let ((found 0)
 417           (mail-source-string (format "maildir:%s" path)))
 418       (dolist (file (directory-files path t))
 419         (when (and (file-regular-p file)
 420                    (not (rename-file file mail-source-crash-box)))
 421           (incf found (mail-source-callback callback file))))
 422       found)))
 423
 424 (provide 'mail-source)
 425
 426 ;;; mail-source.el ends here