lisp/gnus/mail-source.el

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