cgit.sxemacs.org Git - gnus/blob - lisp/mail-source.el

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