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