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 (require 'format-spec)
  38
  39 (defgroup mail-source nil
  40   "The mail-fetching library."
  41   :group 'gnus)
  42
  43 ;; Define these at compile time to avoid dragging in imap always.
  44 (defconst mail-source-imap-authenticators
  45   (eval-when-compile
  46     (mapcar (lambda (a)
  47               (list 'const (car a)))
  48      imap-authenticator-alist)))
  49 (defconst mail-source-imap-streams
  50   (eval-when-compile
  51     (mapcar (lambda (a)
  52               (list 'const (car a)))
  53      imap-stream-alist)))
  54
  55 (defcustom mail-sources nil
  56   "*Where the mail backends will look for incoming mail.
  57 This variable is a list of mail source specifiers.
  58 See Info node `(gnus)Mail Source Specifiers'."
  59   :group 'mail-source
  60   :type `(repeat
  61           (choice :format "%[Value Menu%] %v"
  62                   :value (file)
  63                   (cons :tag "Spool file"
  64                         (const :format "" file)
  65                         (checklist :tag "Options" :greedy t
  66                                    (group :inline t
  67                                           (const :format "" :value :path)
  68                                           file)))
  69                   (cons :tag "Several files in a directory"
  70                         (const :format "" directory)
  71                         (checklist :tag "Options" :greedy t
  72                                    (group :inline t
  73                                           (const :format "" :value :path)
  74                                           (directory :tag "Path"))
  75                                    (group :inline t
  76                                           (const :format "" :value :suffix)
  77                                           (string :tag "Suffix"))
  78                                    (group :inline t
  79                                           (const :format "" :value :predicate)
  80                                           (function :tag "Predicate"))
  81                                    (group :inline t
  82                                           (const :format "" :value :prescript)
  83                                           (string :tag "Prescript"))
  84                                    (group :inline t
  85                                           (const :format "" :value :postscript)
  86                                           (string :tag "Postscript"))
  87                                    (group :inline t
  88                                           (const :format "" :value :plugged)
  89                                           (boolean :tag "Plugged"))))
  90                   (cons :tag "POP3 server"
  91                         (const :format "" pop)
  92                         (checklist :tag "Options" :greedy t
  93                                    (group :inline t
  94                                           (const :format "" :value :server)
  95                                           (string :tag "Server"))
  96                                    (group :inline t
  97                                           (const :format "" :value :port)
  98                                           (choice :tag "Port"
  99                                                   :value "pop3"
 100                                                   (number :format "%v")
 101                                                   (string :format "%v")))
 102                                    (group :inline t
 103                                           (const :format "" :value :user)
 104                                           (string :tag "User"))
 105                                    (group :inline t
 106                                           (const :format "" :value :password)
 107                                           (string :tag "Password"))
 108                                    (group :inline t
 109                                           (const :format "" :value :program)
 110                                           (string :tag "Program"))
 111                                    (group :inline t
 112                                           (const :format "" :value :prescript)
 113                                           (string :tag "Prescript"))
 114                                    (group :inline t
 115                                           (const :format "" :value :postscript)
 116                                           (string :tag "Postscript"))
 117                                    (group :inline t
 118                                           (const :format "" :value :function)
 119                                           (function :tag "Function"))
 120                                    (group :inline t
 121                                           (const :format ""
 122                                                  :value :authentication)
 123                                           (choice :tag "Authentication"
 124                                                   :value apop
 125                                                   (const password)
 126                                                   (const apop)))
 127                                    (group :inline t
 128                                           (const :format "" :value :plugged)
 129                                           (boolean :tag "Plugged"))))
 130                   (cons :tag "Maildir (qmail, postfix...)"
 131                         (const :format "" maildir)
 132                         (checklist :tag "Options" :greedy t
 133                                    (group :inline t
 134                                           (const :format "" :value :path)
 135                                           (directory :tag "Path"))
 136                                    (group :inline t
 137                                           (const :format "" :value :plugged)
 138                                           (boolean :tag "Plugged"))))
 139                   (cons :tag "IMAP server"
 140                         (const :format "" imap)
 141                         (checklist :tag "Options" :greedy t
 142                                    (group :inline t
 143                                           (const :format "" :value :server)
 144                                           (string :tag "Server"))
 145                                    (group :inline t
 146                                           (const :format "" :value :port)
 147                                           (choice :tag "Port"
 148                                                   :value 143
 149                                                   number string))
 150                                    (group :inline t
 151                                           (const :format "" :value :user)
 152                                           (string :tag "User"))
 153                                    (group :inline t
 154                                           (const :format "" :value :password)
 155                                           (string :tag "Password"))
 156                                    (group :inline t
 157                                           (const :format "" :value :stream)
 158                                           (choice :tag "Stream"
 159                                                   :value network
 160                                                   ,@mail-source-imap-streams))
 161                                    (group :inline t
 162                                           (const :format ""
 163                                                  :value :authenticator)
 164                                           (choice :tag "Authenticator"
 165                                                   :value login
 166                                                   ,@mail-source-imap-authenticators))
 167                                    (group :inline t
 168                                           (const :format "" :value :mailbox)
 169                                           (string :tag "Mailbox"
 170                                                   :value "INBOX"))
 171                                    (group :inline t
 172                                           (const :format "" :value :predicate)
 173                                           (string :tag "Predicate"
 174                                                   :value "UNSEEN UNDELETED"))
 175                                    (group :inline t
 176                                           (const :format "" :value :fetchflag)
 177                                           (string :tag "Fetchflag"
 178                                                   :value  "\\Deleted"))
 179                                    (group :inline t
 180                                           (const :format ""
 181                                                  :value :dontexpunge)
 182                                           (boolean :tag "Dontexpunge"))
 183                                    (group :inline t
 184                                           (const :format "" :value :plugged)
 185                                           (boolean :tag "Plugged"))))
 186                   (cons :tag "Webmail server"
 187                         (const :format "" webmail)
 188                         (checklist :tag "Options" :greedy t
 189                                    (group :inline t
 190                                          (const :format "" :value :subtype)
 191                                          ;; Should be generated from
 192                                          ;; `webmail-type-definition', but we
 193                                          ;; can't require webmail without W3.
 194                                          (choice :tag "Subtype"
 195                                                  :value hotmail
 196                                                  (const hotmail)
 197                                                  (const yahoo)
 198                                                  (const netaddress)
 199                                                  (const netscape)
 200                                                  (const my-deja)))
 201                                    (group :inline t
 202                                           (const :format "" :value :user)
 203                                           (string :tag "User"))
 204                                    (group :inline t
 205                                           (const :format "" :value :password)
 206                                           (string :tag "Password"))
 207                                    (group :inline t
 208                                           (const :format ""
 209                                                  :value :dontexpunge)
 210                                           (boolean :tag "Dontexpunge"))
 211                                    (group :inline t
 212                                           (const :format "" :value :plugged)
 213                                           (boolean :tag "Plugged")))))))
 214
 215 (defcustom mail-source-primary-source nil
 216   "*Primary source for incoming mail.
 217 If non-nil, this maildrop will be checked periodically for new mail."
 218   :group 'mail-source
 219   :type 'sexp)
 220
 221 (defcustom mail-source-crash-box "~/.emacs-mail-crash-box"
 222   "File where mail will be stored while processing it."
 223   :group 'mail-source
 224   :type 'file)
 225
 226 (defcustom mail-source-directory "~/Mail/"
 227   "Directory where files (if any) will be stored."
 228   :group 'mail-source
 229   :type 'directory)
 230
 231 (defcustom mail-source-default-file-modes 384
 232   "Set the mode bits of all new mail files to this integer."
 233   :group 'mail-source
 234   :type 'integer)
 235
 236 (defcustom mail-source-delete-incoming nil
 237   "*If non-nil, delete incoming files after handling."
 238   :group 'mail-source
 239   :type 'boolean)
 240
 241 (defcustom mail-source-incoming-file-prefix "Incoming"
 242   "Prefix for file name for storing incoming mail"
 243   :group 'mail-source
 244   :type 'string)
 245
 246 (defcustom mail-source-report-new-mail-interval 5
 247   "Interval in minutes between checks for new mail."
 248   :group 'mail-source
 249   :type 'number)
 250
 251 (defcustom mail-source-idle-time-delay 5
 252   "Number of idle seconds to wait before checking for new mail."
 253   :group 'mail-source
 254   :type 'number)
 255
 256 ;;; Internal variables.
 257
 258 (defvar mail-source-string ""
 259   "A dynamically bound string that says what the current mail source is.")
 260
 261 (defvar mail-source-new-mail-available nil
 262   "Flag indicating when new mail is available.")
 263
 264 (eval-and-compile
 265   (defvar mail-source-common-keyword-map
 266     '((:plugged))
 267     "Mapping from keywords to default values.
 268 Common keywords should be listed here.")
 269
 270   (defvar mail-source-keyword-map
 271     '((file
 272        (:prescript)
 273        (:prescript-delay)
 274        (:postscript)
 275        (:path (or (getenv "MAIL")
 276                   (expand-file-name (user-login-name) rmail-spool-directory))))
 277       (directory
 278        (:path)
 279        (:suffix ".spool")
 280        (:predicate identity))
 281       (pop
 282        (:prescript)
 283        (:prescript-delay)
 284        (:postscript)
 285        (:server (getenv "MAILHOST"))
 286        (:port 110)
 287        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
 288        (:program)
 289        (:function)
 290        (:password)
 291        (:connection)
 292        (:authentication password)
 293        (:leave))
 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                     (pop3-connection-type connection)
 661                     (pop3-leave-mail-on-server
 662                      (or leave
 663                          (and (boundp 'pop3-leave-mail-on-server)
 664                               pop3-leave-mail-on-server))))
 665                 (save-excursion (pop3-movemail mail-source-crash-box))))))
 666       (if result
 667           (progn
 668             (when (eq authentication 'password)
 669               (unless (assoc from mail-source-password-cache)
 670                 (push (cons from password) mail-source-password-cache)))
 671             (prog1
 672                 (mail-source-callback callback server)
 673               ;; Update display-time's mail flag, if relevant.
 674               (if (equal source mail-source-primary-source)
 675                   (setq mail-source-new-mail-available nil))
 676               (mail-source-run-script
 677                postscript
 678                (format-spec-make ?p password ?t mail-source-crash-box
 679                                  ?s server ?P port ?u user))))
 680         ;; We nix out the password in case the error
 681         ;; was because of a wrong password being given.
 682         (setq mail-source-password-cache
 683               (delq (assoc from mail-source-password-cache)
 684                     mail-source-password-cache))
 685         0))))
 686
 687 (defun mail-source-check-pop (source)
 688   "Check whether there is new mail."
 689   (mail-source-bind (pop source)
 690     (let ((from (format "%s:%s:%s" server user port))
 691           (mail-source-string (format "pop:%s@%s" user server))
 692           result)
 693       (when (eq authentication 'password)
 694         (setq password
 695               (or password
 696                   (cdr (assoc from mail-source-password-cache))
 697                   (mail-source-read-passwd
 698                    (format "Password for %s at %s: " user server))))
 699         (unless (assoc from mail-source-password-cache)
 700           (push (cons from password) mail-source-password-cache)))
 701       (when server
 702         (setenv "MAILHOST" server))
 703       (setq result
 704             (cond
 705              ;; No easy way to check whether mail is waiting for these.
 706              (program)
 707              (function)
 708              ;; The default is to use pop3.el.
 709              (t
 710               (let ((pop3-password password)
 711                     (pop3-maildrop user)
 712                     (pop3-mailhost server)
 713                     (pop3-port port)
 714                     (pop3-authentication-scheme
 715                      (if (eq authentication 'apop) 'apop 'pass)))
 716                 (save-excursion (pop3-get-message-count))))))
 717       (if result
 718           ;; Inform display-time that we have new mail.
 719           (setq mail-source-new-mail-available (> result 0))
 720         ;; We nix out the password in case the error
 721         ;; was because of a wrong password being given.
 722         (setq mail-source-password-cache
 723               (delq (assoc from mail-source-password-cache)
 724                     mail-source-password-cache)))
 725       result)))
 726
 727 (defun mail-source-new-mail-p ()
 728   "Handler for `display-time' to indicate when new mail is available."
 729   ;; Only report flag setting; flag is updated on a different schedule.
 730   mail-source-new-mail-available)
 731
 732
 733 (defvar mail-source-report-new-mail nil)
 734 (defvar mail-source-report-new-mail-timer nil)
 735 (defvar mail-source-report-new-mail-idle-timer nil)
 736
 737 (eval-when-compile
 738   (if (featurep 'xemacs)
 739       (require 'itimer)
 740     (require 'timer)))
 741
 742 (defun mail-source-start-idle-timer ()
 743   ;; Start our idle timer if necessary, so we delay the check until the
 744   ;; user isn't typing.
 745   (unless mail-source-report-new-mail-idle-timer
 746     (setq mail-source-report-new-mail-idle-timer
 747           (run-with-idle-timer
 748            mail-source-idle-time-delay
 749            nil
 750            (lambda ()
 751              (setq mail-source-report-new-mail-idle-timer nil)
 752              (mail-source-check-pop mail-source-primary-source))))
 753     ;; Since idle timers created when Emacs is already in the idle
 754     ;; state don't get activated until Emacs _next_ becomes idle, we
 755     ;; need to force our timer to be considered active now.  We do
 756     ;; this by being naughty and poking the timer internals directly
 757     ;; (element 0 of the vector is nil if the timer is active).
 758     (aset mail-source-report-new-mail-idle-timer 0 nil)))
 759
 760 (defun mail-source-report-new-mail (arg)
 761   "Toggle whether to report when new mail is available.
 762 This only works when `display-time' is enabled."
 763   (interactive "P")
 764   (if (not mail-source-primary-source)
 765       (error "Need to set `mail-source-primary-source' to check for new mail."))
 766   (let ((on (if (null arg)
 767                 (not mail-source-report-new-mail)
 768               (> (prefix-numeric-value arg) 0))))
 769     (setq mail-source-report-new-mail on)
 770     (and mail-source-report-new-mail-timer
 771          (nnheader-cancel-timer mail-source-report-new-mail-timer))
 772     (and mail-source-report-new-mail-idle-timer
 773          (nnheader-cancel-timer mail-source-report-new-mail-idle-timer))
 774     (setq mail-source-report-new-mail-timer nil)
 775     (setq mail-source-report-new-mail-idle-timer nil)
 776     (if on
 777         (progn
 778           (require 'time)
 779           ;; display-time-mail-function is an Emacs 21 feature.
 780           (setq display-time-mail-function #'mail-source-new-mail-p)
 781           ;; Set up the main timer.
 782           (setq mail-source-report-new-mail-timer
 783                 (run-at-time t (* 60 mail-source-report-new-mail-interval)
 784                              #'mail-source-start-idle-timer))
 785           ;; When you get new mail, clear "Mail" from the mode line.
 786           (add-hook 'nnmail-post-get-new-mail-hook
 787                     'display-time-event-handler)
 788           (message "Mail check enabled"))
 789       (setq display-time-mail-function nil)
 790       (remove-hook 'nnmail-post-get-new-mail-hook
 791                    'display-time-event-handler)
 792       (message "Mail check disabled"))))
 793
 794 (defun mail-source-fetch-maildir (source callback)
 795   "Fetcher for maildir sources."
 796   (mail-source-bind (maildir source)
 797     (let ((found 0)
 798           mail-source-string)
 799       (unless (string-match "/$" path)
 800         (setq path (concat path "/")))
 801       (dolist (subdir subdirs)
 802         (when (file-directory-p (concat path subdir))
 803           (setq mail-source-string (format "maildir:%s%s" path subdir))
 804           (dolist (file (directory-files (concat path subdir) t))
 805             (when (and (not (file-directory-p file))
 806                        (not (if function
 807                                 (funcall function file mail-source-crash-box)
 808                               (let ((coding-system-for-write
 809                                      nnheader-text-coding-system)
 810                                     (coding-system-for-read
 811                                      nnheader-text-coding-system)
 812                                     (output-coding-system
 813                                      nnheader-text-coding-system)
 814                                     (input-coding-system
 815                                      nnheader-text-coding-system))
 816                                 (with-temp-file mail-source-crash-box
 817                                   (insert-file-contents file)
 818                                   (goto-char (point-min))
 819 ;;;                               ;; Unix mail format
 820 ;;;                               (unless (looking-at "\n*From ")
 821 ;;;                                 (insert "From maildir "
 822 ;;;                                         (current-time-string) "\n"))
 823 ;;;                               (while (re-search-forward "^From " nil t)
 824 ;;;                                 (replace-match ">From "))
 825 ;;;                               (goto-char (point-max))
 826 ;;;                               (insert "\n\n")
 827                                   ;; MMDF mail format
 828                                   (insert "\001\001\001\001\n"))
 829                                 (delete-file file)))))
 830               (incf found (mail-source-callback callback file))))))
 831       found)))
 832
 833 (eval-and-compile
 834   (autoload 'imap-open "imap")
 835   (autoload 'imap-authenticate "imap")
 836   (autoload 'imap-mailbox-select "imap")
 837   (autoload 'imap-mailbox-unselect "imap")
 838   (autoload 'imap-mailbox-close "imap")
 839   (autoload 'imap-search "imap")
 840   (autoload 'imap-fetch "imap")
 841   (autoload 'imap-close "imap")
 842   (autoload 'imap-error-text "imap")
 843   (autoload 'imap-message-flags-add "imap")
 844   (autoload 'imap-list-to-message-set "imap")
 845   (autoload 'imap-range-to-message-set "imap"))
 846
 847 (defvar mail-source-imap-file-coding-system 'binary
 848   "Coding system for the crashbox made by `mail-source-fetch-imap'.")
 849
 850 (defun mail-source-fetch-imap (source callback)
 851   "Fetcher for imap sources."
 852   (mail-source-bind (imap source)
 853     (let ((from (format "%s:%s:%s" server user port))
 854           (found 0)
 855           (buf (get-buffer-create
 856                 (format " *imap source %s:%s:%s *" server user mailbox)))
 857           (mail-source-string (format "imap:%s:%s" server mailbox))
 858           remove)
 859       (if (and (imap-open server port stream authentication buf)
 860                (imap-authenticate
 861                 user (or (cdr (assoc from mail-source-password-cache))
 862                          password) buf)
 863                (imap-mailbox-select mailbox nil buf))
 864           (let ((coding-system-for-write mail-source-imap-file-coding-system)
 865                 (output-coding-system mail-source-imap-file-coding-system)
 866                 str)
 867             (with-temp-file mail-source-crash-box
 868               ;; Avoid converting 8-bit chars from inserted strings to
 869               ;; multibyte.
 870               (set-buffer-multibyte nil)
 871               ;; remember password
 872               (with-current-buffer buf
 873                 (when (or imap-password
 874                           (assoc from mail-source-password-cache))
 875                   (push (cons from imap-password) mail-source-password-cache)))
 876               ;; if predicate is nil, use all uids
 877               (dolist (uid (imap-search (or predicate "1:*") buf))
 878                 (when (setq str (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf))
 879                   (push uid remove)
 880                   (insert "From imap " (current-time-string) "\n")
 881                   (save-excursion
 882                     (insert str "\n\n"))
 883                   (while (re-search-forward "^From " nil t)
 884                     (replace-match ">From "))
 885                   (goto-char (point-max))))
 886               (nnheader-ms-strip-cr))
 887             (incf found (mail-source-callback callback server))
 888             (when (and remove fetchflag)
 889               (imap-message-flags-add
 890                (imap-range-to-message-set (gnus-compress-sequence remove))
 891                fetchflag nil buf))
 892             (if dontexpunge
 893                 (imap-mailbox-unselect buf)
 894               (imap-mailbox-close buf))
 895             (imap-close buf))
 896         (imap-close buf)
 897         ;; We nix out the password in case the error
 898         ;; was because of a wrong password being given.
 899         (setq mail-source-password-cache
 900               (delq (assoc from mail-source-password-cache)
 901                     mail-source-password-cache))
 902         (error (imap-error-text buf)))
 903       (kill-buffer buf)
 904       found)))
 905
 906 (eval-and-compile
 907   (autoload 'webmail-fetch "webmail"))
 908
 909 (defun mail-source-fetch-webmail (source callback)
 910   "Fetch for webmail source."
 911   (mail-source-bind (webmail source)
 912     (let ((mail-source-string (format "webmail:%s:%s" subtype user))
 913           (webmail-newmail-only dontexpunge)
 914           (webmail-move-to-trash-can (not dontexpunge)))
 915       (when (eq authentication 'password)
 916         (setq password
 917               (or password
 918                   (cdr (assoc (format "webmail:%s:%s" subtype user)
 919                               mail-source-password-cache))
 920                   (mail-source-read-passwd
 921                    (format "Password for %s at %s: " user subtype))))
 922         (when (and password
 923                    (not (assoc (format "webmail:%s:%s" subtype user)
 924                                mail-source-password-cache)))
 925           (push (cons (format "webmail:%s:%s" subtype user) password)
 926                 mail-source-password-cache)))
 927       (webmail-fetch mail-source-crash-box subtype user password)
 928       (mail-source-callback callback (symbol-name subtype)))))
 929
 930 (provide 'mail-source)
 931
 932 ;;; mail-source.el ends here