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