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