git.chise.org Git - elisp/gnus.git-/blob - lisp/mail-source.el

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