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