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 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;; Keywords: news, mail
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-when-compile (require 'cl))
  29 (require 'nnheader)
  30 (eval-and-compile
  31   (autoload 'pop3-movemail "pop3")
  32   (autoload 'pop3-get-message-count "pop3"))
  33 (require 'format-spec)
  34
  35 (defgroup mail-source nil
  36   "The mail-fetching library."
  37   :group 'gnus)
  38
  39 (defcustom mail-sources nil
  40   "*Where the mail backends will look for incoming mail.
  41 This variable is a list of mail source specifiers."
  42   :group 'mail-source
  43   :type 'sexp)
  44
  45 (defcustom mail-source-primary-source nil
  46   "*Primary source for incoming mail.
  47 If non-nil, this maildrop will be checked periodically for new mail."
  48   :group 'mail-source
  49   :type 'sexp)
  50
  51 (defcustom mail-source-crash-box "~/.emacs-mail-crash-box"
  52   "File where mail will be stored while processing it."
  53   :group 'mail-source
  54   :type 'file)
  55
  56 (defcustom mail-source-directory "~/Mail/"
  57   "Directory where files (if any) will be stored."
  58   :group 'mail-source
  59   :type 'directory)
  60
  61 (defcustom mail-source-default-file-modes 384
  62   "Set the mode bits of all new mail files to this integer."
  63   :group 'mail-source
  64   :type 'integer)
  65
  66 (defcustom mail-source-delete-incoming nil
  67   "*If non-nil, delete incoming files after handling."
  68   :group 'mail-source
  69   :type 'boolean)
  70
  71 (defcustom mail-source-report-new-mail-interval 5
  72   "Interval in minutes between checks for new mail."
  73   :group 'mail-source
  74   :type 'number)
  75
  76 (defcustom mail-source-idle-time-delay 5
  77   "Number of idle seconds to wait before checking for new mail."
  78   :group 'mail-source
  79   :type 'number)
  80
  81 ;;; Internal variables.
  82
  83 (defvar mail-source-string ""
  84   "A dynamically bound string that says what the current mail source is.")
  85
  86 (defvar mail-source-new-mail-available nil
  87   "Flag indicating when new mail is available.")
  88
  89 (eval-and-compile
  90   (defvar mail-source-common-keyword-map
  91     '((:plugged))
  92     "Mapping from keywords to default values.
  93 Common keywords should be listed here.")
  94
  95   (defvar mail-source-keyword-map
  96     '((file
  97        (:prescript)
  98        (:prescript-delay)
  99        (:postscript)
 100        (:path (or (getenv "MAIL")
 101                   (concat "/usr/spool/mail/" (user-login-name)))))
 102       (directory
 103        (:path)
 104        (:suffix ".spool")
 105        (:predicate identity))
 106       (pop
 107        (:prescript)
 108        (:prescript-delay)
 109        (:postscript)
 110        (:server (getenv "MAILHOST"))
 111        (:port 110)
 112        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
 113        (:program)
 114        (:function)
 115        (:password)
 116        (:connection)
 117        (:authentication password))
 118       (maildir
 119        (:path (or (getenv "MAILDIR") "~/Maildir/"))
 120        (:subdirs ("new" "cur"))
 121        (:function))
 122       (imap
 123        (:server (getenv "MAILHOST"))
 124        (:port)
 125        (:stream)
 126        (:authentication)
 127        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
 128        (:password)
 129        (:mailbox "INBOX")
 130        (:predicate "UNSEEN UNDELETED")
 131        (:fetchflag "\\Deleted")
 132        (:dontexpunge))
 133       (webmail
 134        (:subtype hotmail)
 135        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
 136        (:password)
 137        (:dontexpunge)
 138        (:authentication password)))
 139     "Mapping from keywords to default values.
 140 All keywords that can be used must be listed here."))
 141
 142 (defvar mail-source-fetcher-alist
 143   '((file mail-source-fetch-file)
 144     (directory mail-source-fetch-directory)
 145     (pop mail-source-fetch-pop)
 146     (maildir mail-source-fetch-maildir)
 147     (imap mail-source-fetch-imap)
 148     (webmail mail-source-fetch-webmail))
 149   "A mapping from source type to fetcher function.")
 150
 151 (defvar mail-source-password-cache nil)
 152
 153 (defvar mail-source-plugged t)
 154
 155 ;;; Functions
 156
 157 (eval-and-compile
 158   (defun mail-source-strip-keyword (keyword)
 159     "Strip the leading colon off the KEYWORD."
 160     (intern (substring (symbol-name keyword) 1))))
 161
 162 (eval-and-compile
 163   (defun mail-source-bind-1 (type)
 164     (let* ((defaults (cdr (assq type mail-source-keyword-map)))
 165            default bind)
 166       (while (setq default (pop defaults))
 167         (push (list (mail-source-strip-keyword (car default))
 168                     nil)
 169               bind))
 170       bind)))
 171
 172 (defmacro mail-source-bind (type-source &rest body)
 173   "Return a `let' form that binds all variables in source TYPE.
 174 TYPE-SOURCE is a list where the first element is the TYPE, and
 175 the second variable is the SOURCE.
 176 At run time, the mail source specifier SOURCE will be inspected,
 177 and the variables will be set according to it.  Variables not
 178 specified will be given default values.
 179
 180 After this is done, BODY will be executed in the scope
 181 of the `let' form.
 182
 183 The variables bound and their default values are described by
 184 the `mail-source-keyword-map' variable."
 185   `(let ,(mail-source-bind-1 (car type-source))
 186      (mail-source-set-1 ,(cadr type-source))
 187      ,@body))
 188
 189 (put 'mail-source-bind 'lisp-indent-function 1)
 190 (put 'mail-source-bind 'edebug-form-spec '(form body))
 191
 192 (defun mail-source-set-1 (source)
 193   (let* ((type (pop source))
 194          (defaults (cdr (assq type mail-source-keyword-map)))
 195          default value keyword)
 196     (while (setq default (pop defaults))
 197       (set (mail-source-strip-keyword (setq keyword (car default)))
 198            (if (setq value (plist-get source keyword))
 199                (mail-source-value value)
 200              (mail-source-value (cadr default)))))))
 201
 202 (eval-and-compile
 203   (defun mail-source-bind-common-1 ()
 204     (let* ((defaults mail-source-common-keyword-map)
 205            default bind)
 206       (while (setq default (pop defaults))
 207         (push (list (mail-source-strip-keyword (car default))
 208                     nil)
 209               bind))
 210       bind)))
 211
 212 (defun mail-source-set-common-1 (source)
 213   (let* ((type (pop source))
 214          (defaults mail-source-common-keyword-map)
 215          (defaults-1 (cdr (assq type mail-source-keyword-map)))
 216          default value keyword)
 217     (while (setq default (pop defaults))
 218       (set (mail-source-strip-keyword (setq keyword (car default)))
 219            (if (setq value (plist-get source keyword))
 220                (mail-source-value value)
 221              (if (setq value (assq  keyword defaults-1))
 222                  (mail-source-value (cadr value))
 223                (mail-source-value (cadr default))))))))
 224
 225 (defmacro mail-source-bind-common (source &rest body)
 226   "Return a `let' form that binds all common variables.
 227 See `mail-source-bind'."
 228   `(let ,(mail-source-bind-common-1)
 229      (mail-source-set-common-1 source)
 230      ,@body))
 231
 232 (put 'mail-source-bind-common 'lisp-indent-function 1)
 233 (put 'mail-source-bind-common 'edebug-form-spec '(form body))
 234
 235 (defun mail-source-value (value)
 236   "Return the value of VALUE."
 237   (cond
 238    ;; String
 239    ((stringp value)
 240     value)
 241    ;; Function
 242    ((and (listp value)
 243          (functionp (car value)))
 244     (eval value))
 245    ;; Just return the value.
 246    (t
 247     value)))
 248
 249 (defun mail-source-fetch (source callback)
 250   "Fetch mail from SOURCE and call CALLBACK zero or more times.
 251 CALLBACK will be called with the name of the file where (some of)
 252 the mail from SOURCE is put.
 253 Return the number of files that were found."
 254   (mail-source-bind-common source
 255     (if (or mail-source-plugged plugged)
 256         (save-excursion
 257           (let ((function (cadr (assq (car source) mail-source-fetcher-alist)))
 258                 (found 0))
 259             (unless function
 260               (error "%S is an invalid mail source specification" source))
 261             ;; If there's anything in the crash box, we do it first.
 262             (when (file-exists-p mail-source-crash-box)
 263               (message "Processing mail from %s..." mail-source-crash-box)
 264               (setq found (mail-source-callback
 265                            callback mail-source-crash-box)))
 266             (+ found
 267                (condition-case err
 268                    (funcall function source callback)
 269                  (error
 270                   (unless (yes-or-no-p
 271                            (format "Mail source error (%s).  Continue? " err))
 272                     (error "Cannot get new mail."))
 273                   0))))))))
 274
 275 (defun mail-source-make-complex-temp-name (prefix)
 276   (let ((newname (make-temp-name prefix))
 277         (newprefix prefix))
 278     (while (file-exists-p newname)
 279       (setq newprefix (concat newprefix "x"))
 280       (setq newname (make-temp-name newprefix)))
 281     newname))
 282
 283 (defun mail-source-callback (callback info)
 284   "Call CALLBACK on the mail file, and then remove the mail file.
 285 Pass INFO on to CALLBACK."
 286   (if (or (not (file-exists-p mail-source-crash-box))
 287           (zerop (nth 7 (file-attributes mail-source-crash-box))))
 288       (progn
 289         (when (file-exists-p mail-source-crash-box)
 290           (delete-file mail-source-crash-box))
 291         0)
 292     (prog1
 293         (funcall callback mail-source-crash-box info)
 294       (when (file-exists-p mail-source-crash-box)
 295         ;; Delete or move the incoming mail out of the way.
 296         (if mail-source-delete-incoming
 297             (delete-file mail-source-crash-box)
 298           (let ((incoming
 299                  (mail-source-make-complex-temp-name
 300                   (expand-file-name
 301                    "Incoming" mail-source-directory))))
 302             (unless (file-exists-p (file-name-directory incoming))
 303               (make-directory (file-name-directory incoming) t))
 304             (rename-file mail-source-crash-box incoming t)))))))
 305
 306 (defun mail-source-movemail (from to)
 307   "Move FROM to TO using movemail."
 308   (if (not (file-writable-p to))
 309       (error "Can't write to crash box %s.  Not moving mail" to)
 310     (let ((to (file-truename (expand-file-name to)))
 311           errors result)
 312       (setq to (file-truename to)
 313             from (file-truename from))
 314       ;; Set TO if have not already done so, and rename or copy
 315       ;; the file FROM to TO if and as appropriate.
 316       (cond
 317        ((file-exists-p to)
 318         ;; The crash box exists already.
 319         t)
 320        ((not (file-exists-p from))
 321         ;; There is no inbox.
 322         (setq to nil))
 323        ((zerop (nth 7 (file-attributes from)))
 324         ;; Empty file.
 325         (setq to nil))
 326        (t
 327         ;; If getting from mail spool directory, use movemail to move
 328         ;; rather than just renaming, so as to interlock with the
 329         ;; mailer.
 330         (unwind-protect
 331             (save-excursion
 332               (setq errors (generate-new-buffer " *mail source loss*"))
 333               (let ((default-directory "/"))
 334                 (setq result
 335                       (apply
 336                        'call-process
 337                        (append
 338                         (list
 339                          (expand-file-name "movemail" exec-directory)
 340                          nil errors nil from to)))))
 341               (when (file-exists-p to)
 342                 (set-file-modes to mail-source-default-file-modes))
 343               (if (and (not (buffer-modified-p errors))
 344                        (zerop result))
 345                   ;; No output => movemail won.
 346                   t
 347                 (set-buffer errors)
 348                 ;; There may be a warning about older revisions.  We
 349                 ;; ignore that.
 350                 (goto-char (point-min))
 351                 (if (search-forward "older revision" nil t)
 352                     t
 353                   ;; Probably a real error.
 354                   (subst-char-in-region (point-min) (point-max) ?\n ?\  )
 355                   (goto-char (point-max))
 356                   (skip-chars-backward " \t")
 357                   (delete-region (point) (point-max))
 358                   (goto-char (point-min))
 359                   (when (looking-at "movemail: ")
 360                     (delete-region (point-min) (match-end 0)))
 361                   (unless (yes-or-no-p
 362                            (format "movemail: %s (%d return).  Continue? "
 363                                    (buffer-string) result))
 364                     (error "%s" (buffer-string)))
 365                   (setq to nil)))))))
 366       (when (and errors
 367                  (buffer-name errors))
 368         (kill-buffer errors))
 369       ;; Return whether we moved successfully or not.
 370       to)))
 371
 372 (defun mail-source-movemail-and-remove (from to)
 373   "Move FROM to TO using movemail, then remove FROM if empty."
 374   (or (not (mail-source-movemail from to))
 375       (not (zerop (nth 7 (file-attributes from))))
 376       (delete-file from)))
 377
 378 (defvar mail-source-read-passwd nil)
 379 (defun mail-source-read-passwd (prompt &rest args)
 380   "Read a password using PROMPT.
 381 If ARGS, PROMPT is used as an argument to `format'."
 382   (let ((prompt
 383          (if args
 384              (apply 'format prompt args)
 385            prompt)))
 386     (unless mail-source-read-passwd
 387       (if (or (fboundp 'read-passwd) (load "passwd" t))
 388           (setq mail-source-read-passwd 'read-passwd)
 389         (unless (fboundp 'ange-ftp-read-passwd)
 390           (autoload 'ange-ftp-read-passwd "ange-ftp"))
 391         (setq mail-source-read-passwd 'ange-ftp-read-passwd)))
 392     (funcall mail-source-read-passwd prompt)))
 393
 394 (defun mail-source-fetch-with-program (program)
 395   (zerop (call-process shell-file-name nil nil nil
 396                        shell-command-switch program)))
 397
 398 (defun mail-source-run-script (script spec &optional delay)
 399   (when script
 400     (if (and (symbolp script) (fboundp script))
 401         (funcall script)
 402       (mail-source-call-script
 403        (format-spec script spec))))
 404   (when delay
 405     (sleep-for delay)))
 406
 407 (defun mail-source-call-script (script)
 408   (let ((background nil))
 409     (when (string-match "& *$" script)
 410       (setq script (substring script 0 (match-beginning 0))
 411             background 0))
 412     (call-process shell-file-name nil background nil
 413                   shell-command-switch script)))
 414
 415 ;;;
 416 ;;; Different fetchers
 417 ;;;
 418
 419 (defun mail-source-fetch-file (source callback)
 420   "Fetcher for single-file sources."
 421   (mail-source-bind (file source)
 422     (mail-source-run-script
 423      prescript (format-spec-make ?t mail-source-crash-box)
 424      prescript-delay)
 425     (let ((mail-source-string (format "file:%s" path)))
 426       (if (mail-source-movemail path mail-source-crash-box)
 427           (prog1
 428               (mail-source-callback callback path)
 429             (mail-source-run-script
 430              postscript (format-spec-make ?t mail-source-crash-box)))
 431         0))))
 432
 433 (defun mail-source-fetch-directory (source callback)
 434   "Fetcher for directory sources."
 435   (mail-source-bind (directory source)
 436     (let ((found 0)
 437           (mail-source-string (format "directory:%s" path)))
 438       (dolist (file (directory-files
 439                      path t (concat (regexp-quote suffix) "$")))
 440         (when (and (file-regular-p file)
 441                    (funcall predicate file)
 442                    (mail-source-movemail file mail-source-crash-box))
 443           (incf found (mail-source-callback callback file))))
 444       found)))
 445
 446 (defun mail-source-fetch-pop (source callback)
 447   "Fetcher for single-file sources."
 448   (mail-source-bind (pop source)
 449     (mail-source-run-script
 450      prescript
 451      (format-spec-make ?p password ?t mail-source-crash-box
 452                        ?s server ?P port ?u user)
 453      prescript-delay)
 454     (let ((from (format "%s:%s:%s" server user port))
 455           (mail-source-string (format "pop:%s@%s" user server))
 456           result)
 457       (when (eq authentication 'password)
 458         (setq password
 459               (or password
 460                   (cdr (assoc from mail-source-password-cache))
 461                   (mail-source-read-passwd
 462                    (format "Password for %s at %s: " user server)))))
 463       (when server
 464         (setenv "MAILHOST" server))
 465       (setq result
 466             (cond
 467              (program
 468               (mail-source-fetch-with-program
 469                (format-spec
 470                 program
 471                 (format-spec-make ?p password ?t mail-source-crash-box
 472                                   ?s server ?P port ?u user))))
 473              (function
 474               (funcall function mail-source-crash-box))
 475              ;; The default is to use pop3.el.
 476              (t
 477               (let ((pop3-password password)
 478                     (pop3-maildrop user)
 479                     (pop3-mailhost server)
 480                     (pop3-port port)
 481                     (pop3-authentication-scheme
 482                      (if (eq authentication 'apop) 'apop 'pass))
 483                     (pop3-connection-type connection))
 484                 (save-excursion (pop3-movemail mail-source-crash-box))))))
 485       (if result
 486           (progn
 487             (when (eq authentication 'password)
 488               (unless (assoc from mail-source-password-cache)
 489                 (push (cons from password) mail-source-password-cache)))
 490             (prog1
 491                 (mail-source-callback callback server)
 492               ;; Update display-time's mail flag, if relevant.
 493               (if (equal source mail-source-primary-source)
 494                   (setq mail-source-new-mail-available nil))
 495               (mail-source-run-script
 496                postscript
 497                (format-spec-make ?p password ?t mail-source-crash-box
 498                                  ?s server ?P port ?u user))))
 499         ;; We nix out the password in case the error
 500         ;; was because of a wrong password being given.
 501         (setq mail-source-password-cache
 502               (delq (assoc from mail-source-password-cache)
 503                     mail-source-password-cache))
 504         0))))
 505
 506 (defun mail-source-check-pop (source)
 507   "Check whether there is new mail."
 508   (mail-source-bind (pop source)
 509     (let ((from (format "%s:%s:%s" server user port))
 510           (mail-source-string (format "pop:%s@%s" user server))
 511           result)
 512       (when (eq authentication 'password)
 513         (setq password
 514               (or password
 515                   (cdr (assoc from mail-source-password-cache))
 516                   (mail-source-read-passwd
 517                    (format "Password for %s at %s: " user server))))
 518         (unless (assoc from mail-source-password-cache)
 519           (push (cons from password) mail-source-password-cache)))
 520       (when server
 521         (setenv "MAILHOST" server))
 522       (setq result
 523             (cond
 524              ;; No easy way to check whether mail is waiting for these.
 525              (program)
 526              (function)
 527              ;; The default is to use pop3.el.
 528              (t
 529               (let ((pop3-password password)
 530                     (pop3-maildrop user)
 531                     (pop3-mailhost server)
 532                     (pop3-port port)
 533                     (pop3-authentication-scheme
 534                      (if (eq authentication 'apop) 'apop 'pass)))
 535                 (save-excursion (pop3-get-message-count))))))
 536       (if result
 537           ;; Inform display-time that we have new mail.
 538           (setq mail-source-new-mail-available (> result 0))
 539         ;; We nix out the password in case the error
 540         ;; was because of a wrong password being given.
 541         (setq mail-source-password-cache
 542               (delq (assoc from mail-source-password-cache)
 543                     mail-source-password-cache)))
 544       result)))
 545
 546 (defun mail-source-new-mail-p ()
 547   "Handler for `display-time' to indicate when new mail is available."
 548   ;; Only report flag setting; flag is updated on a different schedule.
 549   mail-source-new-mail-available)
 550
 551
 552 (defvar mail-source-report-new-mail nil)
 553 (defvar mail-source-report-new-mail-timer nil)
 554 (defvar mail-source-report-new-mail-idle-timer nil)
 555
 556 (eval-when-compile (require 'timer))
 557
 558 (defun mail-source-start-idle-timer ()
 559   ;; Start our idle timer if necessary, so we delay the check until the
 560   ;; user isn't typing.
 561   (unless mail-source-report-new-mail-idle-timer
 562     (setq mail-source-report-new-mail-idle-timer
 563           (run-with-idle-timer
 564            mail-source-idle-time-delay
 565            nil
 566            (lambda ()
 567              (setq mail-source-report-new-mail-idle-timer nil)
 568              (mail-source-check-pop mail-source-primary-source))))
 569     ;; Since idle timers created when Emacs is already in the idle
 570     ;; state don't get activated until Emacs _next_ becomes idle, we
 571     ;; need to force our timer to be considered active now.  We do
 572     ;; this by being naughty and poking the timer internals directly
 573     ;; (element 0 of the vector is nil if the timer is active).
 574     (aset mail-source-report-new-mail-idle-timer 0 nil)))
 575
 576 (defun mail-source-report-new-mail (arg)
 577   "Toggle whether to report when new mail is available.
 578 This only works when `display-time' is enabled."
 579   (interactive "P")
 580   (if (not mail-source-primary-source)
 581       (error "Need to set `mail-source-primary-source' to check for new mail."))
 582   (let ((on (if (null arg)
 583                 (not mail-source-report-new-mail)
 584               (> (prefix-numeric-value arg) 0))))
 585     (setq mail-source-report-new-mail on)
 586     (and mail-source-report-new-mail-timer
 587          (cancel-timer mail-source-report-new-mail-timer))
 588     (and mail-source-report-new-mail-idle-timer
 589          (cancel-timer mail-source-report-new-mail-idle-timer))
 590     (setq mail-source-report-new-mail-timer nil)
 591     (setq mail-source-report-new-mail-idle-timer nil)
 592     (if on
 593         (progn
 594           (require 'time)
 595           (setq display-time-mail-function #'mail-source-new-mail-p)
 596           ;; Set up the main timer.
 597           (setq mail-source-report-new-mail-timer
 598                 (run-at-time t (* 60 mail-source-report-new-mail-interval)
 599                              #'mail-source-start-idle-timer))
 600           ;; When you get new mail, clear "Mail" from the mode line.
 601           (add-hook 'nnmail-post-get-new-mail-hook
 602                     'display-time-event-handler)
 603           (message "Mail check enabled"))
 604       (setq display-time-mail-function nil)
 605       (remove-hook 'nnmail-post-get-new-mail-hook
 606                    'display-time-event-handler)
 607       (message "Mail check disabled"))))
 608
 609 (defun mail-source-fetch-maildir (source callback)
 610   "Fetcher for maildir sources."
 611   (mail-source-bind (maildir source)
 612     (let ((found 0)
 613           mail-source-string)
 614       (unless (string-match "/$" path)
 615         (setq path (concat path "/")))
 616       (dolist (subdir subdirs)
 617         (when (file-directory-p (concat path subdir))
 618           (setq mail-source-string (format "maildir:%s%s" path subdir))
 619           (dolist (file (directory-files (concat path subdir) t))
 620             (when (and (not (file-directory-p file))
 621                        (not (if function
 622                                 (funcall function file mail-source-crash-box)
 623                               (let ((coding-system-for-write
 624                                      nnheader-text-coding-system)
 625                                     (coding-system-for-read
 626                                      nnheader-text-coding-system)
 627                                     (output-coding-system
 628                                      nnheader-text-coding-system)
 629                                     (input-coding-system
 630                                      nnheader-text-coding-system))
 631                                 (with-temp-file mail-source-crash-box
 632                                   (insert-file-contents file)
 633                                   (goto-char (point-min))
 634                                   (unless (looking-at "\n*From ")
 635                                     (insert "From maildir "
 636                                             (current-time-string) "\n"))
 637                                   (while (re-search-forward "^From " nil t)
 638                                     (replace-match ">From "))
 639                                   (goto-char (point-max))
 640                                   (insert "\n\n"))
 641                                 (delete-file file)))))
 642               (incf found (mail-source-callback callback file))))))
 643       found)))
 644
 645 (eval-and-compile
 646   (autoload 'imap-open "imap")
 647   (autoload 'imap-authenticate "imap")
 648   (autoload 'imap-mailbox-select "imap")
 649   (autoload 'imap-mailbox-unselect "imap")
 650   (autoload 'imap-mailbox-close "imap")
 651   (autoload 'imap-search "imap")
 652   (autoload 'imap-fetch "imap")
 653   (autoload 'imap-close "imap")
 654   (autoload 'imap-error-text "imap")
 655   (autoload 'imap-message-flags-add "imap")
 656   (autoload 'imap-list-to-message-set "imap"))
 657
 658 (defun mail-source-fetch-imap (source callback)
 659   "Fetcher for imap sources."
 660   (mail-source-bind (imap source)
 661     (let ((from (format "%s:%s:%s" server user port))
 662           (found 0)
 663           (buf (get-buffer-create
 664                 (format " *imap source %s:%s:%s *" server user mailbox)))
 665           (mail-source-string (format "imap:%s:%s" server mailbox))
 666           remove)
 667       (if (and (imap-open server port stream authentication buf)
 668                (imap-authenticate
 669                 user (or (cdr (assoc from mail-source-password-cache))
 670                          password) buf)
 671                (imap-mailbox-select mailbox nil buf))
 672           (let (str
 673                 (coding-system-for-write 'binary)
 674                 (output-coding-system 'binary))
 675             (with-temp-file mail-source-crash-box
 676               ;; remember password
 677               (with-current-buffer buf
 678                 (when (or imap-password
 679                           (assoc from mail-source-password-cache))
 680                   (push (cons from imap-password) mail-source-password-cache)))
 681               ;; if predicate is nil, use all uids
 682               (dolist (uid (imap-search (or predicate "1:*") buf))
 683                 (when (setq str (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf))
 684                   (push uid remove)
 685                   (insert "From imap " (current-time-string) "\n")
 686                   (save-excursion
 687                     (insert str "\n\n"))
 688                   (while (re-search-forward "^From " nil t)
 689                     (replace-match ">From "))
 690                   (goto-char (point-max))))
 691               (nnheader-ms-strip-cr))
 692             (incf found (mail-source-callback callback server))
 693             (when (and remove fetchflag)
 694               (imap-message-flags-add
 695                (imap-list-to-message-set remove) fetchflag nil buf))
 696             (if dontexpunge
 697                 (imap-mailbox-unselect buf)
 698               (imap-mailbox-close buf))
 699             (imap-close buf))
 700         (imap-close buf)
 701         ;; We nix out the password in case the error
 702         ;; was because of a wrong password being given.
 703         (setq mail-source-password-cache
 704               (delq (assoc from mail-source-password-cache)
 705                     mail-source-password-cache))
 706         (error (imap-error-text buf)))
 707       (kill-buffer buf)
 708       found)))
 709
 710 (eval-and-compile
 711   (autoload 'webmail-fetch "webmail"))
 712
 713 (defun mail-source-fetch-webmail (source callback)
 714   "Fetch for webmail source."
 715   (mail-source-bind (webmail source)
 716     (let ((mail-source-string (format "webmail:%s:%s" subtype user))
 717           (webmail-newmail-only dontexpunge)
 718           (webmail-move-to-trash-can (not dontexpunge)))
 719       (when (eq authentication 'password)
 720         (setq password
 721               (or password
 722                   (cdr (assoc (format "webmail:%s:%s" subtype user)
 723                               mail-source-password-cache))
 724                   (mail-source-read-passwd
 725                    (format "Password for %s at %s: " user subtype))))
 726         (when (and password
 727                    (not (assoc (format "webmail:%s:%s" subtype user)
 728                                mail-source-password-cache)))
 729           (push (cons (format "webmail:%s:%s" subtype user) password)
 730                 mail-source-password-cache)))
 731       (webmail-fetch mail-source-crash-box subtype user password)
 732       (mail-source-callback callback (symbol-name subtype)))))
 733
 734 (provide 'mail-source)
 735
 736 ;;; mail-source.el ends here