cgit.sxemacs.org Git - gnus/blob - lisp/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  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.
  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 (defun mail-source-fetch (source callback &optional method)
 505   "Fetch mail from SOURCE and call CALLBACK zero or more times.
 506 CALLBACK will be called with the name of the file where (some of)
 507 the mail from SOURCE is put.
 508 Return the number of files that were found."
 509   (mail-source-bind-common source
 510     (if (or mail-source-plugged plugged)
 511         (save-excursion
 512           ;; Special-case the `file' handler since it's so common and
 513           ;; just adds noise.
 514           (when (or (not (eq (car source) 'file))
 515                     (mail-source-bind (file source)
 516                       (file-exists-p path)))
 517             (nnheader-message 4 "%sReading incoming mail from %s..."
 518                               (if method
 519                                   (format "%s: " method)
 520                                 "")
 521                               (car source)))
 522           (let ((function (cadr (assq (car source) mail-source-fetcher-alist)))
 523                 (found 0))
 524             (unless function
 525               (error "%S is an invalid mail source specification" source))
 526             ;; If there's anything in the crash box, we do it first.
 527             (when (file-exists-p mail-source-crash-box)
 528               (message "Processing mail from %s..." mail-source-crash-box)
 529               (setq found (mail-source-callback
 530                            callback mail-source-crash-box))
 531               (mail-source-delete-crash-box))
 532             (+ found
 533                (if (or debug-on-quit debug-on-error)
 534                    (funcall function source callback)
 535                  (condition-case err
 536                      (funcall function source callback)
 537                    (error
 538                     (if (and (not mail-source-ignore-errors)
 539                              (not
 540                               (yes-or-no-p
 541                                (format "Mail source %s error (%s).  Continue? "
 542                                        (if (memq ':password source)
 543                                            (let ((s (copy-sequence source)))
 544                                              (setcar (cdr (memq ':password s))
 545                                                      "********")
 546                                              s)
 547                                          source)
 548                                        (cadr err)))))
 549                       (error "Cannot get new mail"))
 550                     0)))))))))
 551
 552 (declare-function gnus-message "gnus-util" (level &rest args))
 553
 554 (defun mail-source-delete-old-incoming (&optional age confirm)
 555   "Remove incoming files older than AGE days.
 556 If CONFIRM is non-nil, ask for confirmation before removing a file."
 557   (interactive "P")
 558   (require 'gnus-util)
 559   (let* ((high2days (/ 65536.0 60 60 24));; convert high bits to days
 560          (low2days  (/ 1.0 65536.0))     ;; convert low bits to days
 561          (diff (if (natnump age) age 30));; fallback, if no valid AGE given
 562          currday files)
 563     (setq files (directory-files
 564                  mail-source-directory t
 565                  (concat "\\`"
 566                          (regexp-quote mail-source-incoming-file-prefix)))
 567           currday (* (car (current-time)) high2days)
 568           currday (+ currday (* low2days (nth 1 (current-time)))))
 569     (while files
 570       (let* ((ffile (car files))
 571              (bfile (gnus-replace-in-string
 572                      ffile "\\`.*/\\([^/]+\\)\\'" "\\1"))
 573              (filetime (nth 5 (file-attributes ffile)))
 574              (fileday (* (car filetime) high2days))
 575              (fileday (+ fileday (* low2days (nth 1 filetime)))))
 576         (setq files (cdr files))
 577         (when (and (> (- currday fileday) diff)
 578                    (if confirm
 579                        (y-or-n-p
 580                         (format "\
 581 Delete old (> %s day(s)) incoming mail file `%s'? " diff bfile))
 582                      (gnus-message 8 "\
 583 Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
 584                      t))
 585           (delete-file ffile))))))
 586
 587 (defun mail-source-callback (callback info)
 588   "Call CALLBACK on the mail file.  Pass INFO on to CALLBACK."
 589   (if (or (not (file-exists-p mail-source-crash-box))
 590           (zerop (nth 7 (file-attributes mail-source-crash-box))))
 591       (progn
 592         (when (file-exists-p mail-source-crash-box)
 593           (delete-file mail-source-crash-box))
 594         0)
 595     (funcall callback mail-source-crash-box info)))
 596
 597 (defvar mail-source-incoming-last-checked-time nil)
 598
 599 (defun mail-source-delete-crash-box ()
 600   (when (file-exists-p mail-source-crash-box)
 601     ;; Delete or move the incoming mail out of the way.
 602     (if (eq mail-source-delete-incoming t)
 603         (delete-file mail-source-crash-box)
 604       (let ((incoming
 605              (mm-make-temp-file
 606               (expand-file-name
 607                mail-source-incoming-file-prefix
 608                mail-source-directory))))
 609         (unless (file-exists-p (file-name-directory incoming))
 610           (make-directory (file-name-directory incoming) t))
 611         (rename-file mail-source-crash-box incoming t)
 612         ;; remove old incoming files?
 613         (when (natnump mail-source-delete-incoming)
 614           ;; Don't check for old incoming files more than once per day to
 615           ;; save a lot of file accesses.
 616           (when (or (null mail-source-incoming-last-checked-time)
 617                     (> (time-to-seconds
 618                         (time-since mail-source-incoming-last-checked-time))
 619                        (* 24 60 60)))
 620             (setq mail-source-incoming-last-checked-time (current-time))
 621             (mail-source-delete-old-incoming
 622              mail-source-delete-incoming
 623              mail-source-delete-old-incoming-confirm)))))))
 624
 625 (defun mail-source-movemail (from to)
 626   "Move FROM to TO using movemail."
 627   (if (not (file-writable-p to))
 628       (error "Can't write to crash box %s.  Not moving mail" to)
 629     (let ((to (file-truename (expand-file-name to)))
 630           errors result)
 631       (setq to (file-truename to)
 632             from (file-truename from))
 633       ;; Set TO if have not already done so, and rename or copy
 634       ;; the file FROM to TO if and as appropriate.
 635       (cond
 636        ((file-exists-p to)
 637         ;; The crash box exists already.
 638         t)
 639        ((not (file-exists-p from))
 640         ;; There is no inbox.
 641         (setq to nil))
 642        ((zerop (nth 7 (file-attributes from)))
 643         ;; Empty file.
 644         (setq to nil))
 645        (t
 646         ;; If getting from mail spool directory, use movemail to move
 647         ;; rather than just renaming, so as to interlock with the
 648         ;; mailer.
 649         (unwind-protect
 650             (save-excursion
 651               (setq errors (generate-new-buffer " *mail source loss*"))
 652               (let ((default-directory "/"))
 653                 (setq result
 654                       (apply
 655                        'call-process
 656                        (append
 657                         (list
 658                          (or mail-source-movemail-program
 659                              (expand-file-name "movemail" exec-directory))
 660                          nil errors nil from to)))))
 661               (when (file-exists-p to)
 662                 (set-file-modes to mail-source-default-file-modes))
 663               (if (and (or (not (buffer-modified-p errors))
 664                            (zerop (buffer-size errors)))
 665                        (and (numberp result)
 666                             (zerop result)))
 667                   ;; No output => movemail won.
 668                   t
 669                 (set-buffer errors)
 670                 ;; There may be a warning about older revisions.  We
 671                 ;; ignore that.
 672                 (goto-char (point-min))
 673                 (if (search-forward "older revision" nil t)
 674                     t
 675                   ;; Probably a real error.
 676                   (subst-char-in-region (point-min) (point-max) ?\n ?\  )
 677                   (goto-char (point-max))
 678                   (skip-chars-backward " \t")
 679                   (delete-region (point) (point-max))
 680                   (goto-char (point-min))
 681                   (when (looking-at "movemail: ")
 682                     (delete-region (point-min) (match-end 0)))
 683                   ;; Result may be a signal description string.
 684                   (unless (yes-or-no-p
 685                            (format "movemail: %s (%s return).  Continue? "
 686                                    (buffer-string) result))
 687                     (error "%s" (buffer-string)))
 688                   (setq to nil)))))))
 689       (when (and errors
 690                  (buffer-name errors))
 691         (kill-buffer errors))
 692       ;; Return whether we moved successfully or not.
 693       to)))
 694
 695 (defun mail-source-movemail-and-remove (from to)
 696   "Move FROM to TO using movemail, then remove FROM if empty."
 697   (or (not (mail-source-movemail from to))
 698       (not (zerop (nth 7 (file-attributes from))))
 699       (delete-file from)))
 700
 701 (defun mail-source-fetch-with-program (program)
 702   (eq 0 (call-process shell-file-name nil nil nil
 703                       shell-command-switch program)))
 704
 705 (defun mail-source-run-script (script spec &optional delay)
 706   (when script
 707     (if (functionp script)
 708         (funcall script)
 709       (mail-source-call-script
 710        (format-spec script spec))))
 711   (when delay
 712     (sleep-for delay)))
 713
 714 (defun mail-source-call-script (script)
 715   (let ((background nil)
 716         (stderr (get-buffer-create " *mail-source-stderr*"))
 717         result)
 718     (when (string-match "& *$" script)
 719       (setq script (substring script 0 (match-beginning 0))
 720             background 0))
 721     (setq result
 722           (call-process shell-file-name nil background nil
 723                         shell-command-switch script))
 724     (when (and result
 725                (not (zerop result)))
 726       (set-buffer stderr)
 727       (message "Mail source error: %s" (buffer-string)))
 728     (kill-buffer stderr)))
 729
 730 ;;;
 731 ;;; Different fetchers
 732 ;;;
 733
 734 (defun mail-source-fetch-file (source callback)
 735   "Fetcher for single-file sources."
 736   (mail-source-bind (file source)
 737     (mail-source-run-script
 738      prescript (format-spec-make ?t mail-source-crash-box)
 739      prescript-delay)
 740     (let ((mail-source-string (format "file:%s" path)))
 741       (if (mail-source-movemail path mail-source-crash-box)
 742           (prog1
 743               (mail-source-callback callback path)
 744             (mail-source-run-script
 745              postscript (format-spec-make ?t mail-source-crash-box))
 746             (mail-source-delete-crash-box))
 747         0))))
 748
 749 (defun mail-source-fetch-directory (source callback)
 750   "Fetcher for directory sources."
 751   (mail-source-bind (directory source)
 752     (mail-source-run-script
 753      prescript (format-spec-make ?t path) prescript-delay)
 754     (let ((found 0)
 755           (mail-source-string (format "directory:%s" path)))
 756       (dolist (file (directory-files
 757                      path t (concat (regexp-quote suffix) "$")))
 758         (when (and (file-regular-p file)
 759                    (funcall predicate file)
 760                    (mail-source-movemail file mail-source-crash-box))
 761           (incf found (mail-source-callback callback file))
 762           (mail-source-run-script postscript (format-spec-make ?t path))
 763           (mail-source-delete-crash-box)))
 764       found)))
 765
 766 (defun mail-source-fetch-pop (source callback)
 767   "Fetcher for single-file sources."
 768   (mail-source-bind (pop source)
 769     ;; fixme: deal with stream type in format specs
 770     (mail-source-run-script
 771      prescript
 772      (format-spec-make ?p password ?t mail-source-crash-box
 773                        ?s server ?P port ?u user)
 774      prescript-delay)
 775     (let ((from (format "%s:%s:%s" server user port))
 776           (mail-source-string (format "pop:%s@%s" user server))
 777           result)
 778       (when (eq authentication 'password)
 779         (setq password
 780               (or password
 781                   (cdr (assoc from mail-source-password-cache))
 782                   (read-passwd
 783                    (format "Password for %s at %s: " user server)))))
 784       (when server
 785         (setenv "MAILHOST" server))
 786       (setq result
 787             (cond
 788              (program
 789               (mail-source-fetch-with-program
 790                (format-spec
 791                 program
 792                 (format-spec-make ?p password ?t mail-source-crash-box
 793                                   ?s server ?P port ?u user))))
 794              (function
 795               (funcall function mail-source-crash-box))
 796              ;; The default is to use pop3.el.
 797              (t
 798               (require 'pop3)
 799               (let ((pop3-password password)
 800                     (pop3-maildrop user)
 801                     (pop3-mailhost server)
 802                     (pop3-port port)
 803                     (pop3-authentication-scheme
 804                      (if (eq authentication 'apop) 'apop 'pass))
 805                     (pop3-stream-type stream))
 806                 (if (or debug-on-quit debug-on-error)
 807                     (save-excursion (pop3-movemail mail-source-crash-box))
 808                   (condition-case err
 809                       (save-excursion (pop3-movemail mail-source-crash-box))
 810                     (error
 811                      ;; We nix out the password in case the error
 812                      ;; was because of a wrong password being given.
 813                      (setq mail-source-password-cache
 814                            (delq (assoc from mail-source-password-cache)
 815                                  mail-source-password-cache))
 816                      (signal (car err) (cdr err)))))))))
 817       (if result
 818           (progn
 819             (when (eq authentication 'password)
 820               (unless (assoc from mail-source-password-cache)
 821                 (push (cons from password) mail-source-password-cache)))
 822             (prog1
 823                 (mail-source-callback callback server)
 824               ;; Update display-time's mail flag, if relevant.
 825               (if (equal source mail-source-primary-source)
 826                   (setq mail-source-new-mail-available nil))
 827               (mail-source-run-script
 828                postscript
 829                (format-spec-make ?p password ?t mail-source-crash-box
 830                                  ?s server ?P port ?u user))
 831               (mail-source-delete-crash-box)))
 832         ;; We nix out the password in case the error
 833         ;; was because of a wrong password being given.
 834         (setq mail-source-password-cache
 835               (delq (assoc from mail-source-password-cache)
 836                     mail-source-password-cache))
 837         0))))
 838
 839 (defun mail-source-check-pop (source)
 840   "Check whether there is new mail."
 841   (mail-source-bind (pop source)
 842     (let ((from (format "%s:%s:%s" server user port))
 843           (mail-source-string (format "pop:%s@%s" user server))
 844           result)
 845       (when (eq authentication 'password)
 846         (setq password
 847               (or password
 848                   (cdr (assoc from mail-source-password-cache))
 849                   (read-passwd
 850                    (format "Password for %s at %s: " user server))))
 851         (unless (assoc from mail-source-password-cache)
 852           (push (cons from password) mail-source-password-cache)))
 853       (when server
 854         (setenv "MAILHOST" server))
 855       (setq result
 856             (cond
 857              ;; No easy way to check whether mail is waiting for these.
 858              (program)
 859              (function)
 860              ;; The default is to use pop3.el.
 861              (t
 862               (require 'pop3)
 863               (let ((pop3-password password)
 864                     (pop3-maildrop user)
 865                     (pop3-mailhost server)
 866                     (pop3-port port)
 867                     (pop3-authentication-scheme
 868                      (if (eq authentication 'apop) 'apop 'pass)))
 869                 (if (or debug-on-quit debug-on-error)
 870                     (save-excursion (pop3-get-message-count))
 871                   (condition-case err
 872                       (save-excursion (pop3-get-message-count))
 873                     (error
 874                      ;; We nix out the password in case the error
 875                      ;; was because of a wrong password being given.
 876                      (setq mail-source-password-cache
 877                            (delq (assoc from mail-source-password-cache)
 878                                  mail-source-password-cache))
 879                      (signal (car err) (cdr err)))))))))
 880       (if result
 881           ;; Inform display-time that we have new mail.
 882           (setq mail-source-new-mail-available (> result 0))
 883         ;; We nix out the password in case the error
 884         ;; was because of a wrong password being given.
 885         (setq mail-source-password-cache
 886               (delq (assoc from mail-source-password-cache)
 887                     mail-source-password-cache)))
 888       result)))
 889
 890 (defun mail-source-touch-pop ()
 891   "Open and close a POP connection shortly.
 892 POP server should be defined in `mail-source-primary-source' (which is
 893 preferred) or `mail-sources'.  You may use it for the POP-before-SMTP
 894 authentication.  To do that, you need to set the
 895 `message-send-mail-function' variable as `message-smtpmail-send-it'
 896 and put the following line in your ~/.gnus.el file:
 897
 898 \(add-hook 'message-send-mail-hook 'mail-source-touch-pop)
 899
 900 See the Gnus manual for details."
 901   (let ((sources (if mail-source-primary-source
 902                      (list mail-source-primary-source)
 903                    mail-sources)))
 904     (while sources
 905       (if (eq 'pop (car (car sources)))
 906           (mail-source-check-pop (car sources)))
 907       (setq sources (cdr sources)))))
 908
 909 (defun mail-source-new-mail-p ()
 910   "Handler for `display-time' to indicate when new mail is available."
 911   ;; Flash (ie. ring the visible bell) if mail is available.
 912   (if (and mail-source-flash mail-source-new-mail-available)
 913       (let ((visible-bell t))
 914         (ding)))
 915   ;; Only report flag setting; flag is updated on a different schedule.
 916   mail-source-new-mail-available)
 917
 918
 919 (defvar mail-source-report-new-mail nil)
 920 (defvar mail-source-report-new-mail-timer nil)
 921 (defvar mail-source-report-new-mail-idle-timer nil)
 922
 923 (defun mail-source-start-idle-timer ()
 924   ;; Start our idle timer if necessary, so we delay the check until the
 925   ;; user isn't typing.
 926   (unless mail-source-report-new-mail-idle-timer
 927     (setq mail-source-report-new-mail-idle-timer
 928           (run-with-idle-timer
 929            mail-source-idle-time-delay
 930            nil
 931            (lambda ()
 932              (unwind-protect
 933                  (mail-source-check-pop mail-source-primary-source)
 934                (setq mail-source-report-new-mail-idle-timer nil)))))
 935     ;; Since idle timers created when Emacs is already in the idle
 936     ;; state don't get activated until Emacs _next_ becomes idle, we
 937     ;; need to force our timer to be considered active now.  We do
 938     ;; this by being naughty and poking the timer internals directly
 939     ;; (element 0 of the vector is nil if the timer is active).
 940     (aset mail-source-report-new-mail-idle-timer 0 nil)))
 941
 942 (defun mail-source-report-new-mail (arg)
 943   "Toggle whether to report when new mail is available.
 944 This only works when `display-time' is enabled."
 945   (interactive "P")
 946   (if (not mail-source-primary-source)
 947       (error "Need to set `mail-source-primary-source' to check for new mail"))
 948   (let ((on (if (null arg)
 949                 (not mail-source-report-new-mail)
 950               (> (prefix-numeric-value arg) 0))))
 951     (setq mail-source-report-new-mail on)
 952     (and mail-source-report-new-mail-timer
 953          (nnheader-cancel-timer mail-source-report-new-mail-timer))
 954     (and mail-source-report-new-mail-idle-timer
 955          (nnheader-cancel-timer mail-source-report-new-mail-idle-timer))
 956     (setq mail-source-report-new-mail-timer nil)
 957     (setq mail-source-report-new-mail-idle-timer nil)
 958     (if on
 959         (progn
 960           (require 'time)
 961           ;; display-time-mail-function is an Emacs feature.
 962           (setq display-time-mail-function #'mail-source-new-mail-p)
 963           ;; Set up the main timer.
 964           (setq mail-source-report-new-mail-timer
 965                 (run-at-time
 966                  (* 60 mail-source-report-new-mail-interval)
 967                  (* 60 mail-source-report-new-mail-interval)
 968                  #'mail-source-start-idle-timer))
 969           ;; When you get new mail, clear "Mail" from the mode line.
 970           (add-hook 'nnmail-post-get-new-mail-hook
 971                     'display-time-event-handler)
 972           (message "Mail check enabled"))
 973       (setq display-time-mail-function nil)
 974       (remove-hook 'nnmail-post-get-new-mail-hook
 975                    'display-time-event-handler)
 976       (message "Mail check disabled"))))
 977
 978 (defun mail-source-fetch-maildir (source callback)
 979   "Fetcher for maildir sources."
 980   (mail-source-bind (maildir source)
 981     (let ((found 0)
 982           mail-source-string)
 983       (unless (string-match "/$" path)
 984         (setq path (concat path "/")))
 985       (dolist (subdir subdirs)
 986         (when (file-directory-p (concat path subdir))
 987           (setq mail-source-string (format "maildir:%s%s" path subdir))
 988           (dolist (file (directory-files (concat path subdir) t))
 989             (when (and (not (file-directory-p file))
 990                        (not (if function
 991                                 (funcall function file mail-source-crash-box)
 992                               (let ((coding-system-for-write
 993                                      mm-text-coding-system)
 994                                     (coding-system-for-read
 995                                      mm-text-coding-system))
 996                                 (with-temp-file mail-source-crash-box
 997                                   (insert-file-contents file)
 998                                   (goto-char (point-min))
 999 ;;;                               ;; Unix mail format
1000 ;;;                               (unless (looking-at "\n*From ")
1001 ;;;                                 (insert "From maildir "
1002 ;;;                                         (current-time-string) "\n"))
1003 ;;;                               (while (re-search-forward "^From " nil t)
1004 ;;;                                 (replace-match ">From "))
1005 ;;;                               (goto-char (point-max))
1006 ;;;                               (insert "\n\n")
1007                                   ;; MMDF mail format
1008                                   (insert "\001\001\001\001\n"))
1009                                 (delete-file file)))))
1010               (incf found (mail-source-callback callback file))
1011               (mail-source-delete-crash-box)))))
1012       found)))
1013
1014 (autoload 'imap-open "imap")
1015 (autoload 'imap-authenticate "imap")
1016 (autoload 'imap-mailbox-select "imap")
1017 (autoload 'imap-mailbox-unselect "imap")
1018 (autoload 'imap-mailbox-close "imap")
1019 (autoload 'imap-search "imap")
1020 (autoload 'imap-fetch "imap")
1021 (autoload 'imap-close "imap")
1022 (autoload 'imap-error-text "imap")
1023 (autoload 'imap-message-flags-add "imap")
1024 (autoload 'imap-list-to-message-set "imap")
1025 (autoload 'imap-range-to-message-set "imap")
1026 (autoload 'nnheader-ms-strip-cr "nnheader")
1027
1028 (autoload 'gnus-compress-sequence "gnus-range")
1029
1030 (defvar mail-source-imap-file-coding-system 'binary
1031   "Coding system for the crashbox made by `mail-source-fetch-imap'.")
1032
1033 ;; Autoloads will bring in imap before this is called.
1034 (declare-function imap-capability "imap" (&optional identifier buffer))
1035
1036 (defun mail-source-fetch-imap (source callback)
1037   "Fetcher for imap sources."
1038   (mail-source-bind (imap source)
1039     (mail-source-run-script
1040      prescript (format-spec-make ?p password ?t mail-source-crash-box
1041                                  ?s server ?P port ?u user)
1042      prescript-delay)
1043     (let ((from (format "%s:%s:%s" server user port))
1044           (found 0)
1045           (buf (generate-new-buffer " *imap source*"))
1046           (mail-source-string (format "imap:%s:%s" server mailbox))
1047           (imap-shell-program (or (list program) imap-shell-program))
1048           remove)
1049       (if (and (imap-open server port stream authentication buf)
1050                (imap-authenticate
1051                 user (or (cdr (assoc from mail-source-password-cache))
1052                          password) buf)
1053                (imap-mailbox-select mailbox nil buf))
1054           (let ((coding-system-for-write mail-source-imap-file-coding-system)
1055                 str)
1056             (with-temp-file mail-source-crash-box
1057               ;; Avoid converting 8-bit chars from inserted strings to
1058               ;; multibyte.
1059               (mm-disable-multibyte)
1060               ;; remember password
1061               (with-current-buffer buf
1062                 (when (and imap-password
1063                            (not (assoc from mail-source-password-cache)))
1064                   (push (cons from imap-password) mail-source-password-cache)))
1065               ;; if predicate is nil, use all uids
1066               (dolist (uid (imap-search (or predicate "1:*") buf))
1067                 (when (setq str
1068                             (if (imap-capability 'IMAP4rev1 buf)
1069                                 (caddar (imap-fetch uid "BODY.PEEK[]"
1070                                                     'BODYDETAIL nil buf))
1071                               (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf)))
1072                   (push uid remove)
1073                   (insert "From imap " (current-time-string) "\n")
1074                   (save-excursion
1075                     (insert str "\n\n"))
1076                   (while (let ((case-fold-search nil))
1077                            (re-search-forward "^From " nil t))
1078                     (replace-match ">From "))
1079                   (goto-char (point-max))))
1080               (nnheader-ms-strip-cr))
1081             (incf found (mail-source-callback callback server))
1082             (mail-source-delete-crash-box)
1083             (when (and remove fetchflag)
1084               (setq remove (nreverse remove))
1085               (imap-message-flags-add
1086                (imap-range-to-message-set (gnus-compress-sequence remove))
1087                fetchflag nil buf))
1088             (if dontexpunge
1089                 (imap-mailbox-unselect buf)
1090               (imap-mailbox-close nil buf))
1091             (imap-close buf))
1092         (imap-close buf)
1093         ;; We nix out the password in case the error
1094         ;; was because of a wrong password being given.
1095         (setq mail-source-password-cache
1096               (delq (assoc from mail-source-password-cache)
1097                     mail-source-password-cache))
1098         (error "IMAP error: %s" (imap-error-text buf)))
1099       (kill-buffer buf)
1100       (mail-source-run-script
1101        postscript
1102        (format-spec-make ?p password ?t mail-source-crash-box
1103                          ?s server ?P port ?u user))
1104       found)))
1105
1106 (provide 'mail-source)
1107
1108 ;;; mail-source.el ends here