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         (stderr (get-buffer-create " *mail-source-stderr*"))
 683         result)
 684     (when (string-match "& *$" script)
 685       (setq script (substring script 0 (match-beginning 0))
 686             background 0))
 687     (setq result
 688           (call-process shell-file-name nil background nil
 689                         shell-command-switch script))
 690     (when (and result
 691                (not (zerop result)))
 692       (set-buffer stderr)
 693       (message "Mail source error: %s" (buffer-string)))
 694     (kill-buffer stderr)))
 695
 696 ;;;
 697 ;;; Different fetchers
 698 ;;;
 699
 700 (defun mail-source-fetch-file (source callback)
 701   "Fetcher for single-file sources."
 702   (mail-source-bind (file source)
 703     (mail-source-run-script
 704      prescript (format-spec-make ?t mail-source-crash-box)
 705      prescript-delay)
 706     (let ((mail-source-string (format "file:%s" path)))
 707       (if (mail-source-movemail path mail-source-crash-box)
 708           (prog1
 709               (mail-source-callback callback path)
 710             (mail-source-run-script
 711              postscript (format-spec-make ?t mail-source-crash-box))
 712             (mail-source-delete-crash-box))
 713         0))))
 714
 715 (defun mail-source-fetch-directory (source callback)
 716   "Fetcher for directory sources."
 717   (mail-source-bind (directory source)
 718     (mail-source-run-script
 719      prescript (format-spec-make ?t path) prescript-delay)
 720     (let ((found 0)
 721           (mail-source-string (format "directory:%s" path)))
 722       (dolist (file (directory-files
 723                      path t (concat (regexp-quote suffix) "$")))
 724         (when (and (file-regular-p file)
 725                    (funcall predicate file)
 726                    (mail-source-movemail file mail-source-crash-box))
 727           (incf found (mail-source-callback callback file))
 728           (mail-source-run-script postscript (format-spec-make ?t path))
 729           (mail-source-delete-crash-box)))
 730       found)))
 731
 732 (defun mail-source-fetch-pop (source callback)
 733   "Fetcher for single-file sources."
 734   (mail-source-bind (pop source)
 735     ;; fixme: deal with stream type in format specs
 736     (mail-source-run-script
 737      prescript
 738      (format-spec-make ?p password ?t mail-source-crash-box
 739                        ?s server ?P port ?u user)
 740      prescript-delay)
 741     (let ((from (format "%s:%s:%s" server user port))
 742           (mail-source-string (format "pop:%s@%s" user server))
 743           result)
 744       (when (eq authentication 'password)
 745         (setq password
 746               (or password
 747                   (cdr (assoc from mail-source-password-cache))
 748                   (read-passwd
 749                    (format "Password for %s at %s: " user server)))))
 750       (when server
 751         (setenv "MAILHOST" server))
 752       (setq result
 753             (cond
 754              (program
 755               (mail-source-fetch-with-program
 756                (format-spec
 757                 program
 758                 (format-spec-make ?p password ?t mail-source-crash-box
 759                                   ?s server ?P port ?u user))))
 760              (function
 761               (funcall function mail-source-crash-box))
 762              ;; The default is to use pop3.el.
 763              (t
 764               (require 'pop3)
 765               (let ((pop3-password password)
 766                     (pop3-maildrop user)
 767                     (pop3-mailhost server)
 768                     (pop3-port port)
 769                     (pop3-authentication-scheme
 770                      (if (eq authentication 'apop) 'apop 'pass))
 771                     (pop3-stream-type stream))
 772                 (if (or debug-on-quit debug-on-error)
 773                     (save-excursion (pop3-movemail mail-source-crash-box))
 774                   (condition-case err
 775                       (save-excursion (pop3-movemail mail-source-crash-box))
 776                     (error
 777                      ;; We nix out the password in case the error
 778                      ;; was because of a wrong password being given.
 779                      (setq mail-source-password-cache
 780                            (delq (assoc from mail-source-password-cache)
 781                                  mail-source-password-cache))
 782                      (signal (car err) (cdr err)))))))))
 783       (if result
 784           (progn
 785             (when (eq authentication 'password)
 786               (unless (assoc from mail-source-password-cache)
 787                 (push (cons from password) mail-source-password-cache)))
 788             (prog1
 789                 (mail-source-callback callback server)
 790               ;; Update display-time's mail flag, if relevant.
 791               (if (equal source mail-source-primary-source)
 792                   (setq mail-source-new-mail-available nil))
 793               (mail-source-run-script
 794                postscript
 795                (format-spec-make ?p password ?t mail-source-crash-box
 796                                  ?s server ?P port ?u user))
 797               (mail-source-delete-crash-box)))
 798         ;; We nix out the password in case the error
 799         ;; was because of a wrong password being given.
 800         (setq mail-source-password-cache
 801               (delq (assoc from mail-source-password-cache)
 802                     mail-source-password-cache))
 803         0))))
 804
 805 (defun mail-source-check-pop (source)
 806   "Check whether there is new mail."
 807   (mail-source-bind (pop source)
 808     (let ((from (format "%s:%s:%s" server user port))
 809           (mail-source-string (format "pop:%s@%s" user server))
 810           result)
 811       (when (eq authentication 'password)
 812         (setq password
 813               (or password
 814                   (cdr (assoc from mail-source-password-cache))
 815                   (read-passwd
 816                    (format "Password for %s at %s: " user server))))
 817         (unless (assoc from mail-source-password-cache)
 818           (push (cons from password) mail-source-password-cache)))
 819       (when server
 820         (setenv "MAILHOST" server))
 821       (setq result
 822             (cond
 823              ;; No easy way to check whether mail is waiting for these.
 824              (program)
 825              (function)
 826              ;; The default is to use pop3.el.
 827              (t
 828               (require 'pop3)
 829               (let ((pop3-password password)
 830                     (pop3-maildrop user)
 831                     (pop3-mailhost server)
 832                     (pop3-port port)
 833                     (pop3-authentication-scheme
 834                      (if (eq authentication 'apop) 'apop 'pass)))
 835                 (if (or debug-on-quit debug-on-error)
 836                     (save-excursion (pop3-get-message-count))
 837                   (condition-case err
 838                       (save-excursion (pop3-get-message-count))
 839                     (error
 840                      ;; We nix out the password in case the error
 841                      ;; was because of a wrong password being given.
 842                      (setq mail-source-password-cache
 843                            (delq (assoc from mail-source-password-cache)
 844                                  mail-source-password-cache))
 845                      (signal (car err) (cdr err)))))))))
 846       (if result
 847           ;; Inform display-time that we have new mail.
 848           (setq mail-source-new-mail-available (> result 0))
 849         ;; We nix out the password in case the error
 850         ;; was because of a wrong password being given.
 851         (setq mail-source-password-cache
 852               (delq (assoc from mail-source-password-cache)
 853                     mail-source-password-cache)))
 854       result)))
 855
 856 (defun mail-source-touch-pop ()
 857   "Open and close a POP connection shortly.
 858 POP server should be defined in `mail-source-primary-source' (which is
 859 preferred) or `mail-sources'.  You may use it for the POP-before-SMTP
 860 authentication.  To do that, you need to set the
 861 `message-send-mail-function' variable as `message-smtpmail-send-it'
 862 and put the following line in your ~/.gnus.el file:
 863
 864 \(add-hook 'message-send-mail-hook 'mail-source-touch-pop)
 865
 866 See the Gnus manual for details."
 867   (let ((sources (if mail-source-primary-source
 868                      (list mail-source-primary-source)
 869                    mail-sources)))
 870     (while sources
 871       (if (eq 'pop (car (car sources)))
 872           (mail-source-check-pop (car sources)))
 873       (setq sources (cdr sources)))))
 874
 875 (defun mail-source-new-mail-p ()
 876   "Handler for `display-time' to indicate when new mail is available."
 877   ;; Flash (ie. ring the visible bell) if mail is available.
 878   (if (and mail-source-flash mail-source-new-mail-available)
 879       (let ((visible-bell t))
 880         (ding)))
 881   ;; Only report flag setting; flag is updated on a different schedule.
 882   mail-source-new-mail-available)
 883
 884
 885 (defvar mail-source-report-new-mail nil)
 886 (defvar mail-source-report-new-mail-timer nil)
 887 (defvar mail-source-report-new-mail-idle-timer nil)
 888
 889 (defun mail-source-start-idle-timer ()
 890   ;; Start our idle timer if necessary, so we delay the check until the
 891   ;; user isn't typing.
 892   (unless mail-source-report-new-mail-idle-timer
 893     (setq mail-source-report-new-mail-idle-timer
 894           (run-with-idle-timer
 895            mail-source-idle-time-delay
 896            nil
 897            (lambda ()
 898              (unwind-protect
 899                  (mail-source-check-pop mail-source-primary-source)
 900                (setq mail-source-report-new-mail-idle-timer nil)))))
 901     ;; Since idle timers created when Emacs is already in the idle
 902     ;; state don't get activated until Emacs _next_ becomes idle, we
 903     ;; need to force our timer to be considered active now.  We do
 904     ;; this by being naughty and poking the timer internals directly
 905     ;; (element 0 of the vector is nil if the timer is active).
 906     (aset mail-source-report-new-mail-idle-timer 0 nil)))
 907
 908 (defun mail-source-report-new-mail (arg)
 909   "Toggle whether to report when new mail is available.
 910 This only works when `display-time' is enabled."
 911   (interactive "P")
 912   (if (not mail-source-primary-source)
 913       (error "Need to set `mail-source-primary-source' to check for new mail"))
 914   (let ((on (if (null arg)
 915                 (not mail-source-report-new-mail)
 916               (> (prefix-numeric-value arg) 0))))
 917     (setq mail-source-report-new-mail on)
 918     (and mail-source-report-new-mail-timer
 919          (nnheader-cancel-timer mail-source-report-new-mail-timer))
 920     (and mail-source-report-new-mail-idle-timer
 921          (nnheader-cancel-timer mail-source-report-new-mail-idle-timer))
 922     (setq mail-source-report-new-mail-timer nil)
 923     (setq mail-source-report-new-mail-idle-timer nil)
 924     (if on
 925         (progn
 926           (require 'time)
 927           ;; display-time-mail-function is an Emacs 21 feature.
 928           (setq display-time-mail-function #'mail-source-new-mail-p)
 929           ;; Set up the main timer.
 930           (setq mail-source-report-new-mail-timer
 931                 (run-at-time
 932                  (* 60 mail-source-report-new-mail-interval)
 933                  (* 60 mail-source-report-new-mail-interval)
 934                  #'mail-source-start-idle-timer))
 935           ;; When you get new mail, clear "Mail" from the mode line.
 936           (add-hook 'nnmail-post-get-new-mail-hook
 937                     'display-time-event-handler)
 938           (message "Mail check enabled"))
 939       (setq display-time-mail-function nil)
 940       (remove-hook 'nnmail-post-get-new-mail-hook
 941                    'display-time-event-handler)
 942       (message "Mail check disabled"))))
 943
 944 (defun mail-source-fetch-maildir (source callback)
 945   "Fetcher for maildir sources."
 946   (mail-source-bind (maildir source)
 947     (let ((found 0)
 948           mail-source-string)
 949       (unless (string-match "/$" path)
 950         (setq path (concat path "/")))
 951       (dolist (subdir subdirs)
 952         (when (file-directory-p (concat path subdir))
 953           (setq mail-source-string (format "maildir:%s%s" path subdir))
 954           (dolist (file (directory-files (concat path subdir) t))
 955             (when (and (not (file-directory-p file))
 956                        (not (if function
 957                                 (funcall function file mail-source-crash-box)
 958                               (let ((coding-system-for-write
 959                                      mm-text-coding-system)
 960                                     (coding-system-for-read
 961                                      mm-text-coding-system))
 962                                 (with-temp-file mail-source-crash-box
 963                                   (insert-file-contents file)
 964                                   (goto-char (point-min))
 965 ;;;                               ;; Unix mail format
 966 ;;;                               (unless (looking-at "\n*From ")
 967 ;;;                                 (insert "From maildir "
 968 ;;;                                         (current-time-string) "\n"))
 969 ;;;                               (while (re-search-forward "^From " nil t)
 970 ;;;                                 (replace-match ">From "))
 971 ;;;                               (goto-char (point-max))
 972 ;;;                               (insert "\n\n")
 973                                   ;; MMDF mail format
 974                                   (insert "\001\001\001\001\n"))
 975                                 (delete-file file)))))
 976               (incf found (mail-source-callback callback file))
 977               (mail-source-delete-crash-box)))))
 978       found)))
 979
 980 (eval-and-compile
 981   (autoload 'imap-open "imap")
 982   (autoload 'imap-authenticate "imap")
 983   (autoload 'imap-mailbox-select "imap")
 984   (autoload 'imap-mailbox-unselect "imap")
 985   (autoload 'imap-mailbox-close "imap")
 986   (autoload 'imap-search "imap")
 987   (autoload 'imap-fetch "imap")
 988   (autoload 'imap-close "imap")
 989   (autoload 'imap-error-text "imap")
 990   (autoload 'imap-message-flags-add "imap")
 991   (autoload 'imap-list-to-message-set "imap")
 992   (autoload 'imap-range-to-message-set "imap")
 993   (autoload 'nnheader-ms-strip-cr "nnheader"))
 994
 995 (defvar mail-source-imap-file-coding-system 'binary
 996   "Coding system for the crashbox made by `mail-source-fetch-imap'.")
 997
 998 (defun mail-source-fetch-imap (source callback)
 999   "Fetcher for imap sources."
1000   (mail-source-bind (imap source)
1001     (mail-source-run-script
1002      prescript (format-spec-make ?p password ?t mail-source-crash-box
1003                                  ?s server ?P port ?u user)
1004      prescript-delay)
1005     (let ((from (format "%s:%s:%s" server user port))
1006           (found 0)
1007           (buf (generate-new-buffer " *imap source*"))
1008           (mail-source-string (format "imap:%s:%s" server mailbox))
1009           (imap-shell-program (or (list program) imap-shell-program))
1010           remove)
1011       (if (and (imap-open server port stream authentication buf)
1012                (imap-authenticate
1013                 user (or (cdr (assoc from mail-source-password-cache))
1014                          password) buf)
1015                (imap-mailbox-select mailbox nil buf))
1016           (let ((coding-system-for-write mail-source-imap-file-coding-system)
1017                 str)
1018             (with-temp-file mail-source-crash-box
1019               ;; Avoid converting 8-bit chars from inserted strings to
1020               ;; multibyte.
1021               (mm-disable-multibyte)
1022               ;; remember password
1023               (with-current-buffer buf
1024                 (when (and imap-password
1025                            (not (assoc from mail-source-password-cache)))
1026                   (push (cons from imap-password) mail-source-password-cache)))
1027               ;; if predicate is nil, use all uids
1028               (dolist (uid (imap-search (or predicate "1:*") buf))
1029                 (when (setq str
1030                             (if (imap-capability 'IMAP4rev1 buf)
1031                                 (caddar (imap-fetch uid "BODY.PEEK[]"
1032                                                     'BODYDETAIL nil buf))
1033                               (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf)))
1034                   (push uid remove)
1035                   (insert "From imap " (current-time-string) "\n")
1036                   (save-excursion
1037                     (insert str "\n\n"))
1038                   (while (let ((case-fold-search nil))
1039                            (re-search-forward "^From " nil t))
1040                     (replace-match ">From "))
1041                   (goto-char (point-max))))
1042               (nnheader-ms-strip-cr))
1043             (incf found (mail-source-callback callback server))
1044             (mail-source-delete-crash-box)
1045             (when (and remove fetchflag)
1046               (setq remove (nreverse remove))
1047               (imap-message-flags-add
1048                (imap-range-to-message-set (gnus-compress-sequence remove))
1049                fetchflag nil buf))
1050             (if dontexpunge
1051                 (imap-mailbox-unselect buf)
1052               (imap-mailbox-close nil buf))
1053             (imap-close buf))
1054         (imap-close buf)
1055         ;; We nix out the password in case the error
1056         ;; was because of a wrong password being given.
1057         (setq mail-source-password-cache
1058               (delq (assoc from mail-source-password-cache)
1059                     mail-source-password-cache))
1060         (error "IMAP error: %s" (imap-error-text buf)))
1061       (kill-buffer buf)
1062       (mail-source-run-script
1063        postscript
1064        (format-spec-make ?p password ?t mail-source-crash-box
1065                          ?s server ?P port ?u user))
1066       found)))
1067
1068 (eval-and-compile
1069   (autoload 'webmail-fetch "webmail"))
1070
1071 (defun mail-source-fetch-webmail (source callback)
1072   "Fetch for webmail source."
1073   (mail-source-bind (webmail source)
1074     (let ((mail-source-string (format "webmail:%s:%s" subtype user))
1075           (webmail-newmail-only dontexpunge)
1076           (webmail-move-to-trash-can (not dontexpunge)))
1077       (when (eq authentication 'password)
1078         (setq password
1079               (or password
1080                   (cdr (assoc (format "webmail:%s:%s" subtype user)
1081                               mail-source-password-cache))
1082                   (read-passwd
1083                    (format "Password for %s at %s: " user subtype))))
1084         (when (and password
1085                    (not (assoc (format "webmail:%s:%s" subtype user)
1086                                mail-source-password-cache)))
1087           (push (cons (format "webmail:%s:%s" subtype user) password)
1088                 mail-source-password-cache)))
1089       (webmail-fetch mail-source-crash-box subtype user password)
1090       (mail-source-callback callback (symbol-name subtype))
1091       (mail-source-delete-crash-box))))
1092
1093 (provide 'mail-source)
1094
1095 ;;; arch-tag: 72948025-1d17-4d6c-bb12-ef1aa2c490fd
1096 ;;; mail-source.el ends here