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