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