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

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