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