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