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