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 nil
 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.2" ;; No Gnus / Gnus 5.10.10 (default changed)
 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 "\\`"
 559                          (regexp-quote mail-source-incoming-file-prefix)))
 560           currday (* (car (current-time)) high2days)
 561           currday (+ currday (* low2days (nth 1 (current-time)))))
 562     (while files
 563       (let* ((ffile (car files))
 564              (bfile (gnus-replace-in-string
 565                      ffile "\\`.*/\\([^/]+\\)\\'" "\\1"))
 566              (filetime (nth 5 (file-attributes ffile)))
 567              (fileday (* (car filetime) high2days))
 568              (fileday (+ fileday (* low2days (nth 1 filetime)))))
 569         (setq files (cdr files))
 570         (when (and (> (- currday fileday) diff)
 571                    (if confirm
 572                        (y-or-n-p
 573                         (format "\
 574 Delete old (> %s day(s)) incoming mail file `%s'? " diff bfile))
 575                      (gnus-message 8 "\
 576 Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
 577                      t))
 578           (delete-file ffile))))))
 579
 580 (defun mail-source-callback (callback info)
 581   "Call CALLBACK on the mail file.  Pass INFO on to CALLBACK."
 582   (if (or (not (file-exists-p mail-source-crash-box))
 583           (zerop (nth 7 (file-attributes mail-source-crash-box))))
 584       (progn
 585         (when (file-exists-p mail-source-crash-box)
 586           (delete-file mail-source-crash-box))
 587         0)
 588     (funcall callback mail-source-crash-box info)))
 589
 590 (defun mail-source-delete-crash-box ()
 591   (when (file-exists-p mail-source-crash-box)
 592     ;; Delete or move the incoming mail out of the way.
 593     (if (eq mail-source-delete-incoming t)
 594         (delete-file mail-source-crash-box)
 595       (let ((incoming
 596              (mm-make-temp-file
 597               (expand-file-name
 598                mail-source-incoming-file-prefix
 599                mail-source-directory))))
 600         (unless (file-exists-p (file-name-directory incoming))
 601           (make-directory (file-name-directory incoming) t))
 602         (rename-file mail-source-crash-box incoming t)
 603         ;; remove old incoming files?
 604         (when (natnump mail-source-delete-incoming)
 605           (mail-source-delete-old-incoming
 606            mail-source-delete-incoming
 607            mail-source-delete-old-incoming-confirm))))))
 608
 609 (defun mail-source-movemail (from to)
 610   "Move FROM to TO using movemail."
 611   (if (not (file-writable-p to))
 612       (error "Can't write to crash box %s.  Not moving mail" to)
 613     (let ((to (file-truename (expand-file-name to)))
 614           errors result)
 615       (setq to (file-truename to)
 616             from (file-truename from))
 617       ;; Set TO if have not already done so, and rename or copy
 618       ;; the file FROM to TO if and as appropriate.
 619       (cond
 620        ((file-exists-p to)
 621         ;; The crash box exists already.
 622         t)
 623        ((not (file-exists-p from))
 624         ;; There is no inbox.
 625         (setq to nil))
 626        ((zerop (nth 7 (file-attributes from)))
 627         ;; Empty file.
 628         (setq to nil))
 629        (t
 630         ;; If getting from mail spool directory, use movemail to move
 631         ;; rather than just renaming, so as to interlock with the
 632         ;; mailer.
 633         (unwind-protect
 634             (save-excursion
 635               (setq errors (generate-new-buffer " *mail source loss*"))
 636               (let ((default-directory "/"))
 637                 (setq result
 638                       (apply
 639                        'call-process
 640                        (append
 641                         (list
 642                          (or mail-source-movemail-program
 643                              (expand-file-name "movemail" exec-directory))
 644                          nil errors nil from to)))))
 645               (when (file-exists-p to)
 646                 (set-file-modes to mail-source-default-file-modes))
 647               (if (and (or (not (buffer-modified-p errors))
 648                            (zerop (buffer-size errors)))
 649                        (and (numberp result)
 650                             (zerop result)))
 651                   ;; No output => movemail won.
 652                   t
 653                 (set-buffer errors)
 654                 ;; There may be a warning about older revisions.  We
 655                 ;; ignore that.
 656                 (goto-char (point-min))
 657                 (if (search-forward "older revision" nil t)
 658                     t
 659                   ;; Probably a real error.
 660                   (subst-char-in-region (point-min) (point-max) ?\n ?\  )
 661                   (goto-char (point-max))
 662                   (skip-chars-backward " \t")
 663                   (delete-region (point) (point-max))
 664                   (goto-char (point-min))
 665                   (when (looking-at "movemail: ")
 666                     (delete-region (point-min) (match-end 0)))
 667                   ;; Result may be a signal description string.
 668                   (unless (yes-or-no-p
 669                            (format "movemail: %s (%s return).  Continue? "
 670                                    (buffer-string) result))
 671                     (error "%s" (buffer-string)))
 672                   (setq to nil)))))))
 673       (when (and errors
 674                  (buffer-name errors))
 675         (kill-buffer errors))
 676       ;; Return whether we moved successfully or not.
 677       to)))
 678
 679 (defun mail-source-movemail-and-remove (from to)
 680   "Move FROM to TO using movemail, then remove FROM if empty."
 681   (or (not (mail-source-movemail from to))
 682       (not (zerop (nth 7 (file-attributes from))))
 683       (delete-file from)))
 684
 685 (defun mail-source-fetch-with-program (program)
 686   (eq 0 (call-process shell-file-name nil nil nil
 687                       shell-command-switch program)))
 688
 689 (defun mail-source-run-script (script spec &optional delay)
 690   (when script
 691     (if (functionp script)
 692         (funcall script)
 693       (mail-source-call-script
 694        (format-spec script spec))))
 695   (when delay
 696     (sleep-for delay)))
 697
 698 (defun mail-source-call-script (script)
 699   (let ((background nil)
 700         (stderr (get-buffer-create " *mail-source-stderr*"))
 701         result)
 702     (when (string-match "& *$" script)
 703       (setq script (substring script 0 (match-beginning 0))
 704             background 0))
 705     (setq result
 706           (call-process shell-file-name nil background nil
 707                         shell-command-switch script))
 708     (when (and result
 709                (not (zerop result)))
 710       (set-buffer stderr)
 711       (message "Mail source error: %s" (buffer-string)))
 712     (kill-buffer stderr)))
 713
 714 ;;;
 715 ;;; Different fetchers
 716 ;;;
 717
 718 (defun mail-source-fetch-file (source callback)
 719   "Fetcher for single-file sources."
 720   (mail-source-bind (file source)
 721     (mail-source-run-script
 722      prescript (format-spec-make ?t mail-source-crash-box)
 723      prescript-delay)
 724     (let ((mail-source-string (format "file:%s" path)))
 725       (if (mail-source-movemail path mail-source-crash-box)
 726           (prog1
 727               (mail-source-callback callback path)
 728             (mail-source-run-script
 729              postscript (format-spec-make ?t mail-source-crash-box))
 730             (mail-source-delete-crash-box))
 731         0))))
 732
 733 (defun mail-source-fetch-directory (source callback)
 734   "Fetcher for directory sources."
 735   (mail-source-bind (directory source)
 736     (mail-source-run-script
 737      prescript (format-spec-make ?t path) prescript-delay)
 738     (let ((found 0)
 739           (mail-source-string (format "directory:%s" path)))
 740       (dolist (file (directory-files
 741                      path t (concat (regexp-quote suffix) "$")))
 742         (when (and (file-regular-p file)
 743                    (funcall predicate file)
 744                    (mail-source-movemail file mail-source-crash-box))
 745           (incf found (mail-source-callback callback file))
 746           (mail-source-run-script postscript (format-spec-make ?t path))
 747           (mail-source-delete-crash-box)))
 748       found)))
 749
 750 (defun mail-source-fetch-pop (source callback)
 751   "Fetcher for single-file sources."
 752   (mail-source-bind (pop source)
 753     ;; fixme: deal with stream type in format specs
 754     (mail-source-run-script
 755      prescript
 756      (format-spec-make ?p password ?t mail-source-crash-box
 757                        ?s server ?P port ?u user)
 758      prescript-delay)
 759     (let ((from (format "%s:%s:%s" server user port))
 760           (mail-source-string (format "pop:%s@%s" user server))
 761           result)
 762       (when (eq authentication 'password)
 763         (setq password
 764               (or password
 765                   (cdr (assoc from mail-source-password-cache))
 766                   (read-passwd
 767                    (format "Password for %s at %s: " user server)))))
 768       (when server
 769         (setenv "MAILHOST" server))
 770       (setq result
 771             (cond
 772              (program
 773               (mail-source-fetch-with-program
 774                (format-spec
 775                 program
 776                 (format-spec-make ?p password ?t mail-source-crash-box
 777                                   ?s server ?P port ?u user))))
 778              (function
 779               (funcall function mail-source-crash-box))
 780              ;; The default is to use pop3.el.
 781              (t
 782               (require 'pop3)
 783               (let ((pop3-password password)
 784                     (pop3-maildrop user)
 785                     (pop3-mailhost server)
 786                     (pop3-port port)
 787                     (pop3-authentication-scheme
 788                      (if (eq authentication 'apop) 'apop 'pass))
 789                     (pop3-stream-type stream))
 790                 (if (or debug-on-quit debug-on-error)
 791                     (save-excursion (pop3-movemail mail-source-crash-box))
 792                   (condition-case err
 793                       (save-excursion (pop3-movemail mail-source-crash-box))
 794                     (error
 795                      ;; We nix out the password in case the error
 796                      ;; was because of a wrong password being given.
 797                      (setq mail-source-password-cache
 798                            (delq (assoc from mail-source-password-cache)
 799                                  mail-source-password-cache))
 800                      (signal (car err) (cdr err)))))))))
 801       (if result
 802           (progn
 803             (when (eq authentication 'password)
 804               (unless (assoc from mail-source-password-cache)
 805                 (push (cons from password) mail-source-password-cache)))
 806             (prog1
 807                 (mail-source-callback callback server)
 808               ;; Update display-time's mail flag, if relevant.
 809               (if (equal source mail-source-primary-source)
 810                   (setq mail-source-new-mail-available nil))
 811               (mail-source-run-script
 812                postscript
 813                (format-spec-make ?p password ?t mail-source-crash-box
 814                                  ?s server ?P port ?u user))
 815               (mail-source-delete-crash-box)))
 816         ;; We nix out the password in case the error
 817         ;; was because of a wrong password being given.
 818         (setq mail-source-password-cache
 819               (delq (assoc from mail-source-password-cache)
 820                     mail-source-password-cache))
 821         0))))
 822
 823 (defun mail-source-check-pop (source)
 824   "Check whether there is new mail."
 825   (mail-source-bind (pop source)
 826     (let ((from (format "%s:%s:%s" server user port))
 827           (mail-source-string (format "pop:%s@%s" user server))
 828           result)
 829       (when (eq authentication 'password)
 830         (setq password
 831               (or password
 832                   (cdr (assoc from mail-source-password-cache))
 833                   (read-passwd
 834                    (format "Password for %s at %s: " user server))))
 835         (unless (assoc from mail-source-password-cache)
 836           (push (cons from password) mail-source-password-cache)))
 837       (when server
 838         (setenv "MAILHOST" server))
 839       (setq result
 840             (cond
 841              ;; No easy way to check whether mail is waiting for these.
 842              (program)
 843              (function)
 844              ;; The default is to use pop3.el.
 845              (t
 846               (require 'pop3)
 847               (let ((pop3-password password)
 848                     (pop3-maildrop user)
 849                     (pop3-mailhost server)
 850                     (pop3-port port)
 851                     (pop3-authentication-scheme
 852                      (if (eq authentication 'apop) 'apop 'pass)))
 853                 (if (or debug-on-quit debug-on-error)
 854                     (save-excursion (pop3-get-message-count))
 855                   (condition-case err
 856                       (save-excursion (pop3-get-message-count))
 857                     (error
 858                      ;; We nix out the password in case the error
 859                      ;; was because of a wrong password being given.
 860                      (setq mail-source-password-cache
 861                            (delq (assoc from mail-source-password-cache)
 862                                  mail-source-password-cache))
 863                      (signal (car err) (cdr err)))))))))
 864       (if result
 865           ;; Inform display-time that we have new mail.
 866           (setq mail-source-new-mail-available (> result 0))
 867         ;; We nix out the password in case the error
 868         ;; was because of a wrong password being given.
 869         (setq mail-source-password-cache
 870               (delq (assoc from mail-source-password-cache)
 871                     mail-source-password-cache)))
 872       result)))
 873
 874 (defun mail-source-touch-pop ()
 875   "Open and close a POP connection shortly.
 876 POP server should be defined in `mail-source-primary-source' (which is
 877 preferred) or `mail-sources'.  You may use it for the POP-before-SMTP
 878 authentication.  To do that, you need to set the
 879 `message-send-mail-function' variable as `message-smtpmail-send-it'
 880 and put the following line in your ~/.gnus.el file:
 881
 882 \(add-hook 'message-send-mail-hook 'mail-source-touch-pop)
 883
 884 See the Gnus manual for details."
 885   (let ((sources (if mail-source-primary-source
 886                      (list mail-source-primary-source)
 887                    mail-sources)))
 888     (while sources
 889       (if (eq 'pop (car (car sources)))
 890           (mail-source-check-pop (car sources)))
 891       (setq sources (cdr sources)))))
 892
 893 (defun mail-source-new-mail-p ()
 894   "Handler for `display-time' to indicate when new mail is available."
 895   ;; Flash (ie. ring the visible bell) if mail is available.
 896   (if (and mail-source-flash mail-source-new-mail-available)
 897       (let ((visible-bell t))
 898         (ding)))
 899   ;; Only report flag setting; flag is updated on a different schedule.
 900   mail-source-new-mail-available)
 901
 902
 903 (defvar mail-source-report-new-mail nil)
 904 (defvar mail-source-report-new-mail-timer nil)
 905 (defvar mail-source-report-new-mail-idle-timer nil)
 906
 907 (defun mail-source-start-idle-timer ()
 908   ;; Start our idle timer if necessary, so we delay the check until the
 909   ;; user isn't typing.
 910   (unless mail-source-report-new-mail-idle-timer
 911     (setq mail-source-report-new-mail-idle-timer
 912           (run-with-idle-timer
 913            mail-source-idle-time-delay
 914            nil
 915            (lambda ()
 916              (unwind-protect
 917                  (mail-source-check-pop mail-source-primary-source)
 918                (setq mail-source-report-new-mail-idle-timer nil)))))
 919     ;; Since idle timers created when Emacs is already in the idle
 920     ;; state don't get activated until Emacs _next_ becomes idle, we
 921     ;; need to force our timer to be considered active now.  We do
 922     ;; this by being naughty and poking the timer internals directly
 923     ;; (element 0 of the vector is nil if the timer is active).
 924     (aset mail-source-report-new-mail-idle-timer 0 nil)))
 925
 926 (defun mail-source-report-new-mail (arg)
 927   "Toggle whether to report when new mail is available.
 928 This only works when `display-time' is enabled."
 929   (interactive "P")
 930   (if (not mail-source-primary-source)
 931       (error "Need to set `mail-source-primary-source' to check for new mail"))
 932   (let ((on (if (null arg)
 933                 (not mail-source-report-new-mail)
 934               (> (prefix-numeric-value arg) 0))))
 935     (setq mail-source-report-new-mail on)
 936     (and mail-source-report-new-mail-timer
 937          (nnheader-cancel-timer mail-source-report-new-mail-timer))
 938     (and mail-source-report-new-mail-idle-timer
 939          (nnheader-cancel-timer mail-source-report-new-mail-idle-timer))
 940     (setq mail-source-report-new-mail-timer nil)
 941     (setq mail-source-report-new-mail-idle-timer nil)
 942     (if on
 943         (progn
 944           (require 'time)
 945           ;; display-time-mail-function is an Emacs 21 feature.
 946           (setq display-time-mail-function #'mail-source-new-mail-p)
 947           ;; Set up the main timer.
 948           (setq mail-source-report-new-mail-timer
 949                 (run-at-time
 950                  (* 60 mail-source-report-new-mail-interval)
 951                  (* 60 mail-source-report-new-mail-interval)
 952                  #'mail-source-start-idle-timer))
 953           ;; When you get new mail, clear "Mail" from the mode line.
 954           (add-hook 'nnmail-post-get-new-mail-hook
 955                     'display-time-event-handler)
 956           (message "Mail check enabled"))
 957       (setq display-time-mail-function nil)
 958       (remove-hook 'nnmail-post-get-new-mail-hook
 959                    'display-time-event-handler)
 960       (message "Mail check disabled"))))
 961
 962 (defun mail-source-fetch-maildir (source callback)
 963   "Fetcher for maildir sources."
 964   (mail-source-bind (maildir source)
 965     (let ((found 0)
 966           mail-source-string)
 967       (unless (string-match "/$" path)
 968         (setq path (concat path "/")))
 969       (dolist (subdir subdirs)
 970         (when (file-directory-p (concat path subdir))
 971           (setq mail-source-string (format "maildir:%s%s" path subdir))
 972           (dolist (file (directory-files (concat path subdir) t))
 973             (when (and (not (file-directory-p file))
 974                        (not (if function
 975                                 (funcall function file mail-source-crash-box)
 976                               (let ((coding-system-for-write
 977                                      mm-text-coding-system)
 978                                     (coding-system-for-read
 979                                      mm-text-coding-system))
 980                                 (with-temp-file mail-source-crash-box
 981                                   (insert-file-contents file)
 982                                   (goto-char (point-min))
 983 ;;;                               ;; Unix mail format
 984 ;;;                               (unless (looking-at "\n*From ")
 985 ;;;                                 (insert "From maildir "
 986 ;;;                                         (current-time-string) "\n"))
 987 ;;;                               (while (re-search-forward "^From " nil t)
 988 ;;;                                 (replace-match ">From "))
 989 ;;;                               (goto-char (point-max))
 990 ;;;                               (insert "\n\n")
 991                                   ;; MMDF mail format
 992                                   (insert "\001\001\001\001\n"))
 993                                 (delete-file file)))))
 994               (incf found (mail-source-callback callback file))
 995               (mail-source-delete-crash-box)))))
 996       found)))
 997
 998 (eval-and-compile
 999   (autoload 'imap-open "imap")
1000   (autoload 'imap-authenticate "imap")
1001   (autoload 'imap-mailbox-select "imap")
1002   (autoload 'imap-mailbox-unselect "imap")
1003   (autoload 'imap-mailbox-close "imap")
1004   (autoload 'imap-search "imap")
1005   (autoload 'imap-fetch "imap")
1006   (autoload 'imap-close "imap")
1007   (autoload 'imap-error-text "imap")
1008   (autoload 'imap-message-flags-add "imap")
1009   (autoload 'imap-list-to-message-set "imap")
1010   (autoload 'imap-range-to-message-set "imap")
1011   (autoload 'nnheader-ms-strip-cr "nnheader"))
1012
1013 (autoload 'gnus-compress-sequence "gnus-range")
1014
1015 (defvar mail-source-imap-file-coding-system 'binary
1016   "Coding system for the crashbox made by `mail-source-fetch-imap'.")
1017
1018 ;; Autoloads will bring in imap before this is called.
1019 (declare-function imap-capability "imap" (&optional identifier buffer))
1020
1021 (defun mail-source-fetch-imap (source callback)
1022   "Fetcher for imap sources."
1023   (mail-source-bind (imap source)
1024     (mail-source-run-script
1025      prescript (format-spec-make ?p password ?t mail-source-crash-box
1026                                  ?s server ?P port ?u user)
1027      prescript-delay)
1028     (let ((from (format "%s:%s:%s" server user port))
1029           (found 0)
1030           (buf (generate-new-buffer " *imap source*"))
1031           (mail-source-string (format "imap:%s:%s" server mailbox))
1032           (imap-shell-program (or (list program) imap-shell-program))
1033           remove)
1034       (if (and (imap-open server port stream authentication buf)
1035                (imap-authenticate
1036                 user (or (cdr (assoc from mail-source-password-cache))
1037                          password) buf)
1038                (imap-mailbox-select mailbox nil buf))
1039           (let ((coding-system-for-write mail-source-imap-file-coding-system)
1040                 str)
1041             (with-temp-file mail-source-crash-box
1042               ;; Avoid converting 8-bit chars from inserted strings to
1043               ;; multibyte.
1044               (mm-disable-multibyte)
1045               ;; remember password
1046               (with-current-buffer buf
1047                 (when (and imap-password
1048                            (not (assoc from mail-source-password-cache)))
1049                   (push (cons from imap-password) mail-source-password-cache)))
1050               ;; if predicate is nil, use all uids
1051               (dolist (uid (imap-search (or predicate "1:*") buf))
1052                 (when (setq str
1053                             (if (imap-capability 'IMAP4rev1 buf)
1054                                 (caddar (imap-fetch uid "BODY.PEEK[]"
1055                                                     'BODYDETAIL nil buf))
1056                               (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf)))
1057                   (push uid remove)
1058                   (insert "From imap " (current-time-string) "\n")
1059                   (save-excursion
1060                     (insert str "\n\n"))
1061                   (while (let ((case-fold-search nil))
1062                            (re-search-forward "^From " nil t))
1063                     (replace-match ">From "))
1064                   (goto-char (point-max))))
1065               (nnheader-ms-strip-cr))
1066             (incf found (mail-source-callback callback server))
1067             (mail-source-delete-crash-box)
1068             (when (and remove fetchflag)
1069               (setq remove (nreverse remove))
1070               (imap-message-flags-add
1071                (imap-range-to-message-set (gnus-compress-sequence remove))
1072                fetchflag nil buf))
1073             (if dontexpunge
1074                 (imap-mailbox-unselect buf)
1075               (imap-mailbox-close nil buf))
1076             (imap-close buf))
1077         (imap-close buf)
1078         ;; We nix out the password in case the error
1079         ;; was because of a wrong password being given.
1080         (setq mail-source-password-cache
1081               (delq (assoc from mail-source-password-cache)
1082                     mail-source-password-cache))
1083         (error "IMAP error: %s" (imap-error-text buf)))
1084       (kill-buffer buf)
1085       (mail-source-run-script
1086        postscript
1087        (format-spec-make ?p password ?t mail-source-crash-box
1088                          ?s server ?P port ?u user))
1089       found)))
1090
1091 (eval-and-compile
1092   (autoload 'webmail-fetch "webmail"))
1093
1094 (defun mail-source-fetch-webmail (source callback)
1095   "Fetch for webmail source."
1096   (mail-source-bind (webmail source)
1097     (let ((mail-source-string (format "webmail:%s:%s" subtype user))
1098           (webmail-newmail-only dontexpunge)
1099           (webmail-move-to-trash-can (not dontexpunge)))
1100       (when (eq authentication 'password)
1101         (setq password
1102               (or password
1103                   (cdr (assoc (format "webmail:%s:%s" subtype user)
1104                               mail-source-password-cache))
1105                   (read-passwd
1106                    (format "Password for %s at %s: " user subtype))))
1107         (when (and password
1108                    (not (assoc (format "webmail:%s:%s" subtype user)
1109                                mail-source-password-cache)))
1110           (push (cons (format "webmail:%s:%s" subtype user) password)
1111                 mail-source-password-cache)))
1112       (webmail-fetch mail-source-crash-box subtype user password)
1113       (mail-source-callback callback (symbol-name subtype))
1114       (mail-source-delete-crash-box))))
1115
1116 (provide 'mail-source)
1117
1118 ;;; arch-tag: 72948025-1d17-4d6c-bb12-ef1aa2c490fd
1119 ;;; mail-source.el ends here