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