git.chise.org Git - elisp/gnus.git-/blob - lisp/mail-source.el

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