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

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