code.delx.au - gnu-emacs/blob - lisp/gnus/mail-source.el

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