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

   1 ;;; mail-source.el --- functions for fetching mail
   2
   3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 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 of the License, or
  14 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 ;; For Emacs < 22.2.
  29 (eval-and-compile
  30   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
  31
  32 (require 'format-spec)
  33 (eval-when-compile
  34   (require 'cl)
  35   (require 'imap))
  36 (eval-and-compile
  37   (autoload 'auth-source-user-or-password "auth-source")
  38   (autoload 'pop3-movemail "pop3")
  39   (autoload 'pop3-get-message-count "pop3")
  40   (autoload 'nnheader-cancel-timer "nnheader"))
  41 (require 'mm-util)
  42 (require 'message) ;; for `message-directory'
  43
  44 (defvar display-time-mail-function)
  45
  46 (defgroup mail-source nil
  47   "The mail-fetching library."
  48   :version "21.1"
  49   :group 'gnus)
  50
  51 ;; Define these at compile time to avoid dragging in imap always.
  52 (defconst mail-source-imap-authenticators
  53   (eval-when-compile
  54     (mapcar (lambda (a)
  55               (list 'const (car a)))
  56      imap-authenticator-alist)))
  57 (defconst mail-source-imap-streams
  58   (eval-when-compile
  59     (mapcar (lambda (a)
  60               (list 'const (car a)))
  61      imap-stream-alist)))
  62
  63 (defcustom mail-sources '((file))
  64   "Where the mail backends will look for incoming mail.
  65 This variable is a list of mail source specifiers.
  66 See Info node `(gnus)Mail Source Specifiers'."
  67   :group 'mail-source
  68   :version "23.1" ;; No Gnus
  69   :link '(custom-manual "(gnus)Mail Source Specifiers")
  70   :type `(choice
  71           (const :tag "None" nil)
  72           (repeat :tag "List"
  73            (choice :format "%[Value Menu%] %v"
  74                    :value (file)
  75                    (cons :tag "Group parameter `mail-source'"
  76                          (const :format "" group))
  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
 288   10 ;; development versions
 289   ;; 2 ;; released versions
 290   "If non-nil, delete incoming files after handling.
 291 If t, delete immediately, if nil, never delete.  If a positive number, delete
 292 files older than number of days.
 293
 294 Removing of old files happens in `mail-source-callback', i.e. no
 295 old incoming files will be deleted unless you receive new mail.
 296 You may also set this variable to nil and call
 297 `mail-source-delete-old-incoming' interactively."
 298   :group 'mail-source
 299   :version "22.2" ;; No Gnus / Gnus 5.10.10 (default changed)
 300   :type '(choice (const :tag "immediately" t)
 301                  (const :tag "never" nil)
 302                  (integer :tag "days")))
 303
 304 (defcustom mail-source-delete-old-incoming-confirm nil
 305   "If non-nil, ask for confirmation before deleting old incoming files.
 306 This variable only applies when `mail-source-delete-incoming' is a positive
 307 number."
 308   :version "22.2" ;; No Gnus / Gnus 5.10.10 (default changed)
 309   :group 'mail-source
 310   :type 'boolean)
 311
 312 (defcustom mail-source-incoming-file-prefix "Incoming"
 313   "Prefix for file name for storing incoming mail"
 314   :group 'mail-source
 315   :type 'string)
 316
 317 (defcustom mail-source-report-new-mail-interval 5
 318   "Interval in minutes between checks for new mail."
 319   :group 'mail-source
 320   :type 'number)
 321
 322 (defcustom mail-source-idle-time-delay 5
 323   "Number of idle seconds to wait before checking for new mail."
 324   :group 'mail-source
 325   :type 'number)
 326
 327 (defcustom mail-source-movemail-program nil
 328   "If non-nil, name of program for fetching new mail."
 329   :version "22.1"
 330   :group 'mail-source
 331   :type '(choice (const nil) string))
 332
 333 ;;; Internal variables.
 334
 335 (defvar mail-source-string ""
 336   "A dynamically bound string that says what the current mail source is.")
 337
 338 (defvar mail-source-new-mail-available nil
 339   "Flag indicating when new mail is available.")
 340
 341 (eval-and-compile
 342   (defvar mail-source-common-keyword-map
 343     '((:plugged))
 344     "Mapping from keywords to default values.
 345 Common keywords should be listed here.")
 346
 347   (defvar mail-source-keyword-map
 348     '((file
 349        (:prescript)
 350        (:prescript-delay)
 351        (:postscript)
 352        (:path (or (getenv "MAIL")
 353                   (expand-file-name (user-login-name) rmail-spool-directory))))
 354       (directory
 355        (:prescript)
 356        (:prescript-delay)
 357        (:postscript)
 358        (:path)
 359        (:suffix ".spool")
 360        (:predicate identity))
 361       (pop
 362        (:prescript)
 363        (:prescript-delay)
 364        (:postscript)
 365        (:server (getenv "MAILHOST"))
 366        (:port 110)
 367        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
 368        (:program)
 369        (:function)
 370        (:password)
 371        (:authentication password)
 372        (:stream nil))
 373       (maildir
 374        (:path (or (getenv "MAILDIR") "~/Maildir/"))
 375        (:subdirs ("cur" "new"))
 376        (:function))
 377       (imap
 378        (:server (getenv "MAILHOST"))
 379        (:port)
 380        (:stream)
 381        (:program)
 382        (:authentication)
 383        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
 384        (:password)
 385        (:mailbox "INBOX")
 386        (:predicate "UNSEEN UNDELETED")
 387        (:fetchflag "\\Deleted")
 388        (:prescript)
 389        (:prescript-delay)
 390        (:postscript)
 391        (:dontexpunge))
 392       (webmail
 393        (:subtype hotmail)
 394        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
 395        (:password)
 396        (:dontexpunge)
 397        (:authentication password)))
 398     "Mapping from keywords to default values.
 399 All keywords that can be used must be listed here."))
 400
 401 (defvar mail-source-fetcher-alist
 402   '((file mail-source-fetch-file)
 403     (directory mail-source-fetch-directory)
 404     (pop mail-source-fetch-pop)
 405     (maildir mail-source-fetch-maildir)
 406     (imap mail-source-fetch-imap)
 407     (webmail mail-source-fetch-webmail))
 408   "A mapping from source type to fetcher function.")
 409
 410 (defvar mail-source-password-cache nil)
 411
 412 (defvar mail-source-plugged t)
 413
 414 ;;; Functions
 415
 416 (eval-and-compile
 417   (defun mail-source-strip-keyword (keyword)
 418     "Strip the leading colon off the KEYWORD."
 419     (intern (substring (symbol-name keyword) 1))))
 420
 421 ;; generate a list of variable names paired with nil values
 422 ;; suitable for usage in a `let' form
 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 The user and password will be loaded from the auth-source values
 442 if those are available.  They override the original user and
 443 password in a second `let' form.
 444
 445 After this is done, BODY will be executed in the scope
 446 of the second `let' form.
 447
 448 The variables bound and their default values are described by
 449 the `mail-source-keyword-map' variable."
 450   `(let* ,(mail-source-bind-1 (car type-source))
 451      (mail-source-set-1 ,(cadr type-source))
 452      ,@body))
 453
 454 (put 'mail-source-bind 'lisp-indent-function 1)
 455 (put 'mail-source-bind 'edebug-form-spec '(sexp body))
 456
 457 (defun mail-source-set-1 (source)
 458   (let* ((type (pop source))
 459          (defaults (cdr (assq type mail-source-keyword-map)))
 460          default value keyword user-auth pass-auth)
 461     (while (setq default (pop defaults))
 462       ;; for each default :SYMBOL, set SYMBOL to the plist value for :SYMBOL
 463       ;; using `mail-source-value' to evaluate the plist value
 464       (set (mail-source-strip-keyword (setq keyword (car default)))
 465            ;; note the following reasons for this structure:
 466            ;; 1) the auth-sources user and password override everything
 467            ;; 2) it avoids macros, so it's cleaner
 468            ;; 3) it falls through to the mail-sources and then default values
 469            (cond
 470             ((and
 471              (eq keyword :user)
 472              (setq user-auth
 473                    (auth-source-user-or-password
 474                     "login"
 475                     ;; this is "host" in auth-sources
 476                     (if (boundp 'server) (symbol-value 'server) "")
 477                     type)))
 478              user-auth)
 479             ((and
 480              (eq keyword :password)
 481              (setq pass-auth
 482                    (auth-source-user-or-password
 483                     "password"
 484                     ;; this is "host" in auth-sources
 485                     (if (boundp 'server) (symbol-value 'server) "")
 486                     type)))
 487              pass-auth)
 488             (t (if (setq value (plist-get source keyword))
 489                  (mail-source-value value)
 490                (mail-source-value (cadr default)))))))))
 491
 492 (eval-and-compile
 493   (defun mail-source-bind-common-1 ()
 494     (let* ((defaults mail-source-common-keyword-map)
 495            default bind)
 496       (while (setq default (pop defaults))
 497         (push (list (mail-source-strip-keyword (car default))
 498                     nil)
 499               bind))
 500       bind)))
 501
 502 (defun mail-source-set-common-1 (source)
 503   (let* ((type (pop source))
 504          (defaults mail-source-common-keyword-map)
 505          (defaults-1 (cdr (assq type mail-source-keyword-map)))
 506          default value keyword)
 507     (while (setq default (pop defaults))
 508       (set (mail-source-strip-keyword (setq keyword (car default)))
 509            (if (setq value (plist-get source keyword))
 510                (mail-source-value value)
 511              (if (setq value (assq  keyword defaults-1))
 512                  (mail-source-value (cadr value))
 513                (mail-source-value (cadr default))))))))
 514
 515 (defmacro mail-source-bind-common (source &rest body)
 516   "Return a `let' form that binds all common variables.
 517 See `mail-source-bind'."
 518   `(let ,(mail-source-bind-common-1)
 519      (mail-source-set-common-1 source)
 520      ,@body))
 521
 522 (put 'mail-source-bind-common 'lisp-indent-function 1)
 523 (put 'mail-source-bind-common 'edebug-form-spec '(sexp body))
 524
 525 (defun mail-source-value (value)
 526   "Return the value of VALUE."
 527   (cond
 528    ;; String
 529    ((stringp value)
 530     value)
 531    ;; Function
 532    ((and (listp value) (symbolp (car value)) (fboundp (car value)))
 533     (eval value))
 534    ;; Just return the value.
 535    (t
 536     value)))
 537
 538 (defun mail-source-fetch (source callback)
 539   "Fetch mail from SOURCE and call CALLBACK zero or more times.
 540 CALLBACK will be called with the name of the file where (some of)
 541 the mail from SOURCE is put.
 542 Return the number of files that were found."
 543   (mail-source-bind-common source
 544     (if (or mail-source-plugged plugged)
 545         (save-excursion
 546           (let ((function (cadr (assq (car source) mail-source-fetcher-alist)))
 547                 (found 0))
 548             (unless function
 549               (error "%S is an invalid mail source specification" source))
 550             ;; If there's anything in the crash box, we do it first.
 551             (when (file-exists-p mail-source-crash-box)
 552               (message "Processing mail from %s..." mail-source-crash-box)
 553               (setq found (mail-source-callback
 554                            callback mail-source-crash-box))
 555               (mail-source-delete-crash-box))
 556             (+ found
 557                (if (or debug-on-quit debug-on-error)
 558                    (funcall function source callback)
 559                  (condition-case err
 560                      (funcall function source callback)
 561                    (error
 562                     (if (and (not mail-source-ignore-errors)
 563                              (not
 564                               (yes-or-no-p
 565                                (format "Mail source %s error (%s).  Continue? "
 566                                        (if (memq ':password source)
 567                                            (let ((s (copy-sequence source)))
 568                                              (setcar (cdr (memq ':password s))
 569                                                      "********")
 570                                              s)
 571                                          source)
 572                                        (cadr err)))))
 573                       (error "Cannot get new mail"))
 574                     0)))))))))
 575
 576 (defun mail-source-delete-old-incoming (&optional age confirm)
 577   "Remove incoming files older than AGE days.
 578 If CONFIRM is non-nil, ask for confirmation before removing a file."
 579   (interactive "P")
 580   (let* ((high2days (/ 65536.0 60 60 24));; convert high bits to days
 581          (low2days  (/ 1.0 65536.0))     ;; convert low bits to days
 582          (diff (if (natnump age) age 30));; fallback, if no valid AGE given
 583          currday files)
 584     (setq files (directory-files
 585                  mail-source-directory t
 586                  (concat "\\`"
 587                          (regexp-quote mail-source-incoming-file-prefix)))
 588           currday (* (car (current-time)) high2days)
 589           currday (+ currday (* low2days (nth 1 (current-time)))))
 590     (while files
 591       (let* ((ffile (car files))
 592              (bfile (gnus-replace-in-string
 593                      ffile "\\`.*/\\([^/]+\\)\\'" "\\1"))
 594              (filetime (nth 5 (file-attributes ffile)))
 595              (fileday (* (car filetime) high2days))
 596              (fileday (+ fileday (* low2days (nth 1 filetime)))))
 597         (setq files (cdr files))
 598         (when (and (> (- currday fileday) diff)
 599                    (if confirm
 600                        (y-or-n-p
 601                         (format "\
 602 Delete old (> %s day(s)) incoming mail file `%s'? " diff bfile))
 603                      (gnus-message 8 "\
 604 Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
 605                      t))
 606           (delete-file ffile))))))
 607
 608 (defun mail-source-callback (callback info)
 609   "Call CALLBACK on the mail file.  Pass INFO on to CALLBACK."
 610   (if (or (not (file-exists-p mail-source-crash-box))
 611           (zerop (nth 7 (file-attributes mail-source-crash-box))))
 612       (progn
 613         (when (file-exists-p mail-source-crash-box)
 614           (delete-file mail-source-crash-box))
 615         0)
 616     (funcall callback mail-source-crash-box info)))
 617
 618 (defun mail-source-delete-crash-box ()
 619   (when (file-exists-p mail-source-crash-box)
 620     ;; Delete or move the incoming mail out of the way.
 621     (if (eq mail-source-delete-incoming t)
 622         (delete-file mail-source-crash-box)
 623       (let ((incoming
 624              (mm-make-temp-file
 625               (expand-file-name
 626                mail-source-incoming-file-prefix
 627                mail-source-directory))))
 628         (unless (file-exists-p (file-name-directory incoming))
 629           (make-directory (file-name-directory incoming) t))
 630         (rename-file mail-source-crash-box incoming t)
 631         ;; remove old incoming files?
 632         (when (natnump mail-source-delete-incoming)
 633           (mail-source-delete-old-incoming
 634            mail-source-delete-incoming
 635            mail-source-delete-old-incoming-confirm))))))
 636
 637 (defun mail-source-movemail (from to)
 638   "Move FROM to TO using movemail."
 639   (if (not (file-writable-p to))
 640       (error "Can't write to crash box %s.  Not moving mail" to)
 641     (let ((to (file-truename (expand-file-name to)))
 642           errors result)
 643       (setq to (file-truename to)
 644             from (file-truename from))
 645       ;; Set TO if have not already done so, and rename or copy
 646       ;; the file FROM to TO if and as appropriate.
 647       (cond
 648        ((file-exists-p to)
 649         ;; The crash box exists already.
 650         t)
 651        ((not (file-exists-p from))
 652         ;; There is no inbox.
 653         (setq to nil))
 654        ((zerop (nth 7 (file-attributes from)))
 655         ;; Empty file.
 656         (setq to nil))
 657        (t
 658         ;; If getting from mail spool directory, use movemail to move
 659         ;; rather than just renaming, so as to interlock with the
 660         ;; mailer.
 661         (unwind-protect
 662             (save-excursion
 663               (setq errors (generate-new-buffer " *mail source loss*"))
 664               (let ((default-directory "/"))
 665                 (setq result
 666                       (apply
 667                        'call-process
 668                        (append
 669                         (list
 670                          (or mail-source-movemail-program
 671                              (expand-file-name "movemail" exec-directory))
 672                          nil errors nil from to)))))
 673               (when (file-exists-p to)
 674                 (set-file-modes to mail-source-default-file-modes))
 675               (if (and (or (not (buffer-modified-p errors))
 676                            (zerop (buffer-size errors)))
 677                        (and (numberp result)
 678                             (zerop result)))
 679                   ;; No output => movemail won.
 680                   t
 681                 (set-buffer errors)
 682                 ;; There may be a warning about older revisions.  We
 683                 ;; ignore that.
 684                 (goto-char (point-min))
 685                 (if (search-forward "older revision" nil t)
 686                     t
 687                   ;; Probably a real error.
 688                   (subst-char-in-region (point-min) (point-max) ?\n ?\  )
 689                   (goto-char (point-max))
 690                   (skip-chars-backward " \t")
 691                   (delete-region (point) (point-max))
 692                   (goto-char (point-min))
 693                   (when (looking-at "movemail: ")
 694                     (delete-region (point-min) (match-end 0)))
 695                   ;; Result may be a signal description string.
 696                   (unless (yes-or-no-p
 697                            (format "movemail: %s (%s return).  Continue? "
 698                                    (buffer-string) result))
 699                     (error "%s" (buffer-string)))
 700                   (setq to nil)))))))
 701       (when (and errors
 702                  (buffer-name errors))
 703         (kill-buffer errors))
 704       ;; Return whether we moved successfully or not.
 705       to)))
 706
 707 (defun mail-source-movemail-and-remove (from to)
 708   "Move FROM to TO using movemail, then remove FROM if empty."
 709   (or (not (mail-source-movemail from to))
 710       (not (zerop (nth 7 (file-attributes from))))
 711       (delete-file from)))
 712
 713 (defun mail-source-fetch-with-program (program)
 714   (eq 0 (call-process shell-file-name nil nil nil
 715                       shell-command-switch program)))
 716
 717 (defun mail-source-run-script (script spec &optional delay)
 718   (when script
 719     (if (functionp script)
 720         (funcall script)
 721       (mail-source-call-script
 722        (format-spec script spec))))
 723   (when delay
 724     (sleep-for delay)))
 725
 726 (defun mail-source-call-script (script)
 727   (let ((background nil)
 728         (stderr (get-buffer-create " *mail-source-stderr*"))
 729         result)
 730     (when (string-match "& *$" script)
 731       (setq script (substring script 0 (match-beginning 0))
 732             background 0))
 733     (setq result
 734           (call-process shell-file-name nil background nil
 735                         shell-command-switch script))
 736     (when (and result
 737                (not (zerop result)))
 738       (set-buffer stderr)
 739       (message "Mail source error: %s" (buffer-string)))
 740     (kill-buffer stderr)))
 741
 742 ;;;
 743 ;;; Different fetchers
 744 ;;;
 745
 746 (defun mail-source-fetch-file (source callback)
 747   "Fetcher for single-file sources."
 748   (mail-source-bind (file source)
 749     (mail-source-run-script
 750      prescript (format-spec-make ?t mail-source-crash-box)
 751      prescript-delay)
 752     (let ((mail-source-string (format "file:%s" path)))
 753       (if (mail-source-movemail path mail-source-crash-box)
 754           (prog1
 755               (mail-source-callback callback path)
 756             (mail-source-run-script
 757              postscript (format-spec-make ?t mail-source-crash-box))
 758             (mail-source-delete-crash-box))
 759         0))))
 760
 761 (defun mail-source-fetch-directory (source callback)
 762   "Fetcher for directory sources."
 763   (mail-source-bind (directory source)
 764     (mail-source-run-script
 765      prescript (format-spec-make ?t path) prescript-delay)
 766     (let ((found 0)
 767           (mail-source-string (format "directory:%s" path)))
 768       (dolist (file (directory-files
 769                      path t (concat (regexp-quote suffix) "$")))
 770         (when (and (file-regular-p file)
 771                    (funcall predicate file)
 772                    (mail-source-movemail file mail-source-crash-box))
 773           (incf found (mail-source-callback callback file))
 774           (mail-source-run-script postscript (format-spec-make ?t path))
 775           (mail-source-delete-crash-box)))
 776       found)))
 777
 778 (defun mail-source-fetch-pop (source callback)
 779   "Fetcher for single-file sources."
 780   (mail-source-bind (pop source)
 781     ;; fixme: deal with stream type in format specs
 782     (mail-source-run-script
 783      prescript
 784      (format-spec-make ?p password ?t mail-source-crash-box
 785                        ?s server ?P port ?u user)
 786      prescript-delay)
 787     (let ((from (format "%s:%s:%s" server user port))
 788           (mail-source-string (format "pop:%s@%s" user server))
 789           result)
 790       (when (eq authentication 'password)
 791         (setq password
 792               (or password
 793                   (cdr (assoc from mail-source-password-cache))
 794                   (read-passwd
 795                    (format "Password for %s at %s: " user server)))))
 796       (when server
 797         (setenv "MAILHOST" server))
 798       (setq result
 799             (cond
 800              (program
 801               (mail-source-fetch-with-program
 802                (format-spec
 803                 program
 804                 (format-spec-make ?p password ?t mail-source-crash-box
 805                                   ?s server ?P port ?u user))))
 806              (function
 807               (funcall function mail-source-crash-box))
 808              ;; The default is to use pop3.el.
 809              (t
 810               (require 'pop3)
 811               (let ((pop3-password password)
 812                     (pop3-maildrop user)
 813                     (pop3-mailhost server)
 814                     (pop3-port port)
 815                     (pop3-authentication-scheme
 816                      (if (eq authentication 'apop) 'apop 'pass))
 817                     (pop3-stream-type stream))
 818                 (if (or debug-on-quit debug-on-error)
 819                     (save-excursion (pop3-movemail mail-source-crash-box))
 820                   (condition-case err
 821                       (save-excursion (pop3-movemail mail-source-crash-box))
 822                     (error
 823                      ;; We nix out the password in case the error
 824                      ;; was because of a wrong password being given.
 825                      (setq mail-source-password-cache
 826                            (delq (assoc from mail-source-password-cache)
 827                                  mail-source-password-cache))
 828                      (signal (car err) (cdr err)))))))))
 829       (if result
 830           (progn
 831             (when (eq authentication 'password)
 832               (unless (assoc from mail-source-password-cache)
 833                 (push (cons from password) mail-source-password-cache)))
 834             (prog1
 835                 (mail-source-callback callback server)
 836               ;; Update display-time's mail flag, if relevant.
 837               (if (equal source mail-source-primary-source)
 838                   (setq mail-source-new-mail-available nil))
 839               (mail-source-run-script
 840                postscript
 841                (format-spec-make ?p password ?t mail-source-crash-box
 842                                  ?s server ?P port ?u user))
 843               (mail-source-delete-crash-box)))
 844         ;; We nix out the password in case the error
 845         ;; was because of a wrong password being given.
 846         (setq mail-source-password-cache
 847               (delq (assoc from mail-source-password-cache)
 848                     mail-source-password-cache))
 849         0))))
 850
 851 (defun mail-source-check-pop (source)
 852   "Check whether there is new mail."
 853   (mail-source-bind (pop source)
 854     (let ((from (format "%s:%s:%s" server user port))
 855           (mail-source-string (format "pop:%s@%s" user server))
 856           result)
 857       (when (eq authentication 'password)
 858         (setq password
 859               (or password
 860                   (cdr (assoc from mail-source-password-cache))
 861                   (read-passwd
 862                    (format "Password for %s at %s: " user server))))
 863         (unless (assoc from mail-source-password-cache)
 864           (push (cons from password) mail-source-password-cache)))
 865       (when server
 866         (setenv "MAILHOST" server))
 867       (setq result
 868             (cond
 869              ;; No easy way to check whether mail is waiting for these.
 870              (program)
 871              (function)
 872              ;; The default is to use pop3.el.
 873              (t
 874               (require 'pop3)
 875               (let ((pop3-password password)
 876                     (pop3-maildrop user)
 877                     (pop3-mailhost server)
 878                     (pop3-port port)
 879                     (pop3-authentication-scheme
 880                      (if (eq authentication 'apop) 'apop 'pass)))
 881                 (if (or debug-on-quit debug-on-error)
 882                     (save-excursion (pop3-get-message-count))
 883                   (condition-case err
 884                       (save-excursion (pop3-get-message-count))
 885                     (error
 886                      ;; We nix out the password in case the error
 887                      ;; was because of a wrong password being given.
 888                      (setq mail-source-password-cache
 889                            (delq (assoc from mail-source-password-cache)
 890                                  mail-source-password-cache))
 891                      (signal (car err) (cdr err)))))))))
 892       (if result
 893           ;; Inform display-time that we have new mail.
 894           (setq mail-source-new-mail-available (> result 0))
 895         ;; We nix out the password in case the error
 896         ;; was because of a wrong password being given.
 897         (setq mail-source-password-cache
 898               (delq (assoc from mail-source-password-cache)
 899                     mail-source-password-cache)))
 900       result)))
 901
 902 (defun mail-source-touch-pop ()
 903   "Open and close a POP connection shortly.
 904 POP server should be defined in `mail-source-primary-source' (which is
 905 preferred) or `mail-sources'.  You may use it for the POP-before-SMTP
 906 authentication.  To do that, you need to set the
 907 `message-send-mail-function' variable as `message-smtpmail-send-it'
 908 and put the following line in your ~/.gnus.el file:
 909
 910 \(add-hook 'message-send-mail-hook 'mail-source-touch-pop)
 911
 912 See the Gnus manual for details."
 913   (let ((sources (if mail-source-primary-source
 914                      (list mail-source-primary-source)
 915                    mail-sources)))
 916     (while sources
 917       (if (eq 'pop (car (car sources)))
 918           (mail-source-check-pop (car sources)))
 919       (setq sources (cdr sources)))))
 920
 921 (defun mail-source-new-mail-p ()
 922   "Handler for `display-time' to indicate when new mail is available."
 923   ;; Flash (ie. ring the visible bell) if mail is available.
 924   (if (and mail-source-flash mail-source-new-mail-available)
 925       (let ((visible-bell t))
 926         (ding)))
 927   ;; Only report flag setting; flag is updated on a different schedule.
 928   mail-source-new-mail-available)
 929
 930
 931 (defvar mail-source-report-new-mail nil)
 932 (defvar mail-source-report-new-mail-timer nil)
 933 (defvar mail-source-report-new-mail-idle-timer nil)
 934
 935 (defun mail-source-start-idle-timer ()
 936   ;; Start our idle timer if necessary, so we delay the check until the
 937   ;; user isn't typing.
 938   (unless mail-source-report-new-mail-idle-timer
 939     (setq mail-source-report-new-mail-idle-timer
 940           (run-with-idle-timer
 941            mail-source-idle-time-delay
 942            nil
 943            (lambda ()
 944              (unwind-protect
 945                  (mail-source-check-pop mail-source-primary-source)
 946                (setq mail-source-report-new-mail-idle-timer nil)))))
 947     ;; Since idle timers created when Emacs is already in the idle
 948     ;; state don't get activated until Emacs _next_ becomes idle, we
 949     ;; need to force our timer to be considered active now.  We do
 950     ;; this by being naughty and poking the timer internals directly
 951     ;; (element 0 of the vector is nil if the timer is active).
 952     (aset mail-source-report-new-mail-idle-timer 0 nil)))
 953
 954 (defun mail-source-report-new-mail (arg)
 955   "Toggle whether to report when new mail is available.
 956 This only works when `display-time' is enabled."
 957   (interactive "P")
 958   (if (not mail-source-primary-source)
 959       (error "Need to set `mail-source-primary-source' to check for new mail"))
 960   (let ((on (if (null arg)
 961                 (not mail-source-report-new-mail)
 962               (> (prefix-numeric-value arg) 0))))
 963     (setq mail-source-report-new-mail on)
 964     (and mail-source-report-new-mail-timer
 965          (nnheader-cancel-timer mail-source-report-new-mail-timer))
 966     (and mail-source-report-new-mail-idle-timer
 967          (nnheader-cancel-timer mail-source-report-new-mail-idle-timer))
 968     (setq mail-source-report-new-mail-timer nil)
 969     (setq mail-source-report-new-mail-idle-timer nil)
 970     (if on
 971         (progn
 972           (require 'time)
 973           ;; display-time-mail-function is an Emacs 21 feature.
 974           (setq display-time-mail-function #'mail-source-new-mail-p)
 975           ;; Set up the main timer.
 976           (setq mail-source-report-new-mail-timer
 977                 (run-at-time
 978                  (* 60 mail-source-report-new-mail-interval)
 979                  (* 60 mail-source-report-new-mail-interval)
 980                  #'mail-source-start-idle-timer))
 981           ;; When you get new mail, clear "Mail" from the mode line.
 982           (add-hook 'nnmail-post-get-new-mail-hook
 983                     'display-time-event-handler)
 984           (message "Mail check enabled"))
 985       (setq display-time-mail-function nil)
 986       (remove-hook 'nnmail-post-get-new-mail-hook
 987                    'display-time-event-handler)
 988       (message "Mail check disabled"))))
 989
 990 (defun mail-source-fetch-maildir (source callback)
 991   "Fetcher for maildir sources."
 992   (mail-source-bind (maildir source)
 993     (let ((found 0)
 994           mail-source-string)
 995       (unless (string-match "/$" path)
 996         (setq path (concat path "/")))
 997       (dolist (subdir subdirs)
 998         (when (file-directory-p (concat path subdir))
 999           (setq mail-source-string (format "maildir:%s%s" path subdir))
1000           (dolist (file (directory-files (concat path subdir) t))
1001             (when (and (not (file-directory-p file))
1002                        (not (if function
1003                                 (funcall function file mail-source-crash-box)
1004                               (let ((coding-system-for-write
1005                                      mm-text-coding-system)
1006                                     (coding-system-for-read
1007                                      mm-text-coding-system))
1008                                 (with-temp-file mail-source-crash-box
1009                                   (insert-file-contents file)
1010                                   (goto-char (point-min))
1011 ;;;                               ;; Unix mail format
1012 ;;;                               (unless (looking-at "\n*From ")
1013 ;;;                                 (insert "From maildir "
1014 ;;;                                         (current-time-string) "\n"))
1015 ;;;                               (while (re-search-forward "^From " nil t)
1016 ;;;                                 (replace-match ">From "))
1017 ;;;                               (goto-char (point-max))
1018 ;;;                               (insert "\n\n")
1019                                   ;; MMDF mail format
1020                                   (insert "\001\001\001\001\n"))
1021                                 (delete-file file)))))
1022               (incf found (mail-source-callback callback file))
1023               (mail-source-delete-crash-box)))))
1024       found)))
1025
1026 (eval-and-compile
1027   (autoload 'imap-open "imap")
1028   (autoload 'imap-authenticate "imap")
1029   (autoload 'imap-mailbox-select "imap")
1030   (autoload 'imap-mailbox-unselect "imap")
1031   (autoload 'imap-mailbox-close "imap")
1032   (autoload 'imap-search "imap")
1033   (autoload 'imap-fetch "imap")
1034   (autoload 'imap-close "imap")
1035   (autoload 'imap-error-text "imap")
1036   (autoload 'imap-message-flags-add "imap")
1037   (autoload 'imap-list-to-message-set "imap")
1038   (autoload 'imap-range-to-message-set "imap")
1039   (autoload 'nnheader-ms-strip-cr "nnheader"))
1040
1041 (autoload 'gnus-compress-sequence "gnus-range")
1042
1043 (defvar mail-source-imap-file-coding-system 'binary
1044   "Coding system for the crashbox made by `mail-source-fetch-imap'.")
1045
1046 ;; Autoloads will bring in imap before this is called.
1047 (declare-function imap-capability "imap" (&optional identifier buffer))
1048
1049 (defun mail-source-fetch-imap (source callback)
1050   "Fetcher for imap sources."
1051   (mail-source-bind (imap source)
1052     (mail-source-run-script
1053      prescript (format-spec-make ?p password ?t mail-source-crash-box
1054                                  ?s server ?P port ?u user)
1055      prescript-delay)
1056     (let ((from (format "%s:%s:%s" server user port))
1057           (found 0)
1058           (buf (generate-new-buffer " *imap source*"))
1059           (mail-source-string (format "imap:%s:%s" server mailbox))
1060           (imap-shell-program (or (list program) imap-shell-program))
1061           remove)
1062       (if (and (imap-open server port stream authentication buf)
1063                (imap-authenticate
1064                 user (or (cdr (assoc from mail-source-password-cache))
1065                          password) buf)
1066                (imap-mailbox-select mailbox nil buf))
1067           (let ((coding-system-for-write mail-source-imap-file-coding-system)
1068                 str)
1069             (with-temp-file mail-source-crash-box
1070               ;; Avoid converting 8-bit chars from inserted strings to
1071               ;; multibyte.
1072               (mm-disable-multibyte)
1073               ;; remember password
1074               (with-current-buffer buf
1075                 (when (and imap-password
1076                            (not (assoc from mail-source-password-cache)))
1077                   (push (cons from imap-password) mail-source-password-cache)))
1078               ;; if predicate is nil, use all uids
1079               (dolist (uid (imap-search (or predicate "1:*") buf))
1080                 (when (setq str
1081                             (if (imap-capability 'IMAP4rev1 buf)
1082                                 (caddar (imap-fetch uid "BODY.PEEK[]"
1083                                                     'BODYDETAIL nil buf))
1084                               (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf)))
1085                   (push uid remove)
1086                   (insert "From imap " (current-time-string) "\n")
1087                   (save-excursion
1088                     (insert str "\n\n"))
1089                   (while (let ((case-fold-search nil))
1090                            (re-search-forward "^From " nil t))
1091                     (replace-match ">From "))
1092                   (goto-char (point-max))))
1093               (nnheader-ms-strip-cr))
1094             (incf found (mail-source-callback callback server))
1095             (mail-source-delete-crash-box)
1096             (when (and remove fetchflag)
1097               (setq remove (nreverse remove))
1098               (imap-message-flags-add
1099                (imap-range-to-message-set (gnus-compress-sequence remove))
1100                fetchflag nil buf))
1101             (if dontexpunge
1102                 (imap-mailbox-unselect buf)
1103               (imap-mailbox-close nil buf))
1104             (imap-close buf))
1105         (imap-close buf)
1106         ;; We nix out the password in case the error
1107         ;; was because of a wrong password being given.
1108         (setq mail-source-password-cache
1109               (delq (assoc from mail-source-password-cache)
1110                     mail-source-password-cache))
1111         (error "IMAP error: %s" (imap-error-text buf)))
1112       (kill-buffer buf)
1113       (mail-source-run-script
1114        postscript
1115        (format-spec-make ?p password ?t mail-source-crash-box
1116                          ?s server ?P port ?u user))
1117       found)))
1118
1119 (eval-and-compile
1120   (autoload 'webmail-fetch "webmail"))
1121
1122 (defun mail-source-fetch-webmail (source callback)
1123   "Fetch for webmail source."
1124   (mail-source-bind (webmail source)
1125     (let ((mail-source-string (format "webmail:%s:%s" subtype user))
1126           (webmail-newmail-only dontexpunge)
1127           (webmail-move-to-trash-can (not dontexpunge)))
1128       (when (eq authentication 'password)
1129         (setq password
1130               (or password
1131                   (cdr (assoc (format "webmail:%s:%s" subtype user)
1132                               mail-source-password-cache))
1133                   (read-passwd
1134                    (format "Password for %s at %s: " user subtype))))
1135         (when (and password
1136                    (not (assoc (format "webmail:%s:%s" subtype user)
1137                                mail-source-password-cache)))
1138           (push (cons (format "webmail:%s:%s" subtype user) password)
1139                 mail-source-password-cache)))
1140       (webmail-fetch mail-source-crash-box subtype user password)
1141       (mail-source-callback callback (symbol-name subtype))
1142       (mail-source-delete-crash-box))))
1143
1144 (provide 'mail-source)
1145
1146 ;; arch-tag: 72948025-1d17-4d6c-bb12-ef1aa2c490fd
1147 ;;; mail-source.el ends here