lisp/gnus/mail-source.el

   1 ;;; mail-source.el --- functions for fetching mail
   2
   3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
   4 ;;   2008, 2009, 2010, 2011  Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; Keywords: news, mail
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 ;; For Emacs <22.2 and XEmacs.
  29 (eval-and-compile
  30   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
  31
  32 (require 'format-spec)
  33 (eval-when-compile
  34   (require 'cl)
  35   (require 'imap))
  36 (autoload 'auth-source-user-or-password "auth-source")
  37 (autoload 'pop3-movemail "pop3")
  38 (autoload 'pop3-get-message-count "pop3")
  39 (autoload 'nnheader-cancel-timer "nnheader")
  40 (require 'mm-util)
  41 (require 'message) ;; for `message-directory'
  42
  43 (defvar display-time-mail-function)
  44
  45 (defgroup mail-source nil
  46   "The mail-fetching library."
  47   :version "21.1"
  48   :group 'gnus)
  49
  50 ;; Define these at compile time to avoid dragging in imap always.
  51 (defconst mail-source-imap-authenticators
  52   (eval-when-compile
  53     (mapcar (lambda (a)
  54               (list 'const (car a)))
  55      imap-authenticator-alist)))
  56 (defconst mail-source-imap-streams
  57   (eval-when-compile
  58     (mapcar (lambda (a)
  59               (list 'const (car a)))
  60      imap-stream-alist)))
  61
  62 (defcustom mail-sources '((file))
  63   "Where the mail backends will look for incoming mail.
  64 This variable is a list of mail source specifiers.
  65 See Info node `(gnus)Mail Source Specifiers'."
  66   :group 'mail-source
  67   :version "23.1" ;; No Gnus
  68   :link '(custom-manual "(gnus)Mail Source Specifiers")
  69   :type `(choice
  70           (const :tag "None" nil)
  71           (repeat :tag "List"
  72            (choice :format "%[Value Menu%] %v"
  73                    :value (file)
  74                    (cons :tag "Group parameter `mail-source'"
  75                          (const :format "" group))
  76                    (cons :tag "Spool file"
  77                          (const :format "" file)
  78                          (checklist :tag "Options" :greedy t
  79                                     (group :inline t
  80                                            (const :format "" :value :path)
  81                                            file)))
  82                    (cons :tag "Several files in a directory"
  83                          (const :format "" directory)
  84                          (checklist :tag "Options" :greedy t
  85                                     (group :inline t
  86                                            (const :format "" :value :path)
  87                                            (directory :tag "Path"))
  88                                     (group :inline t
  89                                            (const :format "" :value :suffix)
  90                                            (string :tag "Suffix"))
  91                                     (group :inline t
  92                                            (const :format "" :value :predicate)
  93                                            (function :tag "Predicate"))
  94                                     (group :inline t
  95                                            (const :format "" :value :prescript)
  96                                            (choice :tag "Prescript"
  97                                                    :value nil
  98                                                    (string :format "%v")
  99                                                    (function :format "%v")))
 100                                     (group :inline t
 101                                            (const :format "" :value :postscript)
 102                                            (choice :tag "Postscript"
 103                                                    :value nil
 104                                                    (string :format "%v")
 105                                                    (function :format "%v")))
 106                                     (group :inline t
 107                                            (const :format "" :value :plugged)
 108                                            (boolean :tag "Plugged"))))
 109                    (cons :tag "POP3 server"
 110                          (const :format "" pop)
 111                          (checklist :tag "Options" :greedy t
 112                                     (group :inline t
 113                                            (const :format "" :value :server)
 114                                            (string :tag "Server"))
 115                                     (group :inline t
 116                                            (const :format "" :value :port)
 117                                            (choice :tag "Port"
 118                                                    :value "pop3"
 119                                                    (integer :format "%v")
 120                                                    (string :format "%v")))
 121                                     (group :inline t
 122                                            (const :format "" :value :user)
 123                                            (string :tag "User"))
 124                                     (group :inline t
 125                                            (const :format "" :value :password)
 126                                            (string :tag "Password"))
 127                                     (group :inline t
 128                                            (const :format "" :value :program)
 129                                            (string :tag "Program"))
 130                                     (group :inline t
 131                                            (const :format "" :value :prescript)
 132                                            (choice :tag "Prescript"
 133                                                    :value nil
 134                                                    (string :format "%v")
 135                                                    (function :format "%v")
 136                                                    (const :tag "None" nil)))
 137                                     (group :inline t
 138                                            (const :format "" :value :postscript)
 139                                            (choice :tag "Postscript"
 140                                                    :value nil
 141                                                    (string :format "%v")
 142                                                    (function :format "%v")
 143                                                    (const :tag "None" nil)))
 144                                     (group :inline t
 145                                            (const :format "" :value :function)
 146                                            (function :tag "Function"))
 147                                     (group :inline t
 148                                            (const :format ""
 149                                                   :value :authentication)
 150                                            (choice :tag "Authentication"
 151                                                    :value apop
 152                                                    (const password)
 153                                                    (const apop)))
 154                                     (group :inline t
 155                                            (const :format "" :value :plugged)
 156                                            (boolean :tag "Plugged"))
 157                                     (group :inline t
 158                                            (const :format "" :value :stream)
 159                                            (choice :tag "Stream"
 160                                                    :value nil
 161                                                    (const :tag "Clear" nil)
 162                                                    (const starttls)
 163                                                    (const :tag "SSL/TLS" ssl)))))
 164                    (cons :tag "Maildir (qmail, postfix...)"
 165                          (const :format "" maildir)
 166                          (checklist :tag "Options" :greedy t
 167                                     (group :inline t
 168                                            (const :format "" :value :path)
 169                                            (directory :tag "Path"))
 170                                     (group :inline t
 171                                            (const :format "" :value :plugged)
 172                                            (boolean :tag "Plugged"))))
 173                    (cons :tag "IMAP server"
 174                          (const :format "" imap)
 175                          (checklist :tag "Options" :greedy t
 176                                     (group :inline t
 177                                            (const :format "" :value :server)
 178                                            (string :tag "Server"))
 179                                     (group :inline t
 180                                            (const :format "" :value :port)
 181                                            (choice :tag "Port"
 182                                                    :value 143
 183                                                    integer string))
 184                                     (group :inline t
 185                                            (const :format "" :value :user)
 186                                            (string :tag "User"))
 187                                     (group :inline t
 188                                            (const :format "" :value :password)
 189                                            (string :tag "Password"))
 190                                     (group :inline t
 191                                            (const :format "" :value :stream)
 192                                            (choice :tag "Stream"
 193                                                    :value network
 194                                                    ,@mail-source-imap-streams))
 195                                     (group :inline t
 196                                            (const :format "" :value :program)
 197                                            (string :tag "Program"))
 198                                     (group :inline t
 199                                            (const :format ""
 200                                                   :value :authenticator)
 201                                            (choice :tag "Authenticator"
 202                                                    :value login
 203                                                    ,@mail-source-imap-authenticators))
 204                                     (group :inline t
 205                                            (const :format "" :value :mailbox)
 206                                            (string :tag "Mailbox"
 207                                                    :value "INBOX"))
 208                                     (group :inline t
 209                                            (const :format "" :value :predicate)
 210                                            (string :tag "Predicate"
 211                                                    :value "UNSEEN UNDELETED"))
 212                                     (group :inline t
 213                                            (const :format "" :value :fetchflag)
 214                                            (string :tag "Fetchflag"
 215                                                    :value  "\\Deleted"))
 216                                     (group :inline t
 217                                            (const :format ""
 218                                                   :value :dontexpunge)
 219                                            (boolean :tag "Dontexpunge"))
 220                                     (group :inline t
 221                                            (const :format "" :value :plugged)
 222                                            (boolean :tag "Plugged"))))))))
 223
 224 (defcustom mail-source-ignore-errors nil
 225   "*Ignore errors when querying mail sources.
 226 If nil, the user will be prompted when an error occurs.  If non-nil,
 227 the error will be ignored."
 228   :version "22.1"
 229   :group 'mail-source
 230   :type 'boolean)
 231
 232 (defcustom mail-source-primary-source nil
 233   "*Primary source for incoming mail.
 234 If non-nil, this maildrop will be checked periodically for new mail."
 235   :group 'mail-source
 236   :type 'sexp)
 237
 238 (defcustom mail-source-flash t
 239   "*If non-nil, flash periodically when mail is available."
 240   :group 'mail-source
 241   :type 'boolean)
 242
 243 (defcustom mail-source-crash-box "~/.emacs-mail-crash-box"
 244   "File where mail will be stored while processing it."
 245   :group 'mail-source
 246   :type 'file)
 247
 248 (defcustom mail-source-directory message-directory
 249   "Directory where incoming mail source files (if any) will be stored."
 250   :group 'mail-source
 251   :type 'directory)
 252
 253 (defcustom mail-source-default-file-modes 384
 254   "Set the mode bits of all new mail files to this integer."
 255   :group 'mail-source
 256   :type 'integer)
 257
 258 (defcustom mail-source-delete-incoming
 259   10 ;; development versions
 260   ;; 2 ;; released versions
 261   "If non-nil, delete incoming files after handling.
 262 If t, delete immediately, if nil, never delete.  If a positive number, delete
 263 files older than number of days.
 264
 265 Removing of old files happens in `mail-source-callback', i.e. no
 266 old incoming files will be deleted unless you receive new mail.
 267 You may also set this variable to nil and call
 268 `mail-source-delete-old-incoming' interactively."
 269   :group 'mail-source
 270   :version "22.2" ;; No Gnus / Gnus 5.10.10 (default changed)
 271   :type '(choice (const :tag "immediately" t)
 272                  (const :tag "never" nil)
 273                  (integer :tag "days")))
 274
 275 (defcustom mail-source-delete-old-incoming-confirm nil
 276   "If non-nil, ask for confirmation before deleting old incoming files.
 277 This variable only applies when `mail-source-delete-incoming' is a positive
 278 number."
 279   :version "22.2" ;; No Gnus / Gnus 5.10.10 (default changed)
 280   :group 'mail-source
 281   :type 'boolean)
 282
 283 (defcustom mail-source-incoming-file-prefix "Incoming"
 284   "Prefix for file name for storing incoming mail"
 285   :group 'mail-source
 286   :type 'string)
 287
 288 (defcustom mail-source-report-new-mail-interval 5
 289   "Interval in minutes between checks for new mail."
 290   :group 'mail-source
 291   :type 'number)
 292
 293 (defcustom mail-source-idle-time-delay 5
 294   "Number of idle seconds to wait before checking for new mail."
 295   :group 'mail-source
 296   :type 'number)
 297
 298 (defcustom mail-source-movemail-program nil
 299   "If non-nil, name of program for fetching new mail."
 300   :version "22.1"
 301   :group 'mail-source
 302   :type '(choice (const nil) string))
 303
 304 ;;; Internal variables.
 305
 306 (defvar mail-source-string ""
 307   "A dynamically bound string that says what the current mail source is.")
 308
 309 (defvar mail-source-new-mail-available nil
 310   "Flag indicating when new mail is available.")
 311
 312 (eval-and-compile
 313   (defvar mail-source-common-keyword-map
 314     '((:plugged))
 315     "Mapping from keywords to default values.
 316 Common keywords should be listed here.")
 317
 318   (defvar mail-source-keyword-map
 319     '((file
 320        (:prescript)
 321        (:prescript-delay)
 322        (:postscript)
 323        (:path (or (getenv "MAIL")
 324                   (expand-file-name (user-login-name) rmail-spool-directory))))
 325       (directory
 326        (:prescript)
 327        (:prescript-delay)
 328        (:postscript)
 329        (:path)
 330        (:suffix ".spool")
 331        (:predicate identity))
 332       (pop
 333        (:prescript)
 334        (:prescript-delay)
 335        (:postscript)
 336        (:server (getenv "MAILHOST"))
 337        (:port 110)
 338        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
 339        (:program)
 340        (:function)
 341        (:password)
 342        (:authentication password)
 343        (:stream nil))
 344       (maildir
 345        (:path (or (getenv "MAILDIR") "~/Maildir/"))
 346        (:subdirs ("cur" "new"))
 347        (:function))
 348       (imap
 349        (:server (getenv "MAILHOST"))
 350        (:port)
 351        (:stream)
 352        (:program)
 353        (:authentication)
 354        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
 355        (:password)
 356        (:mailbox "INBOX")
 357        (:predicate "UNSEEN UNDELETED")
 358        (:fetchflag "\\Deleted")
 359        (:prescript)
 360        (:prescript-delay)
 361        (:postscript)
 362        (:dontexpunge)))
 363     "Mapping from keywords to default values.
 364 All keywords that can be used must be listed here."))
 365
 366 (defvar mail-source-fetcher-alist
 367   '((file mail-source-fetch-file)
 368     (directory mail-source-fetch-directory)
 369     (pop mail-source-fetch-pop)
 370     (maildir mail-source-fetch-maildir)
 371     (imap mail-source-fetch-imap))
 372   "A mapping from source type to fetcher function.")
 373
 374 (defvar mail-source-password-cache nil)
 375
 376 (defvar mail-source-plugged t)
 377
 378 ;;; Functions
 379
 380 (eval-and-compile
 381   (defun mail-source-strip-keyword (keyword)
 382     "Strip the leading colon off the KEYWORD."
 383     (intern (substring (symbol-name keyword) 1))))
 384
 385 ;; generate a list of variable names paired with nil values
 386 ;; suitable for usage in a `let' form
 387 (eval-and-compile
 388   (defun mail-source-bind-1 (type)
 389     (let* ((defaults (cdr (assq type mail-source-keyword-map)))
 390            default bind)
 391       (while (setq default (pop defaults))
 392         (push (list (mail-source-strip-keyword (car default))
 393                     nil)
 394               bind))
 395       bind)))
 396
 397 (defmacro mail-source-bind (type-source &rest body)
 398   "Return a `let' form that binds all variables in source TYPE.
 399 TYPE-SOURCE is a list where the first element is the TYPE, and
 400 the second variable is the SOURCE.
 401 At run time, the mail source specifier SOURCE will be inspected,
 402 and the variables will be set according to it.  Variables not
 403 specified will be given default values.
 404
 405 The user and password will be loaded from the auth-source values
 406 if those are available.  They override the original user and
 407 password in a second `let' form.
 408
 409 After this is done, BODY will be executed in the scope
 410 of the second `let' form.
 411
 412 The variables bound and their default values are described by
 413 the `mail-source-keyword-map' variable."
 414   `(let* ,(mail-source-bind-1 (car type-source))
 415      (mail-source-set-1 ,(cadr type-source))
 416      ,@body))
 417
 418 (put 'mail-source-bind 'lisp-indent-function 1)
 419 (put 'mail-source-bind 'edebug-form-spec '(sexp body))
 420
 421 ;; TODO: use the list format for auth-source-user-or-password modes
 422 (defun mail-source-set-1 (source)
 423   (let* ((type (pop source))
 424          (defaults (cdr (assq type mail-source-keyword-map)))
 425          default value keyword auth-info user-auth pass-auth)
 426     (while (setq default (pop defaults))
 427       ;; for each default :SYMBOL, set SYMBOL to the plist value for :SYMBOL
 428       ;; using `mail-source-value' to evaluate the plist value
 429       (set (mail-source-strip-keyword (setq keyword (car default)))
 430            ;; note the following reasons for this structure:
 431            ;; 1) the auth-sources user and password override everything
 432            ;; 2) it avoids macros, so it's cleaner
 433            ;; 3) it falls through to the mail-sources and then default values
 434            (cond
 435             ((and
 436              (eq keyword :user)
 437              (setq user-auth
 438                    (nth 0 (auth-source-user-or-password
 439                            '("login" "password")
 440                            ;; this is "host" in auth-sources
 441                            (if (boundp 'server) (symbol-value 'server) "")
 442                            type))))
 443              user-auth)
 444             ((and
 445               (eq keyword :password)
 446               (setq pass-auth
 447                     (nth 1
 448                          (auth-source-user-or-password
 449                           '("login" "password")
 450                           ;; this is "host" in auth-sources
 451                           (if (boundp 'server) (symbol-value 'server) "")
 452                           type))))
 453              pass-auth)
 454             (t (if (setq value (plist-get source keyword))
 455                  (mail-source-value value)
 456                (mail-source-value (cadr default)))))))))
 457
 458 (eval-and-compile
 459   (defun mail-source-bind-common-1 ()
 460     (let* ((defaults mail-source-common-keyword-map)
 461            default bind)
 462       (while (setq default (pop defaults))
 463         (push (list (mail-source-strip-keyword (car default))
 464                     nil)
 465               bind))
 466       bind)))
 467
 468 (defun mail-source-set-common-1 (source)
 469   (let* ((type (pop source))
 470          (defaults mail-source-common-keyword-map)
 471          (defaults-1 (cdr (assq type mail-source-keyword-map)))
 472          default value keyword)
 473     (while (setq default (pop defaults))
 474       (set (mail-source-strip-keyword (setq keyword (car default)))
 475            (if (setq value (plist-get source keyword))
 476                (mail-source-value value)
 477              (if (setq value (assq  keyword defaults-1))
 478                  (mail-source-value (cadr value))
 479                (mail-source-value (cadr default))))))))
 480
 481 (defmacro mail-source-bind-common (source &rest body)
 482   "Return a `let' form that binds all common variables.
 483 See `mail-source-bind'."
 484   `(let ,(mail-source-bind-common-1)
 485      (mail-source-set-common-1 source)
 486      ,@body))
 487
 488 (put 'mail-source-bind-common 'lisp-indent-function 1)
 489 (put 'mail-source-bind-common 'edebug-form-spec '(sexp body))
 490
 491 (defun mail-source-value (value)
 492   "Return the value of VALUE."
 493   (cond
 494    ;; String
 495    ((stringp value)
 496     value)
 497    ;; Function
 498    ((and (listp value) (symbolp (car value)) (fboundp (car value)))
 499     (eval value))
 500    ;; Just return the value.
 501    (t
 502     value)))
 503
 504 (autoload 'nnheader-message "nnheader")
 505
 506 (defun mail-source-fetch (source callback &optional method)
 507   "Fetch mail from SOURCE and call CALLBACK zero or more times.
 508 CALLBACK will be called with the name of the file where (some of)
 509 the mail from SOURCE is put.
 510 Return the number of files that were found."
 511   (mail-source-bind-common source
 512     (if (or mail-source-plugged plugged)
 513         (save-excursion
 514           ;; Special-case the `file' handler since it's so common and
 515           ;; just adds noise.
 516           (when (or (not (eq (car source) 'file))
 517                     (mail-source-bind (file source)
 518                       (file-exists-p path)))
 519             (nnheader-message 4 "%sReading incoming mail from %s..."
 520                               (if method
 521                                   (format "%s: " method)
 522                                 "")
 523                               (car source)))
 524           (let ((function (cadr (assq (car source) mail-source-fetcher-alist)))
 525                 (found 0))
 526             (unless function
 527               (error "%S is an invalid mail source specification" source))
 528             ;; If there's anything in the crash box, we do it first.
 529             (when (file-exists-p mail-source-crash-box)
 530               (message "Processing mail from %s..." mail-source-crash-box)
 531               (setq found (mail-source-callback
 532                            callback mail-source-crash-box))
 533               (mail-source-delete-crash-box))
 534             (+ found
 535                (if (or debug-on-quit debug-on-error)
 536                    (funcall function source callback)
 537                  (condition-case err
 538                      (funcall function source callback)
 539                    (error
 540                     (if (and (not mail-source-ignore-errors)
 541                              (not
 542                               (yes-or-no-p
 543                                (format "Mail source %s error (%s).  Continue? "
 544                                        (if (memq ':password source)
 545                                            (let ((s (copy-sequence source)))
 546                                              (setcar (cdr (memq ':password s))
 547                                                      "********")
 548                                              s)
 549                                          source)
 550                                        (cadr err)))))
 551                       (error "Cannot get new mail"))
 552                     0)))))))))
 553
 554 (declare-function gnus-message "gnus-util" (level &rest args))
 555
 556 (defun mail-source-delete-old-incoming (&optional age confirm)
 557   "Remove incoming files older than AGE days.
 558 If CONFIRM is non-nil, ask for confirmation before removing a file."
 559   (interactive "P")
 560   (require 'gnus-util)
 561   (let* ((high2days (/ 65536.0 60 60 24));; convert high bits to days
 562          (low2days  (/ 1.0 65536.0))     ;; convert low bits to days
 563          (diff (if (natnump age) age 30));; fallback, if no valid AGE given
 564          currday files)
 565     (setq files (directory-files
 566                  mail-source-directory t
 567                  (concat "\\`"
 568                          (regexp-quote mail-source-incoming-file-prefix)))
 569           currday (* (car (current-time)) high2days)
 570           currday (+ currday (* low2days (nth 1 (current-time)))))
 571     (while files
 572       (let* ((ffile (car files))
 573              (bfile (gnus-replace-in-string
 574                      ffile "\\`.*/\\([^/]+\\)\\'" "\\1"))
 575              (filetime (nth 5 (file-attributes ffile)))
 576              (fileday (* (car filetime) high2days))
 577              (fileday (+ fileday (* low2days (nth 1 filetime)))))
 578         (setq files (cdr files))
 579         (when (and (> (- currday fileday) diff)
 580                    (if confirm
 581                        (y-or-n-p
 582                         (format "\
 583 Delete old (> %s day(s)) incoming mail file `%s'? " diff bfile))
 584                      (gnus-message 8 "\
 585 Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
 586                      t))
 587           (delete-file ffile))))))
 588
 589 (defun mail-source-callback (callback info)
 590   "Call CALLBACK on the mail file.  Pass INFO on to CALLBACK."
 591   (if (or (not (file-exists-p mail-source-crash-box))
 592           (zerop (nth 7 (file-attributes mail-source-crash-box))))
 593       (progn
 594         (when (file-exists-p mail-source-crash-box)
 595           (delete-file mail-source-crash-box))
 596         0)
 597     (funcall callback mail-source-crash-box info)))
 598
 599 (autoload 'gnus-float-time "gnus-util")
 600
 601 (defvar mail-source-incoming-last-checked-time nil)
 602
 603 (defun mail-source-delete-crash-box ()
 604   (when (file-exists-p mail-source-crash-box)
 605     ;; Delete or move the incoming mail out of the way.
 606     (if (eq mail-source-delete-incoming t)
 607         (delete-file mail-source-crash-box)
 608       (let ((incoming
 609              (mm-make-temp-file
 610               (expand-file-name
 611                mail-source-incoming-file-prefix
 612                mail-source-directory))))
 613         (unless (file-exists-p (file-name-directory incoming))
 614           (make-directory (file-name-directory incoming) t))
 615         (rename-file mail-source-crash-box incoming t)
 616         ;; remove old incoming files?
 617         (when (natnump mail-source-delete-incoming)
 618           ;; Don't check for old incoming files more than once per day to
 619           ;; save a lot of file accesses.
 620           (when (or (null mail-source-incoming-last-checked-time)
 621                     (> (gnus-float-time
 622                         (time-since mail-source-incoming-last-checked-time))
 623                        (* 24 60 60)))
 624             (setq mail-source-incoming-last-checked-time (current-time))
 625             (mail-source-delete-old-incoming
 626              mail-source-delete-incoming
 627              mail-source-delete-old-incoming-confirm)))))))
 628
 629 (defun mail-source-movemail (from to)
 630   "Move FROM to TO using movemail."
 631   (if (not (file-writable-p to))
 632       (error "Can't write to crash box %s.  Not moving mail" to)
 633     (let ((to (file-truename (expand-file-name to)))
 634           errors result)
 635       (setq to (file-truename to)
 636             from (file-truename from))
 637       ;; Set TO if have not already done so, and rename or copy
 638       ;; the file FROM to TO if and as appropriate.
 639       (cond
 640        ((file-exists-p to)
 641         ;; The crash box exists already.
 642         t)
 643        ((not (file-exists-p from))
 644         ;; There is no inbox.
 645         (setq to nil))
 646        ((zerop (nth 7 (file-attributes from)))
 647         ;; Empty file.
 648         (setq to nil))
 649        (t
 650         ;; If getting from mail spool directory, use movemail to move
 651         ;; rather than just renaming, so as to interlock with the
 652         ;; mailer.
 653         (unwind-protect
 654             (save-excursion
 655               (setq errors (generate-new-buffer " *mail source loss*"))
 656               (let ((default-directory "/"))
 657                 (setq result
 658                       (apply
 659                        'call-process
 660                        (append
 661                         (list
 662                          (or mail-source-movemail-program
 663                              (expand-file-name "movemail" exec-directory))
 664                          nil errors nil from to)))))
 665               (when (file-exists-p to)
 666                 (set-file-modes to mail-source-default-file-modes))
 667               (if (and (or (not (buffer-modified-p errors))
 668                            (zerop (buffer-size errors)))
 669                        (and (numberp result)
 670                             (zerop result)))
 671                   ;; No output => movemail won.
 672                   t
 673                 (set-buffer errors)
 674                 ;; There may be a warning about older revisions.  We
 675                 ;; ignore that.
 676                 (goto-char (point-min))
 677                 (if (search-forward "older revision" nil t)
 678                     t
 679                   ;; Probably a real error.
 680                   (subst-char-in-region (point-min) (point-max) ?\n ?\  )
 681                   (goto-char (point-max))
 682                   (skip-chars-backward " \t")
 683                   (delete-region (point) (point-max))
 684                   (goto-char (point-min))
 685                   (when (looking-at "movemail: ")
 686                     (delete-region (point-min) (match-end 0)))
 687                   ;; Result may be a signal description string.
 688                   (unless (yes-or-no-p
 689                            (format "movemail: %s (%s return).  Continue? "
 690                                    (buffer-string) result))
 691                     (error "%s" (buffer-string)))
 692                   (setq to nil)))))))
 693       (when (and errors
 694                  (buffer-name errors))
 695         (kill-buffer errors))
 696       ;; Return whether we moved successfully or not.
 697       to)))
 698
 699 (defun mail-source-movemail-and-remove (from to)
 700   "Move FROM to TO using movemail, then remove FROM if empty."
 701   (or (not (mail-source-movemail from to))
 702       (not (zerop (nth 7 (file-attributes from))))
 703       (delete-file from)))
 704
 705 (defun mail-source-fetch-with-program (program)
 706   (eq 0 (call-process shell-file-name nil nil nil
 707                       shell-command-switch program)))
 708
 709 (defun mail-source-run-script (script spec &optional delay)
 710   (when script
 711     (if (functionp script)
 712         (funcall script)
 713       (mail-source-call-script
 714        (format-spec script spec))))
 715   (when delay
 716     (sleep-for delay)))
 717
 718 (defun mail-source-call-script (script)
 719   (let ((background nil)
 720         (stderr (get-buffer-create " *mail-source-stderr*"))
 721         result)
 722     (when (string-match "& *$" script)
 723       (setq script (substring script 0 (match-beginning 0))
 724             background 0))
 725     (setq result
 726           (call-process shell-file-name nil background nil
 727                         shell-command-switch script))
 728     (when (and result
 729                (not (zerop result)))
 730       (set-buffer stderr)
 731       (message "Mail source error: %s" (buffer-string)))
 732     (kill-buffer stderr)))
 733
 734 ;;;
 735 ;;; Different fetchers
 736 ;;;
 737
 738 (defun mail-source-fetch-file (source callback)
 739   "Fetcher for single-file sources."
 740   (mail-source-bind (file source)
 741     (mail-source-run-script
 742      prescript (format-spec-make ?t mail-source-crash-box)
 743      prescript-delay)
 744     (let ((mail-source-string (format "file:%s" path)))
 745       (if (mail-source-movemail path mail-source-crash-box)
 746           (prog1
 747               (mail-source-callback callback path)
 748             (mail-source-run-script
 749              postscript (format-spec-make ?t mail-source-crash-box))
 750             (mail-source-delete-crash-box))
 751         0))))
 752
 753 (defun mail-source-fetch-directory (source callback)
 754   "Fetcher for directory sources."
 755   (mail-source-bind (directory source)
 756     (mail-source-run-script
 757      prescript (format-spec-make ?t path) prescript-delay)
 758     (let ((found 0)
 759           (mail-source-string (format "directory:%s" path)))
 760       (dolist (file (directory-files
 761                      path t (concat (regexp-quote suffix) "$")))
 762         (when (and (file-regular-p file)
 763                    (funcall predicate file)
 764                    (mail-source-movemail file mail-source-crash-box))
 765           (incf found (mail-source-callback callback file))
 766           (mail-source-run-script postscript (format-spec-make ?t path))
 767           (mail-source-delete-crash-box)))
 768       found)))
 769
 770 (defun mail-source-fetch-pop (source callback)
 771   "Fetcher for single-file sources."
 772   (mail-source-bind (pop source)
 773     ;; fixme: deal with stream type in format specs
 774     (mail-source-run-script
 775      prescript
 776      (format-spec-make ?p password ?t mail-source-crash-box
 777                        ?s server ?P port ?u user)
 778      prescript-delay)
 779     (let ((from (format "%s:%s:%s" server user port))
 780           (mail-source-string (format "pop:%s@%s" user server))
 781           result)
 782       (when (eq authentication 'password)
 783         (setq password
 784               (or password
 785                   (cdr (assoc from mail-source-password-cache))
 786                   (read-passwd
 787                    (format "Password for %s at %s: " user server)))))
 788       (when server
 789         (setenv "MAILHOST" server))
 790       (setq result
 791             (cond
 792              (program
 793               (mail-source-fetch-with-program
 794                (format-spec
 795                 program
 796                 (format-spec-make ?p password ?t mail-source-crash-box
 797                                   ?s server ?P port ?u user))))
 798              (function
 799               (funcall function mail-source-crash-box))
 800              ;; The default is to use pop3.el.
 801              (t
 802               (require 'pop3)
 803               (let ((pop3-password password)
 804                     (pop3-maildrop user)
 805                     (pop3-mailhost server)
 806                     (pop3-port port)
 807                     (pop3-authentication-scheme
 808                      (if (eq authentication 'apop) 'apop 'pass))
 809                     (pop3-stream-type stream))
 810                 (if (or debug-on-quit debug-on-error)
 811                     (save-excursion (pop3-movemail mail-source-crash-box))
 812                   (condition-case err
 813                       (save-excursion (pop3-movemail mail-source-crash-box))
 814                     (error
 815                      ;; We nix out the password in case the error
 816                      ;; was because of a wrong password being given.
 817                      (setq mail-source-password-cache
 818                            (delq (assoc from mail-source-password-cache)
 819                                  mail-source-password-cache))
 820                      (signal (car err) (cdr err)))))))))
 821       (if result
 822           (progn
 823             (when (eq authentication 'password)
 824               (unless (assoc from mail-source-password-cache)
 825                 (push (cons from password) mail-source-password-cache)))
 826             (prog1
 827                 (mail-source-callback callback server)
 828               ;; Update display-time's mail flag, if relevant.
 829               (if (equal source mail-source-primary-source)
 830                   (setq mail-source-new-mail-available nil))
 831               (mail-source-run-script
 832                postscript
 833                (format-spec-make ?p password ?t mail-source-crash-box
 834                                  ?s server ?P port ?u user))
 835               (mail-source-delete-crash-box)))
 836         ;; We nix out the password in case the error
 837         ;; was because of a wrong password being given.
 838         (setq mail-source-password-cache
 839               (delq (assoc from mail-source-password-cache)
 840                     mail-source-password-cache))
 841         0))))
 842
 843 (defun mail-source-check-pop (source)
 844   "Check whether there is new mail."
 845   (mail-source-bind (pop source)
 846     (let ((from (format "%s:%s:%s" server user port))
 847           (mail-source-string (format "pop:%s@%s" user server))
 848           result)
 849       (when (eq authentication 'password)
 850         (setq password
 851               (or password
 852                   (cdr (assoc from mail-source-password-cache))
 853                   (read-passwd
 854                    (format "Password for %s at %s: " user server))))
 855         (unless (assoc from mail-source-password-cache)
 856           (push (cons from password) mail-source-password-cache)))
 857       (when server
 858         (setenv "MAILHOST" server))
 859       (setq result
 860             (cond
 861              ;; No easy way to check whether mail is waiting for these.
 862              (program)
 863              (function)
 864              ;; The default is to use pop3.el.
 865              (t
 866               (require 'pop3)
 867               (let ((pop3-password password)
 868                     (pop3-maildrop user)
 869                     (pop3-mailhost server)
 870                     (pop3-port port)
 871                     (pop3-authentication-scheme
 872                      (if (eq authentication 'apop) 'apop 'pass)))
 873                 (if (or debug-on-quit debug-on-error)
 874                     (save-excursion (pop3-get-message-count))
 875                   (condition-case err
 876                       (save-excursion (pop3-get-message-count))
 877                     (error
 878                      ;; We nix out the password in case the error
 879                      ;; was because of a wrong password being given.
 880                      (setq mail-source-password-cache
 881                            (delq (assoc from mail-source-password-cache)
 882                                  mail-source-password-cache))
 883                      (signal (car err) (cdr err)))))))))
 884       (if result
 885           ;; Inform display-time that we have new mail.
 886           (setq mail-source-new-mail-available (> result 0))
 887         ;; We nix out the password in case the error
 888         ;; was because of a wrong password being given.
 889         (setq mail-source-password-cache
 890               (delq (assoc from mail-source-password-cache)
 891                     mail-source-password-cache)))
 892       result)))
 893
 894 (defun mail-source-touch-pop ()
 895   "Open and close a POP connection shortly.
 896 POP server should be defined in `mail-source-primary-source' (which is
 897 preferred) or `mail-sources'.  You may use it for the POP-before-SMTP
 898 authentication.  To do that, you need to set the
 899 `message-send-mail-function' variable as `message-smtpmail-send-it'
 900 and put the following line in your ~/.gnus.el file:
 901
 902 \(add-hook 'message-send-mail-hook 'mail-source-touch-pop)
 903
 904 See the Gnus manual for details."
 905   (let ((sources (if mail-source-primary-source
 906                      (list mail-source-primary-source)
 907                    mail-sources)))
 908     (while sources
 909       (if (eq 'pop (car (car sources)))
 910           (mail-source-check-pop (car sources)))
 911       (setq sources (cdr sources)))))
 912
 913 (defun mail-source-new-mail-p ()
 914   "Handler for `display-time' to indicate when new mail is available."
 915   ;; Flash (ie. ring the visible bell) if mail is available.
 916   (if (and mail-source-flash mail-source-new-mail-available)
 917       (let ((visible-bell t))
 918         (ding)))
 919   ;; Only report flag setting; flag is updated on a different schedule.
 920   mail-source-new-mail-available)
 921
 922
 923 (defvar mail-source-report-new-mail nil)
 924 (defvar mail-source-report-new-mail-timer nil)
 925 (defvar mail-source-report-new-mail-idle-timer nil)
 926
 927 (defun mail-source-start-idle-timer ()
 928   ;; Start our idle timer if necessary, so we delay the check until the
 929   ;; user isn't typing.
 930   (unless mail-source-report-new-mail-idle-timer
 931     (setq mail-source-report-new-mail-idle-timer
 932           (run-with-idle-timer
 933            mail-source-idle-time-delay
 934            nil
 935            (lambda ()
 936              (unwind-protect
 937                  (mail-source-check-pop mail-source-primary-source)
 938                (setq mail-source-report-new-mail-idle-timer nil)))))
 939     ;; Since idle timers created when Emacs is already in the idle
 940     ;; state don't get activated until Emacs _next_ becomes idle, we
 941     ;; need to force our timer to be considered active now.  We do
 942     ;; this by being naughty and poking the timer internals directly
 943     ;; (element 0 of the vector is nil if the timer is active).
 944     (aset mail-source-report-new-mail-idle-timer 0 nil)))
 945
 946 (defun mail-source-report-new-mail (arg)
 947   "Toggle whether to report when new mail is available.
 948 This only works when `display-time' is enabled."
 949   (interactive "P")
 950   (if (not mail-source-primary-source)
 951       (error "Need to set `mail-source-primary-source' to check for new mail"))
 952   (let ((on (if (null arg)
 953                 (not mail-source-report-new-mail)
 954               (> (prefix-numeric-value arg) 0))))
 955     (setq mail-source-report-new-mail on)
 956     (and mail-source-report-new-mail-timer
 957          (nnheader-cancel-timer mail-source-report-new-mail-timer))
 958     (and mail-source-report-new-mail-idle-timer
 959          (nnheader-cancel-timer mail-source-report-new-mail-idle-timer))
 960     (setq mail-source-report-new-mail-timer nil)
 961     (setq mail-source-report-new-mail-idle-timer nil)
 962     (if on
 963         (progn
 964           (require 'time)
 965           ;; display-time-mail-function is an Emacs feature.
 966           (setq display-time-mail-function #'mail-source-new-mail-p)
 967           ;; Set up the main timer.
 968           (setq mail-source-report-new-mail-timer
 969                 (run-at-time
 970                  (* 60 mail-source-report-new-mail-interval)
 971                  (* 60 mail-source-report-new-mail-interval)
 972                  #'mail-source-start-idle-timer))
 973           ;; When you get new mail, clear "Mail" from the mode line.
 974           (add-hook 'nnmail-post-get-new-mail-hook
 975                     'display-time-event-handler)
 976           (message "Mail check enabled"))
 977       (setq display-time-mail-function nil)
 978       (remove-hook 'nnmail-post-get-new-mail-hook
 979                    'display-time-event-handler)
 980       (message "Mail check disabled"))))
 981
 982 (defun mail-source-fetch-maildir (source callback)
 983   "Fetcher for maildir sources."
 984   (mail-source-bind (maildir source)
 985     (let ((found 0)
 986           mail-source-string)
 987       (unless (string-match "/$" path)
 988         (setq path (concat path "/")))
 989       (dolist (subdir subdirs)
 990         (when (file-directory-p (concat path subdir))
 991           (setq mail-source-string (format "maildir:%s%s" path subdir))
 992           (dolist (file (directory-files (concat path subdir) t))
 993             (when (and (not (file-directory-p file))
 994                        (not (if function
 995                                 (funcall function file mail-source-crash-box)
 996                               (let ((coding-system-for-write
 997                                      mm-text-coding-system)
 998                                     (coding-system-for-read
 999                                      mm-text-coding-system))
1000                                 (with-temp-file mail-source-crash-box
1001                                   (insert-file-contents file)
1002                                   (goto-char (point-min))
1003 ;;;                               ;; Unix mail format
1004 ;;;                               (unless (looking-at "\n*From ")
1005 ;;;                                 (insert "From maildir "
1006 ;;;                                         (current-time-string) "\n"))
1007 ;;;                               (while (re-search-forward "^From " nil t)
1008 ;;;                                 (replace-match ">From "))
1009 ;;;                               (goto-char (point-max))
1010 ;;;                               (insert "\n\n")
1011                                   ;; MMDF mail format
1012                                   (insert "\001\001\001\001\n"))
1013                                 (delete-file file)))))
1014               (incf found (mail-source-callback callback file))
1015               (mail-source-delete-crash-box)))))
1016       found)))
1017
1018 (autoload 'imap-open "imap")
1019 (autoload 'imap-authenticate "imap")
1020 (autoload 'imap-mailbox-select "imap")
1021 (autoload 'imap-mailbox-unselect "imap")
1022 (autoload 'imap-mailbox-close "imap")
1023 (autoload 'imap-search "imap")
1024 (autoload 'imap-fetch "imap")
1025 (autoload 'imap-close "imap")
1026 (autoload 'imap-error-text "imap")
1027 (autoload 'imap-message-flags-add "imap")
1028 (autoload 'imap-list-to-message-set "imap")
1029 (autoload 'imap-range-to-message-set "imap")
1030 (autoload 'nnheader-ms-strip-cr "nnheader")
1031
1032 (autoload 'gnus-compress-sequence "gnus-range")
1033
1034 (defvar mail-source-imap-file-coding-system 'binary
1035   "Coding system for the crashbox made by `mail-source-fetch-imap'.")
1036
1037 ;; Autoloads will bring in imap before this is called.
1038 (declare-function imap-capability "imap" (&optional identifier buffer))
1039
1040 (defun mail-source-fetch-imap (source callback)
1041   "Fetcher for imap sources."
1042   (mail-source-bind (imap source)
1043     (mail-source-run-script
1044      prescript (format-spec-make ?p password ?t mail-source-crash-box
1045                                  ?s server ?P port ?u user)
1046      prescript-delay)
1047     (let ((from (format "%s:%s:%s" server user port))
1048           (found 0)
1049           (buf (generate-new-buffer " *imap source*"))
1050           (mail-source-string (format "imap:%s:%s" server mailbox))
1051           (imap-shell-program (or (list program) imap-shell-program))
1052           remove)
1053       (if (and (imap-open server port stream authentication buf)
1054                (imap-authenticate
1055                 user (or (cdr (assoc from mail-source-password-cache))
1056                          password) buf)
1057                (imap-mailbox-select mailbox nil buf))
1058           (let ((coding-system-for-write mail-source-imap-file-coding-system)
1059                 str)
1060             (with-temp-file mail-source-crash-box
1061               ;; Avoid converting 8-bit chars from inserted strings to
1062               ;; multibyte.
1063               (mm-disable-multibyte)
1064               ;; remember password
1065               (with-current-buffer buf
1066                 (when (and imap-password
1067                            (not (assoc from mail-source-password-cache)))
1068                   (push (cons from imap-password) mail-source-password-cache)))
1069               ;; if predicate is nil, use all uids
1070               (dolist (uid (imap-search (or predicate "1:*") buf))
1071                 (when (setq str
1072                             (if (imap-capability 'IMAP4rev1 buf)
1073                                 (caddar (imap-fetch uid "BODY.PEEK[]"
1074                                                     'BODYDETAIL nil buf))
1075                               (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf)))
1076                   (push uid remove)
1077                   (insert "From imap " (current-time-string) "\n")
1078                   (save-excursion
1079                     (insert str "\n\n"))
1080                   (while (let ((case-fold-search nil))
1081                            (re-search-forward "^From " nil t))
1082                     (replace-match ">From "))
1083                   (goto-char (point-max))))
1084               (nnheader-ms-strip-cr))
1085             (incf found (mail-source-callback callback server))
1086             (mail-source-delete-crash-box)
1087             (when (and remove fetchflag)
1088               (setq remove (nreverse remove))
1089               (imap-message-flags-add
1090                (imap-range-to-message-set (gnus-compress-sequence remove))
1091                fetchflag nil buf))
1092             (if dontexpunge
1093                 (imap-mailbox-unselect buf)
1094               (imap-mailbox-close nil buf))
1095             (imap-close buf))
1096         (imap-close buf)
1097         ;; We nix out the password in case the error
1098         ;; was because of a wrong password being given.
1099         (setq mail-source-password-cache
1100               (delq (assoc from mail-source-password-cache)
1101                     mail-source-password-cache))
1102         (error "IMAP error: %s" (imap-error-text buf)))
1103       (kill-buffer buf)
1104       (mail-source-run-script
1105        postscript
1106        (format-spec-make ?p password ?t mail-source-crash-box
1107                          ?s server ?P port ?u user))
1108       found)))
1109
1110 (provide 'mail-source)
1111
1112 ;;; mail-source.el ends here