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