cgit.sxemacs.org Git - gnus/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 (eval-and-compile
  30   (autoload 'pop3-movemail "pop3")
  31   (autoload 'pop3-get-message-count "pop3"))
  32 (require 'format-spec)
  33 (require 'mm-util)
  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 See Info node `(gnus)Mail Source Specifiers'."
  43   :group 'mail-source
  44   ;; This specification should be tidied up, particularly to avoid
  45   ;; constant items appearing.  (Perhaps there's scope for improvment
  46   ;; in the widget code.)
  47   :type `(repeat
  48           (choice (const :tag "Default spool file" (file))
  49                   (list :tag "Specified spool file"
  50                         (const file)
  51                         (const :value :path)
  52                         file)
  53                   (cons :tag "Several files in a directory"
  54                         (const directory)
  55                         (choice
  56                          :tag "Options"
  57                          (const :tag "None" nil)
  58                          (repeat
  59                           (choice
  60                            (list :inline t :tag "path"
  61                                  (const :value :path) directory)
  62                            (list :inline t :tag "suffix"
  63                                  (const :value :suffix) string)
  64                            (list :inline t :tag "predicate"
  65                                  (const :value :predicate) function)
  66                            (list :inline t :tag "prescript"
  67                                  (const :value :prescript) string)
  68                            (list :inline t :tag "postscript"
  69                                  (const :value :postscript) string)
  70                            (list :inline t :tag "plugged"
  71                                  (const :value :plugged) boolean)))))
  72                   (cons :tag "POP3 server"
  73                         (const pop)
  74                         (choice
  75                          :tag "Options"
  76                          (const :tag "None" nil)
  77                          (repeat
  78                           (choice
  79                            (list :inline t :tag "server"
  80                                  (const :value :server) string)
  81                            (list :inline t :tag "port"
  82                                  (const :value :port) (choice number string))
  83                            (list :inline t :tag "user"
  84                                  (const :value :user) string)
  85                            (list :inline t :tag "password"
  86                                  (const :value :password) string)
  87                            (list :inline t :tag "program"
  88                                  (const :value :program) string)
  89                            (list :inline t :tag "prescript"
  90                                  (const :value :prescript) string)
  91                            (list :inline t :tag "postscript"
  92                                  (const :value :postscript) string)
  93                            (list :inline t :tag "function"
  94                                  (const :value :function) function)
  95                            (list :inline t :tag "authentication"
  96                                  (const :value :authentication)
  97                                  (choice (const password)
  98                                          (const apop)))
  99                            (list :inline t :tag "plugged"
 100                                  (const :value :plugged) boolean)))))
 101                   (cons :tag "Maildir (qmail, postfix...)"
 102                         (const maildir)
 103                         (choice
 104                          :tag "Options"
 105                          (const :tag "None" nil)
 106                          (repeat
 107                           (choice
 108                            (list :inline t :tag "path"
 109                                  (const :value :path) directory)
 110                            (list :inline t :tag "plugged"
 111                                  (const :value :plugged) boolean)))))
 112                   (cons :tag "IMAP server"
 113                         (const imap)
 114                         (choice
 115                          :tag "Options"
 116                          (const :tag "None" nil)
 117                          (repeat
 118                           (choice
 119                            (list :inline t :tag "server"
 120                                  (const :value :server) string)
 121                            (list :inline t :tag "port"
 122                                  (const :value :port)
 123                                  (choice number string))
 124                            (list :inline t :tag "user"
 125                                  (const :value :user) string)
 126                            (list :inline t :tag "password"
 127                                  (const :value :password) string)
 128                            (list :inline t :tag "stream"
 129                                  (const :value :stream)
 130                                  (choice ,@(progn (require 'imap)
 131                                                   (mapcar
 132                                                    (lambda (a)
 133                                                      (list 'const (car a)))
 134                                                    imap-stream-alist))))
 135                            (list :inline t :tag "authenticator"
 136                                  (const :value :authenticator)
 137                                  (choice ,@(progn (require 'imap)
 138                                                   (mapcar
 139                                                    (lambda (a)
 140                                                      (list 'const (car a)))
 141                                                    imap-authenticator-alist))))
 142                            (list :inline t :tag "mailbox"
 143                                  (const :value :mailbox) string)
 144                            (list :inline t :tag "predicate"
 145                                  (const :value :predicate) function)
 146                            (list :inline t :tag "fetchflag"
 147                                  (const :value :fetchflag) string)
 148                            (list :inline t :tag "dontexpunge"
 149                                  (const :value :dontexpunge) boolean)
 150                            (list :inline t :tag "plugged"
 151                                  (const :value :plugged) )))))
 152                   (cons :tag "Webmail server"
 153                         (const webmail)
 154                         (choice
 155                          :tag "Options"
 156                          (const :tag "None" nil)
 157                          (repeat
 158                           (choice
 159                            (list :inline t :tag "subtype"
 160                                  (const :value :subtype)
 161                                  ;; Should be generated from
 162                                  ;; `webmail-type-definition', but we
 163                                  ;; can't require webmail without W3.
 164                                  (choice (const hotmail) (const yahoo)
 165                                          (const netaddress) (const netscape)
 166                                          (const my-deja)))
 167                            (list :inline t :tag "user"
 168                                  (const :value :user) string)
 169                            (list :inline t :tag "password"
 170                                  (const :value :password) string)
 171                            (list :inline t :tag "dontexpunge"
 172                                  (const :value :dontexpunge) boolean)
 173                            (list :inline t :tag "plugged"
 174                                  (const :value :plugged) boolean))))))))
 175
 176 (defcustom mail-source-primary-source nil
 177   "*Primary source for incoming mail.
 178 If non-nil, this maildrop will be checked periodically for new mail."
 179   :group 'mail-source
 180   :type 'sexp)
 181
 182 (defcustom mail-source-crash-box "~/.emacs-mail-crash-box"
 183   "File where mail will be stored while processing it."
 184   :group 'mail-source
 185   :type 'file)
 186
 187 (defcustom mail-source-directory "~/Mail/"
 188   "Directory where files (if any) will be stored."
 189   :group 'mail-source
 190   :type 'directory)
 191
 192 (defcustom mail-source-default-file-modes 384
 193   "Set the mode bits of all new mail files to this integer."
 194   :group 'mail-source
 195   :type 'integer)
 196
 197 (defcustom mail-source-delete-incoming nil
 198   "*If non-nil, delete incoming files after handling."
 199   :group 'mail-source
 200   :type 'boolean)
 201
 202 (defcustom mail-source-incoming-file-prefix "Incoming"
 203   "Prefix for file name for storing incoming mail"
 204   :group 'mail-source
 205   :type 'string)
 206
 207 (defcustom mail-source-report-new-mail-interval 5
 208   "Interval in minutes between checks for new mail."
 209   :group 'mail-source
 210   :type 'number)
 211
 212 (defcustom mail-source-idle-time-delay 5
 213   "Number of idle seconds to wait before checking for new mail."
 214   :group 'mail-source
 215   :type 'number)
 216
 217 ;;; Internal variables.
 218
 219 (defvar mail-source-string ""
 220   "A dynamically bound string that says what the current mail source is.")
 221
 222 (defvar mail-source-new-mail-available nil
 223   "Flag indicating when new mail is available.")
 224
 225 (eval-and-compile
 226   (defvar mail-source-common-keyword-map
 227     '((:plugged))
 228     "Mapping from keywords to default values.
 229 Common keywords should be listed here.")
 230
 231   (defvar mail-source-keyword-map
 232     '((file
 233        (:prescript)
 234        (:prescript-delay)
 235        (:postscript)
 236        (:path (or (getenv "MAIL")
 237                   (expand-file-name (user-login-name) rmail-spool-directory))))
 238       (directory
 239        (:path)
 240        (:suffix ".spool")
 241        (:predicate identity))
 242       (pop
 243        (:prescript)
 244        (:prescript-delay)
 245        (:postscript)
 246        (:server (getenv "MAILHOST"))
 247        (:port 110)
 248        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
 249        (:program)
 250        (:function)
 251        (:password)
 252        (:authentication password))
 253       (maildir
 254        (:path (or (getenv "MAILDIR") "~/Maildir/"))
 255        (:subdirs ("new" "cur"))
 256        (:function))
 257       (imap
 258        (:server (getenv "MAILHOST"))
 259        (:port)
 260        (:stream)
 261        (:authentication)
 262        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
 263        (:password)
 264        (:mailbox "INBOX")
 265        (:predicate "UNSEEN UNDELETED")
 266        (:fetchflag "\\Deleted")
 267        (:dontexpunge))
 268       (webmail
 269        (:subtype hotmail)
 270        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
 271        (:password)
 272        (:dontexpunge)
 273        (:authentication password)))
 274     "Mapping from keywords to default values.
 275 All keywords that can be used must be listed here."))
 276
 277 (defvar mail-source-fetcher-alist
 278   '((file mail-source-fetch-file)
 279     (directory mail-source-fetch-directory)
 280     (pop mail-source-fetch-pop)
 281     (maildir mail-source-fetch-maildir)
 282     (imap mail-source-fetch-imap)
 283     (webmail mail-source-fetch-webmail))
 284   "A mapping from source type to fetcher function.")
 285
 286 (defvar mail-source-password-cache nil)
 287
 288 (defvar mail-source-plugged t)
 289
 290 ;;; Functions
 291
 292 (eval-and-compile
 293   (defun mail-source-strip-keyword (keyword)
 294     "Strip the leading colon off the KEYWORD."
 295     (intern (substring (symbol-name keyword) 1))))
 296
 297 (eval-and-compile
 298   (defun mail-source-bind-1 (type)
 299     (let* ((defaults (cdr (assq type mail-source-keyword-map)))
 300            default bind)
 301       (while (setq default (pop defaults))
 302         (push (list (mail-source-strip-keyword (car default))
 303                     nil)
 304               bind))
 305       bind)))
 306
 307 (defmacro mail-source-bind (type-source &rest body)
 308   "Return a `let' form that binds all variables in source TYPE.
 309 TYPE-SOURCE is a list where the first element is the TYPE, and
 310 the second variable is the SOURCE.
 311 At run time, the mail source specifier SOURCE will be inspected,
 312 and the variables will be set according to it.  Variables not
 313 specified will be given default values.
 314
 315 After this is done, BODY will be executed in the scope
 316 of the `let' form.
 317
 318 The variables bound and their default values are described by
 319 the `mail-source-keyword-map' variable."
 320   `(let ,(mail-source-bind-1 (car type-source))
 321      (mail-source-set-1 ,(cadr type-source))
 322      ,@body))
 323
 324 (put 'mail-source-bind 'lisp-indent-function 1)
 325 (put 'mail-source-bind 'edebug-form-spec '(form body))
 326
 327 (defun mail-source-set-1 (source)
 328   (let* ((type (pop source))
 329          (defaults (cdr (assq type mail-source-keyword-map)))
 330          default value keyword)
 331     (while (setq default (pop defaults))
 332       (set (mail-source-strip-keyword (setq keyword (car default)))
 333            (if (setq value (plist-get source keyword))
 334                (mail-source-value value)
 335              (mail-source-value (cadr default)))))))
 336
 337 (eval-and-compile
 338   (defun mail-source-bind-common-1 ()
 339     (let* ((defaults mail-source-common-keyword-map)
 340            default bind)
 341       (while (setq default (pop defaults))
 342         (push (list (mail-source-strip-keyword (car default))
 343                     nil)
 344               bind))
 345       bind)))
 346
 347 (defun mail-source-set-common-1 (source)
 348   (let* ((type (pop source))
 349          (defaults mail-source-common-keyword-map)
 350          (defaults-1 (cdr (assq type mail-source-keyword-map)))
 351          default value keyword)
 352     (while (setq default (pop defaults))
 353       (set (mail-source-strip-keyword (setq keyword (car default)))
 354            (if (setq value (plist-get source keyword))
 355                (mail-source-value value)
 356              (if (setq value (assq  keyword defaults-1))
 357                  (mail-source-value (cadr value))
 358                (mail-source-value (cadr default))))))))
 359
 360 (defmacro mail-source-bind-common (source &rest body)
 361   "Return a `let' form that binds all common variables.
 362 See `mail-source-bind'."
 363   `(let ,(mail-source-bind-common-1)
 364      (mail-source-set-common-1 source)
 365      ,@body))
 366
 367 (put 'mail-source-bind-common 'lisp-indent-function 1)
 368 (put 'mail-source-bind-common 'edebug-form-spec '(form body))
 369
 370 (defun mail-source-value (value)
 371   "Return the value of VALUE."
 372   (cond
 373    ;; String
 374    ((stringp value)
 375     value)
 376    ;; Function
 377    ((and (listp value)
 378          (functionp (car value)))
 379     (eval value))
 380    ;; Just return the value.
 381    (t
 382     value)))
 383
 384 (defun mail-source-fetch (source callback)
 385   "Fetch mail from SOURCE and call CALLBACK zero or more times.
 386 CALLBACK will be called with the name of the file where (some of)
 387 the mail from SOURCE is put.
 388 Return the number of files that were found."
 389   (mail-source-bind-common source
 390     (if (or mail-source-plugged plugged)
 391         (save-excursion
 392           (let ((function (cadr (assq (car source) mail-source-fetcher-alist)))
 393                 (found 0))
 394             (unless function
 395               (error "%S is an invalid mail source specification" source))
 396             ;; If there's anything in the crash box, we do it first.
 397             (when (file-exists-p mail-source-crash-box)
 398               (message "Processing mail from %s..." mail-source-crash-box)
 399               (setq found (mail-source-callback
 400                            callback mail-source-crash-box)))
 401             (+ found
 402                (condition-case err
 403                    (funcall function source callback)
 404                  (error
 405                   (unless (yes-or-no-p
 406                            (format "Mail source error (%s).  Continue? " err))
 407                     (error "Cannot get new mail."))
 408                   0))))))))
 409
 410 (defun mail-source-make-complex-temp-name (prefix)
 411   (let ((newname (make-temp-name prefix))
 412         (newprefix prefix))
 413     (while (file-exists-p newname)
 414       (setq newprefix (concat newprefix "x"))
 415       (setq newname (make-temp-name newprefix)))
 416     newname))
 417
 418 (defun mail-source-callback (callback info)
 419   "Call CALLBACK on the mail file, and then remove the mail file.
 420 Pass INFO on to CALLBACK."
 421   (if (or (not (file-exists-p mail-source-crash-box))
 422           (zerop (nth 7 (file-attributes mail-source-crash-box))))
 423       (progn
 424         (when (file-exists-p mail-source-crash-box)
 425           (delete-file mail-source-crash-box))
 426         0)
 427     (prog1
 428         (funcall callback mail-source-crash-box info)
 429       (when (file-exists-p mail-source-crash-box)
 430         ;; Delete or move the incoming mail out of the way.
 431         (if mail-source-delete-incoming
 432             (delete-file mail-source-crash-box)
 433           (let ((incoming
 434                  (mail-source-make-complex-temp-name
 435                   (expand-file-name
 436                    mail-source-incoming-file-prefix
 437                    mail-source-directory))))
 438             (unless (file-exists-p (file-name-directory incoming))
 439               (make-directory (file-name-directory incoming) t))
 440             (rename-file mail-source-crash-box incoming t)))))))
 441
 442 (defun mail-source-movemail (from to)
 443   "Move FROM to TO using movemail."
 444   (if (not (file-writable-p to))
 445       (error "Can't write to crash box %s.  Not moving mail" to)
 446     (let ((to (file-truename (expand-file-name to)))
 447           errors result)
 448       (setq to (file-truename to)
 449             from (file-truename from))
 450       ;; Set TO if have not already done so, and rename or copy
 451       ;; the file FROM to TO if and as appropriate.
 452       (cond
 453        ((file-exists-p to)
 454         ;; The crash box exists already.
 455         t)
 456        ((not (file-exists-p from))
 457         ;; There is no inbox.
 458         (setq to nil))
 459        ((zerop (nth 7 (file-attributes from)))
 460         ;; Empty file.
 461         (setq to nil))
 462        (t
 463         ;; If getting from mail spool directory, use movemail to move
 464         ;; rather than just renaming, so as to interlock with the
 465         ;; mailer.
 466         (unwind-protect
 467             (save-excursion
 468               (setq errors (generate-new-buffer " *mail source loss*"))
 469               (let ((default-directory "/"))
 470                 (setq result
 471                       (apply
 472                        'call-process
 473                        (append
 474                         (list
 475                          (expand-file-name "movemail" exec-directory)
 476                          nil errors nil from to)))))
 477               (when (file-exists-p to)
 478                 (set-file-modes to mail-source-default-file-modes))
 479               (if (and (not (buffer-modified-p errors))
 480                        (zerop result))
 481                   ;; No output => movemail won.
 482                   t
 483                 (set-buffer errors)
 484                 ;; There may be a warning about older revisions.  We
 485                 ;; ignore that.
 486                 (goto-char (point-min))
 487                 (if (search-forward "older revision" nil t)
 488                     t
 489                   ;; Probably a real error.
 490                   (subst-char-in-region (point-min) (point-max) ?\n ?\  )
 491                   (goto-char (point-max))
 492                   (skip-chars-backward " \t")
 493                   (delete-region (point) (point-max))
 494                   (goto-char (point-min))
 495                   (when (looking-at "movemail: ")
 496                     (delete-region (point-min) (match-end 0)))
 497                   (unless (yes-or-no-p
 498                            (format "movemail: %s (%d return).  Continue? "
 499                                    (buffer-string) result))
 500                     (error "%s" (buffer-string)))
 501                   (setq to nil)))))))
 502       (when (and errors
 503                  (buffer-name errors))
 504         (kill-buffer errors))
 505       ;; Return whether we moved successfully or not.
 506       to)))
 507
 508 (defun mail-source-movemail-and-remove (from to)
 509   "Move FROM to TO using movemail, then remove FROM if empty."
 510   (or (not (mail-source-movemail from to))
 511       (not (zerop (nth 7 (file-attributes from))))
 512       (delete-file from)))
 513
 514 (defvar mail-source-read-passwd nil)
 515 (defun mail-source-read-passwd (prompt &rest args)
 516   "Read a password using PROMPT.
 517 If ARGS, PROMPT is used as an argument to `format'."
 518   (let ((prompt
 519          (if args
 520              (apply 'format prompt args)
 521            prompt)))
 522     (unless mail-source-read-passwd
 523       (if (or (fboundp 'read-passwd) (load "passwd" t))
 524           (setq mail-source-read-passwd 'read-passwd)
 525         (unless (fboundp 'ange-ftp-read-passwd)
 526           (autoload 'ange-ftp-read-passwd "ange-ftp"))
 527         (setq mail-source-read-passwd 'ange-ftp-read-passwd)))
 528     (funcall mail-source-read-passwd prompt)))
 529
 530 (defun mail-source-fetch-with-program (program)
 531   (zerop (call-process shell-file-name nil nil nil
 532                        shell-command-switch program)))
 533
 534 (defun mail-source-run-script (script spec &optional delay)
 535   (when script
 536     (if (and (symbolp script) (fboundp script))
 537         (funcall script)
 538       (mail-source-call-script
 539        (format-spec script spec))))
 540   (when delay
 541     (sleep-for delay)))
 542
 543 (defun mail-source-call-script (script)
 544   (let ((background nil))
 545     (when (string-match "& *$" script)
 546       (setq script (substring script 0 (match-beginning 0))
 547             background 0))
 548     (call-process shell-file-name nil background nil
 549                   shell-command-switch script)))
 550
 551 ;;;
 552 ;;; Different fetchers
 553 ;;;
 554
 555 (defun mail-source-fetch-file (source callback)
 556   "Fetcher for single-file sources."
 557   (mail-source-bind (file source)
 558     (mail-source-run-script
 559      prescript (format-spec-make ?t mail-source-crash-box)
 560      prescript-delay)
 561     (let ((mail-source-string (format "file:%s" path)))
 562       (if (mail-source-movemail path mail-source-crash-box)
 563           (prog1
 564               (mail-source-callback callback path)
 565             (mail-source-run-script
 566              postscript (format-spec-make ?t mail-source-crash-box)))
 567         0))))
 568
 569 (defun mail-source-fetch-directory (source callback)
 570   "Fetcher for directory sources."
 571   (mail-source-bind (directory source)
 572     (let ((found 0)
 573           (mail-source-string (format "directory:%s" path)))
 574       (dolist (file (directory-files
 575                      path t (concat (regexp-quote suffix) "$")))
 576         (when (and (file-regular-p file)
 577                    (funcall predicate file)
 578                    (mail-source-movemail file mail-source-crash-box))
 579           (incf found (mail-source-callback callback file))))
 580       found)))
 581
 582 (defun mail-source-fetch-pop (source callback)
 583   "Fetcher for single-file sources."
 584   (mail-source-bind (pop source)
 585     (mail-source-run-script
 586      prescript
 587      (format-spec-make ?p password ?t mail-source-crash-box
 588                        ?s server ?P port ?u user)
 589      prescript-delay)
 590     (let ((from (format "%s:%s:%s" server user port))
 591           (mail-source-string (format "pop:%s@%s" user server))
 592           result)
 593       (when (eq authentication 'password)
 594         (setq password
 595               (or password
 596                   (cdr (assoc from mail-source-password-cache))
 597                   (mail-source-read-passwd
 598                    (format "Password for %s at %s: " user server)))))
 599       (when server
 600         (setenv "MAILHOST" server))
 601       (setq result
 602             (cond
 603              (program
 604               (mail-source-fetch-with-program
 605                (format-spec
 606                 program
 607                 (format-spec-make ?p password ?t mail-source-crash-box
 608                                   ?s server ?P port ?u user))))
 609              (function
 610               (funcall function mail-source-crash-box))
 611              ;; The default is to use pop3.el.
 612              (t
 613               (let ((pop3-password password)
 614                     (pop3-maildrop user)
 615                     (pop3-mailhost server)
 616                     (pop3-port port)
 617                     (pop3-authentication-scheme
 618                      (if (eq authentication 'apop) 'apop 'pass)))
 619                 (save-excursion (pop3-movemail mail-source-crash-box))))))
 620       (if result
 621           (progn
 622             (when (eq authentication 'password)
 623               (unless (assoc from mail-source-password-cache)
 624                 (push (cons from password) mail-source-password-cache)))
 625             (prog1
 626                 (mail-source-callback callback server)
 627               ;; Update display-time's mail flag, if relevant.
 628               (if (equal source mail-source-primary-source)
 629                   (setq mail-source-new-mail-available nil))
 630               (mail-source-run-script
 631                postscript
 632                (format-spec-make ?p password ?t mail-source-crash-box
 633                                  ?s server ?P port ?u user))))
 634         ;; We nix out the password in case the error
 635         ;; was because of a wrong password being given.
 636         (setq mail-source-password-cache
 637               (delq (assoc from mail-source-password-cache)
 638                     mail-source-password-cache))
 639         0))))
 640
 641 (defun mail-source-check-pop (source)
 642   "Check whether there is new mail."
 643   (mail-source-bind (pop source)
 644     (let ((from (format "%s:%s:%s" server user port))
 645           (mail-source-string (format "pop:%s@%s" user server))
 646           result)
 647       (when (eq authentication 'password)
 648         (setq password
 649               (or password
 650                   (cdr (assoc from mail-source-password-cache))
 651                   (mail-source-read-passwd
 652                    (format "Password for %s at %s: " user server))))
 653         (unless (assoc from mail-source-password-cache)
 654           (push (cons from password) mail-source-password-cache)))
 655       (when server
 656         (setenv "MAILHOST" server))
 657       (setq result
 658             (cond
 659              ;; No easy way to check whether mail is waiting for these.
 660              (program)
 661              (function)
 662              ;; The default is to use pop3.el.
 663              (t
 664               (let ((pop3-password password)
 665                     (pop3-maildrop user)
 666                     (pop3-mailhost server)
 667                     (pop3-port port)
 668                     (pop3-authentication-scheme
 669                      (if (eq authentication 'apop) 'apop 'pass)))
 670                 (save-excursion (pop3-get-message-count))))))
 671       (if result
 672           ;; Inform display-time that we have new mail.
 673           (setq mail-source-new-mail-available (> result 0))
 674         ;; We nix out the password in case the error
 675         ;; was because of a wrong password being given.
 676         (setq mail-source-password-cache
 677               (delq (assoc from mail-source-password-cache)
 678                     mail-source-password-cache)))
 679       result)))
 680
 681 (defun mail-source-new-mail-p ()
 682   "Handler for `display-time' to indicate when new mail is available."
 683   ;; Only report flag setting; flag is updated on a different schedule.
 684   mail-source-new-mail-available)
 685
 686
 687 (defvar mail-source-report-new-mail nil)
 688 (defvar mail-source-report-new-mail-timer nil)
 689 (defvar mail-source-report-new-mail-idle-timer nil)
 690
 691 (eval-when-compile
 692   (if (featurep 'xemacs)
 693       (require 'itimer)
 694     (require 'timer)))
 695
 696 (defun mail-source-start-idle-timer ()
 697   ;; Start our idle timer if necessary, so we delay the check until the
 698   ;; user isn't typing.
 699   (unless mail-source-report-new-mail-idle-timer
 700     (setq mail-source-report-new-mail-idle-timer
 701           (run-with-idle-timer
 702            mail-source-idle-time-delay
 703            nil
 704            (lambda ()
 705              (setq mail-source-report-new-mail-idle-timer nil)
 706              (mail-source-check-pop mail-source-primary-source))))
 707     ;; Since idle timers created when Emacs is already in the idle
 708     ;; state don't get activated until Emacs _next_ becomes idle, we
 709     ;; need to force our timer to be considered active now.  We do
 710     ;; this by being naughty and poking the timer internals directly
 711     ;; (element 0 of the vector is nil if the timer is active).
 712     (aset mail-source-report-new-mail-idle-timer 0 nil)))
 713
 714 (defun mail-source-report-new-mail (arg)
 715   "Toggle whether to report when new mail is available.
 716 This only works when `display-time' is enabled."
 717   (interactive "P")
 718   (if (not mail-source-primary-source)
 719       (error "Need to set `mail-source-primary-source' to check for new mail."))
 720   (let ((on (if (null arg)
 721                 (not mail-source-report-new-mail)
 722               (> (prefix-numeric-value arg) 0))))
 723     (setq mail-source-report-new-mail on)
 724     (and mail-source-report-new-mail-timer
 725          (nnheader-cancel-timer mail-source-report-new-mail-timer))
 726     (and mail-source-report-new-mail-idle-timer
 727          (nnheader-cancel-timer mail-source-report-new-mail-idle-timer))
 728     (setq mail-source-report-new-mail-timer nil)
 729     (setq mail-source-report-new-mail-idle-timer nil)
 730     (if on
 731         (progn
 732           (require 'time)
 733           ;; display-time-mail-function is an Emacs 21 feature.
 734           (setq display-time-mail-function #'mail-source-new-mail-p)
 735           ;; Set up the main timer.
 736           (setq mail-source-report-new-mail-timer
 737                 (run-at-time t (* 60 mail-source-report-new-mail-interval)
 738                              #'mail-source-start-idle-timer))
 739           ;; When you get new mail, clear "Mail" from the mode line.
 740           (add-hook 'nnmail-post-get-new-mail-hook
 741                     'display-time-event-handler)
 742           (message "Mail check enabled"))
 743       (setq display-time-mail-function nil)
 744       (remove-hook 'nnmail-post-get-new-mail-hook
 745                    'display-time-event-handler)
 746       (message "Mail check disabled"))))
 747
 748 (defun mail-source-fetch-maildir (source callback)
 749   "Fetcher for maildir sources."
 750   (mail-source-bind (maildir source)
 751     (let ((found 0)
 752           mail-source-string)
 753       (unless (string-match "/$" path)
 754         (setq path (concat path "/")))
 755       (dolist (subdir subdirs)
 756         (when (file-directory-p (concat path subdir))
 757           (setq mail-source-string (format "maildir:%s%s" path subdir))
 758           (dolist (file (directory-files (concat path subdir) t))
 759             (when (and (not (file-directory-p file))
 760                        (not (if function
 761                                 (funcall function file mail-source-crash-box)
 762                               (let ((coding-system-for-write
 763                                      mm-text-coding-system)
 764                                     (coding-system-for-read
 765                                      mm-text-coding-system))
 766                                 (with-temp-file mail-source-crash-box
 767                                   (insert-file-contents file)
 768                                   (goto-char (point-min))
 769 ;;;                               ;; Unix mail format
 770 ;;;                               (unless (looking-at "\n*From ")
 771 ;;;                                 (insert "From maildir "
 772 ;;;                                         (current-time-string) "\n"))
 773 ;;;                               (while (re-search-forward "^From " nil t)
 774 ;;;                                 (replace-match ">From "))
 775 ;;;                               (goto-char (point-max))
 776 ;;;                               (insert "\n\n")
 777                                   ;; MMDF mail format
 778                                   (insert "\001\001\001\001\n"))
 779                                 (delete-file file)))))
 780               (incf found (mail-source-callback callback file))))))
 781       found)))
 782
 783 (eval-and-compile
 784   (autoload 'imap-open "imap")
 785   (autoload 'imap-authenticate "imap")
 786   (autoload 'imap-mailbox-select "imap")
 787   (autoload 'imap-mailbox-unselect "imap")
 788   (autoload 'imap-mailbox-close "imap")
 789   (autoload 'imap-search "imap")
 790   (autoload 'imap-fetch "imap")
 791   (autoload 'imap-close "imap")
 792   (autoload 'imap-error-text "imap")
 793   (autoload 'imap-message-flags-add "imap")
 794   (autoload 'imap-list-to-message-set "imap")
 795   (autoload 'imap-range-to-message-set "imap")
 796   (autoload 'nnheader-ms-strip-cr "nnheader"))
 797
 798 (defvar mail-source-imap-file-coding-system 'binary
 799   "Coding system for the crashbox made by `mail-source-fetch-imap'.")
 800
 801 (defun mail-source-fetch-imap (source callback)
 802   "Fetcher for imap sources."
 803   (mail-source-bind (imap source)
 804     (let ((from (format "%s:%s:%s" server user port))
 805           (found 0)
 806           (buf (get-buffer-create (generate-new-buffer-name " *imap source*")))
 807           (mail-source-string (format "imap:%s:%s" server mailbox))
 808           remove)
 809       (if (and (imap-open server port stream authentication buf)
 810                (imap-authenticate
 811                 user (or (cdr (assoc from mail-source-password-cache))
 812                          password) buf)
 813                (imap-mailbox-select mailbox nil buf))
 814           (let ((coding-system-for-write mail-source-imap-file-coding-system)
 815                 str)
 816             (with-temp-file mail-source-crash-box
 817               ;; Avoid converting 8-bit chars from inserted strings to
 818               ;; multibyte.
 819               (mm-disable-multibyte)
 820               ;; remember password
 821               (with-current-buffer buf
 822                 (when (or imap-password
 823                           (assoc from mail-source-password-cache))
 824                   (push (cons from imap-password) mail-source-password-cache)))
 825               ;; if predicate is nil, use all uids
 826               (dolist (uid (imap-search (or predicate "1:*") buf))
 827                 (when (setq str (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf))
 828                   (push uid remove)
 829                   (insert "From imap " (current-time-string) "\n")
 830                   (save-excursion
 831                     (insert str "\n\n"))
 832                   (while (re-search-forward "^From " nil t)
 833                     (replace-match ">From "))
 834                   (goto-char (point-max))))
 835               (nnheader-ms-strip-cr))
 836             (incf found (mail-source-callback callback server))
 837             (when (and remove fetchflag)
 838               (imap-message-flags-add
 839                (imap-range-to-message-set (gnus-compress-sequence remove))
 840                fetchflag nil buf))
 841             (if dontexpunge
 842                 (imap-mailbox-unselect buf)
 843               (imap-mailbox-close buf))
 844             (imap-close buf))
 845         (imap-close buf)
 846         ;; We nix out the password in case the error
 847         ;; was because of a wrong password being given.
 848         (setq mail-source-password-cache
 849               (delq (assoc from mail-source-password-cache)
 850                     mail-source-password-cache))
 851         (error (imap-error-text buf)))
 852       (kill-buffer buf)
 853       found)))
 854
 855 (eval-and-compile
 856   (autoload 'webmail-fetch "webmail"))
 857
 858 (defun mail-source-fetch-webmail (source callback)
 859   "Fetch for webmail source."
 860   (mail-source-bind (webmail source)
 861     (let ((mail-source-string (format "webmail:%s:%s" subtype user))
 862           (webmail-newmail-only dontexpunge)
 863           (webmail-move-to-trash-can (not dontexpunge)))
 864       (when (eq authentication 'password)
 865         (setq password
 866               (or password
 867                   (cdr (assoc (format "webmail:%s:%s" subtype user)
 868                               mail-source-password-cache))
 869                   (mail-source-read-passwd
 870                    (format "Password for %s at %s: " user subtype))))
 871         (when (and password
 872                    (not (assoc (format "webmail:%s:%s" subtype user)
 873                                mail-source-password-cache)))
 874           (push (cons (format "webmail:%s:%s" subtype user) password)
 875                 mail-source-password-cache)))
 876       (webmail-fetch mail-source-crash-box subtype user password)
 877       (mail-source-callback callback (symbol-name subtype)))))
 878
 879 (provide 'mail-source)
 880
 881 ;;; mail-source.el ends here