git.chise.org Git - elisp/gnus.git-/blob - lisp/mail-source.el

   1 ;;; mail-source.el --- functions for fetching mail
   2 ;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;; Keywords: news, mail
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-when-compile (require 'cl))
  29 (require 'nnheader)
  30 (eval-and-compile
  31   (defvar pop3-leave-mail-on-server)
  32   (autoload 'pop3-movemail "pop3")
  33   (autoload 'pop3-get-message-count "pop3"))
  34 (require 'format-spec)
  35
  36 (defgroup mail-source nil
  37   "The mail-fetching library."
  38   :group 'gnus)
  39
  40 (defcustom mail-sources nil
  41   "*Where the mail backends will look for incoming mail.
  42 This variable is a list of mail source specifiers."
  43   :group 'mail-source
  44   :type 'sexp)
  45
  46 (defcustom mail-source-primary-source nil
  47   "*Primary source for incoming mail.
  48 If non-nil, this maildrop will be checked periodically for new mail."
  49   :group 'mail-source
  50   :type 'sexp)
  51
  52 (defcustom mail-source-crash-box "~/.emacs-mail-crash-box"
  53   "File where mail will be stored while processing it."
  54   :group 'mail-source
  55   :type 'file)
  56
  57 (defcustom mail-source-directory "~/Mail/"
  58   "Directory where files (if any) will be stored."
  59   :group 'mail-source
  60   :type 'directory)
  61
  62 (defcustom mail-source-default-file-modes 384
  63   "Set the mode bits of all new mail files to this integer."
  64   :group 'mail-source
  65   :type 'integer)
  66
  67 (defcustom mail-source-delete-incoming nil
  68   "*If non-nil, delete incoming files after handling."
  69   :group 'mail-source
  70   :type 'boolean)
  71
  72 (defcustom mail-source-incoming-file-prefix "Incoming"
  73   "Prefix for file name for storing incoming mail"
  74   :group 'mail-source
  75   :type 'string)
  76
  77 (defcustom mail-source-report-new-mail-interval 5
  78   "Interval in minutes between checks for new mail."
  79   :group 'mail-source
  80   :type 'number)
  81
  82 (defcustom mail-source-idle-time-delay 5
  83   "Number of idle seconds to wait before checking for new mail."
  84   :group 'mail-source
  85   :type 'number)
  86
  87 ;;; Internal variables.
  88
  89 (defvar mail-source-string ""
  90   "A dynamically bound string that says what the current mail source is.")
  91
  92 (defvar mail-source-new-mail-available nil
  93   "Flag indicating when new mail is available.")
  94
  95 (eval-and-compile
  96   (defvar mail-source-common-keyword-map
  97     '((:plugged))
  98     "Mapping from keywords to default values.
  99 Common keywords should be listed here.")
 100
 101   (defvar mail-source-keyword-map
 102     '((file
 103        (:prescript)
 104        (:prescript-delay)
 105        (:postscript)
 106        (:path (or (getenv "MAIL")
 107                   (concat "/usr/spool/mail/" (user-login-name)))))
 108       (directory
 109        (:path)
 110        (:suffix ".spool")
 111        (:predicate identity))
 112       (pop
 113        (:prescript)
 114        (:prescript-delay)
 115        (:postscript)
 116        (:server (getenv "MAILHOST"))
 117        (:port 110)
 118        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
 119        (:program)
 120        (:function)
 121        (:password)
 122        (:connection)
 123        (:authentication password)
 124        (:leave))
 125       (maildir
 126        (:path (or (getenv "MAILDIR") "~/Maildir/"))
 127        (:subdirs ("new" "cur"))
 128        (:function))
 129       (imap
 130        (:server (getenv "MAILHOST"))
 131        (:port)
 132        (:stream)
 133        (:authentication)
 134        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
 135        (:password)
 136        (:mailbox "INBOX")
 137        (:predicate "UNSEEN UNDELETED")
 138        (:fetchflag "\\Deleted")
 139        (:dontexpunge))
 140       (webmail
 141        (:subtype hotmail)
 142        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
 143        (:password)
 144        (:dontexpunge)
 145        (:authentication password)))
 146     "Mapping from keywords to default values.
 147 All keywords that can be used must be listed here."))
 148
 149 (defvar mail-source-fetcher-alist
 150   '((file mail-source-fetch-file)
 151     (directory mail-source-fetch-directory)
 152     (pop mail-source-fetch-pop)
 153     (maildir mail-source-fetch-maildir)
 154     (imap mail-source-fetch-imap)
 155     (webmail mail-source-fetch-webmail))
 156   "A mapping from source type to fetcher function.")
 157
 158 (defvar mail-source-password-cache nil)
 159
 160 (defvar mail-source-plugged t)
 161
 162 ;;; Functions
 163
 164 (eval-and-compile
 165   (defun mail-source-strip-keyword (keyword)
 166     "Strip the leading colon off the KEYWORD."
 167     (intern (substring (symbol-name keyword) 1))))
 168
 169 (eval-and-compile
 170   (defun mail-source-bind-1 (type)
 171     (let* ((defaults (cdr (assq type mail-source-keyword-map)))
 172            default bind)
 173       (while (setq default (pop defaults))
 174         (push (list (mail-source-strip-keyword (car default))
 175                     nil)
 176               bind))
 177       bind)))
 178
 179 (defmacro mail-source-bind (type-source &rest body)
 180   "Return a `let' form that binds all variables in source TYPE.
 181 TYPE-SOURCE is a list where the first element is the TYPE, and
 182 the second variable is the SOURCE.
 183 At run time, the mail source specifier SOURCE will be inspected,
 184 and the variables will be set according to it.  Variables not
 185 specified will be given default values.
 186
 187 After this is done, BODY will be executed in the scope
 188 of the `let' form.
 189
 190 The variables bound and their default values are described by
 191 the `mail-source-keyword-map' variable."
 192   `(let ,(mail-source-bind-1 (car type-source))
 193      (mail-source-set-1 ,(cadr type-source))
 194      ,@body))
 195
 196 (put 'mail-source-bind 'lisp-indent-function 1)
 197 (put 'mail-source-bind 'edebug-form-spec '(form body))
 198
 199 (defun mail-source-set-1 (source)
 200   (let* ((type (pop source))
 201          (defaults (cdr (assq type mail-source-keyword-map)))
 202          default value keyword)
 203     (while (setq default (pop defaults))
 204       (set (mail-source-strip-keyword (setq keyword (car default)))
 205            (if (setq value (plist-get source keyword))
 206                (mail-source-value value)
 207              (mail-source-value (cadr default)))))))
 208
 209 (eval-and-compile
 210   (defun mail-source-bind-common-1 ()
 211     (let* ((defaults mail-source-common-keyword-map)
 212            default bind)
 213       (while (setq default (pop defaults))
 214         (push (list (mail-source-strip-keyword (car default))
 215                     nil)
 216               bind))
 217       bind)))
 218
 219 (defun mail-source-set-common-1 (source)
 220   (let* ((type (pop source))
 221          (defaults mail-source-common-keyword-map)
 222          (defaults-1 (cdr (assq type mail-source-keyword-map)))
 223          default value keyword)
 224     (while (setq default (pop defaults))
 225       (set (mail-source-strip-keyword (setq keyword (car default)))
 226            (if (setq value (plist-get source keyword))
 227                (mail-source-value value)
 228              (if (setq value (assq  keyword defaults-1))
 229                  (mail-source-value (cadr value))
 230                (mail-source-value (cadr default))))))))
 231
 232 (defmacro mail-source-bind-common (source &rest body)
 233   "Return a `let' form that binds all common variables.
 234 See `mail-source-bind'."
 235   `(let ,(mail-source-bind-common-1)
 236      (mail-source-set-common-1 source)
 237      ,@body))
 238
 239 (put 'mail-source-bind-common 'lisp-indent-function 1)
 240 (put 'mail-source-bind-common 'edebug-form-spec '(form body))
 241
 242 (defun mail-source-value (value)
 243   "Return the value of VALUE."
 244   (cond
 245    ;; String
 246    ((stringp value)
 247     value)
 248    ;; Function
 249    ((and (listp value)
 250          (functionp (car value)))
 251     (eval value))
 252    ;; Just return the value.
 253    (t
 254     value)))
 255
 256 (defun mail-source-fetch (source callback)
 257   "Fetch mail from SOURCE and call CALLBACK zero or more times.
 258 CALLBACK will be called with the name of the file where (some of)
 259 the mail from SOURCE is put.
 260 Return the number of files that were found."
 261   (mail-source-bind-common source
 262     (if (or mail-source-plugged plugged)
 263         (save-excursion
 264           (let ((function (cadr (assq (car source) mail-source-fetcher-alist)))
 265                 (found 0))
 266             (unless function
 267               (error "%S is an invalid mail source specification" source))
 268             ;; If there's anything in the crash box, we do it first.
 269             (when (file-exists-p mail-source-crash-box)
 270               (message "Processing mail from %s..." mail-source-crash-box)
 271               (setq found (mail-source-callback
 272                            callback mail-source-crash-box)))
 273             (+ found
 274                (condition-case err
 275                    (funcall function source callback)
 276                  (error
 277                   (unless (yes-or-no-p
 278                            (format "Mail source error (%s).  Continue? " err))
 279                     (error "Cannot get new mail."))
 280                   0))))))))
 281
 282 (defun mail-source-make-complex-temp-name (prefix)
 283   (let ((newname (make-temp-name prefix))
 284         (newprefix prefix))
 285     (while (file-exists-p newname)
 286       (setq newprefix (concat newprefix "x"))
 287       (setq newname (make-temp-name newprefix)))
 288     newname))
 289
 290 (defun mail-source-callback (callback info)
 291   "Call CALLBACK on the mail file, and then remove the mail file.
 292 Pass INFO on to CALLBACK."
 293   (if (or (not (file-exists-p mail-source-crash-box))
 294           (zerop (nth 7 (file-attributes mail-source-crash-box))))
 295       (progn
 296         (when (file-exists-p mail-source-crash-box)
 297           (delete-file mail-source-crash-box))
 298         0)
 299     (prog1
 300         (funcall callback mail-source-crash-box info)
 301       (when (file-exists-p mail-source-crash-box)
 302         ;; Delete or move the incoming mail out of the way.
 303         (if mail-source-delete-incoming
 304             (delete-file mail-source-crash-box)
 305           (let ((incoming
 306                  (mail-source-make-complex-temp-name
 307                   (expand-file-name
 308                    mail-source-incoming-file-prefix
 309                    mail-source-directory))))
 310             (unless (file-exists-p (file-name-directory incoming))
 311               (make-directory (file-name-directory incoming) t))
 312             (rename-file mail-source-crash-box incoming t)))))))
 313
 314 (defun mail-source-movemail (from to)
 315   "Move FROM to TO using movemail."
 316   (if (not (file-writable-p to))
 317       (error "Can't write to crash box %s.  Not moving mail" to)
 318     (let ((to (file-truename (expand-file-name to)))
 319           errors result)
 320       (setq to (file-truename to)
 321             from (file-truename from))
 322       ;; Set TO if have not already done so, and rename or copy
 323       ;; the file FROM to TO if and as appropriate.
 324       (cond
 325        ((file-exists-p to)
 326         ;; The crash box exists already.
 327         t)
 328        ((not (file-exists-p from))
 329         ;; There is no inbox.
 330         (setq to nil))
 331        ((zerop (nth 7 (file-attributes from)))
 332         ;; Empty file.
 333         (setq to nil))
 334        (t
 335         ;; If getting from mail spool directory, use movemail to move
 336         ;; rather than just renaming, so as to interlock with the
 337         ;; mailer.
 338         (unwind-protect
 339             (save-excursion
 340               (setq errors (generate-new-buffer " *mail source loss*"))
 341               (let ((default-directory "/"))
 342                 (setq result
 343                       (apply
 344                        'call-process
 345                        (append
 346                         (list
 347                          (expand-file-name "movemail" exec-directory)
 348                          nil errors nil from to)))))
 349               (when (file-exists-p to)
 350                 (set-file-modes to mail-source-default-file-modes))
 351               (if (and (not (buffer-modified-p errors))
 352                        (zerop result))
 353                   ;; No output => movemail won.
 354                   t
 355                 (set-buffer errors)
 356                 ;; There may be a warning about older revisions.  We
 357                 ;; ignore that.
 358                 (goto-char (point-min))
 359                 (if (search-forward "older revision" nil t)
 360                     t
 361                   ;; Probably a real error.
 362                   (subst-char-in-region (point-min) (point-max) ?\n ?\  )
 363                   (goto-char (point-max))
 364                   (skip-chars-backward " \t")
 365                   (delete-region (point) (point-max))
 366                   (goto-char (point-min))
 367                   (when (looking-at "movemail: ")
 368                     (delete-region (point-min) (match-end 0)))
 369                   (unless (yes-or-no-p
 370                            (format "movemail: %s (%d return).  Continue? "
 371                                    (buffer-string) result))
 372                     (error "%s" (buffer-string)))
 373                   (setq to nil)))))))
 374       (when (and errors
 375                  (buffer-name errors))
 376         (kill-buffer errors))
 377       ;; Return whether we moved successfully or not.
 378       to)))
 379
 380 (defun mail-source-movemail-and-remove (from to)
 381   "Move FROM to TO using movemail, then remove FROM if empty."
 382   (or (not (mail-source-movemail from to))
 383       (not (zerop (nth 7 (file-attributes from))))
 384       (delete-file from)))
 385
 386 (defvar mail-source-read-passwd nil)
 387 (defun mail-source-read-passwd (prompt &rest args)
 388   "Read a password using PROMPT.
 389 If ARGS, PROMPT is used as an argument to `format'."
 390   (let ((prompt
 391          (if args
 392              (apply 'format prompt args)
 393            prompt)))
 394     (unless mail-source-read-passwd
 395       (if (or (fboundp 'read-passwd) (load "passwd" t))
 396           (setq mail-source-read-passwd 'read-passwd)
 397         (unless (fboundp 'ange-ftp-read-passwd)
 398           (autoload 'ange-ftp-read-passwd "ange-ftp"))
 399         (setq mail-source-read-passwd 'ange-ftp-read-passwd)))
 400     (funcall mail-source-read-passwd prompt)))
 401
 402 (defun mail-source-fetch-with-program (program)
 403   (zerop (call-process shell-file-name nil nil nil
 404                        shell-command-switch program)))
 405
 406 (defun mail-source-run-script (script spec &optional delay)
 407   (when script
 408     (if (and (symbolp script) (fboundp script))
 409         (funcall script)
 410       (mail-source-call-script
 411        (format-spec script spec))))
 412   (when delay
 413     (sleep-for delay)))
 414
 415 (defun mail-source-call-script (script)
 416   (let ((background nil))
 417     (when (string-match "& *$" script)
 418       (setq script (substring script 0 (match-beginning 0))
 419             background 0))
 420     (call-process shell-file-name nil background nil
 421                   shell-command-switch script)))
 422
 423 ;;;
 424 ;;; Different fetchers
 425 ;;;
 426
 427 (defun mail-source-fetch-file (source callback)
 428   "Fetcher for single-file sources."
 429   (mail-source-bind (file source)
 430     (mail-source-run-script
 431      prescript (format-spec-make ?t mail-source-crash-box)
 432      prescript-delay)
 433     (let ((mail-source-string (format "file:%s" path)))
 434       (if (mail-source-movemail path mail-source-crash-box)
 435           (prog1
 436               (mail-source-callback callback path)
 437             (mail-source-run-script
 438              postscript (format-spec-make ?t mail-source-crash-box)))
 439         0))))
 440
 441 (defun mail-source-fetch-directory (source callback)
 442   "Fetcher for directory sources."
 443   (mail-source-bind (directory source)
 444     (let ((found 0)
 445           (mail-source-string (format "directory:%s" path)))
 446       (dolist (file (directory-files
 447                      path t (concat (regexp-quote suffix) "$")))
 448         (when (and (file-regular-p file)
 449                    (funcall predicate file)
 450                    (mail-source-movemail file mail-source-crash-box))
 451           (incf found (mail-source-callback callback file))))
 452       found)))
 453
 454 (defun mail-source-fetch-pop (source callback)
 455   "Fetcher for single-file sources."
 456   (mail-source-bind (pop source)
 457     (mail-source-run-script
 458      prescript
 459      (format-spec-make ?p password ?t mail-source-crash-box
 460                        ?s server ?P port ?u user)
 461      prescript-delay)
 462     (let ((from (format "%s:%s:%s" server user port))
 463           (mail-source-string (format "pop:%s@%s" user server))
 464           result)
 465       (when (eq authentication 'password)
 466         (setq password
 467               (or password
 468                   (cdr (assoc from mail-source-password-cache))
 469                   (mail-source-read-passwd
 470                    (format "Password for %s at %s: " user server)))))
 471       (when server
 472         (setenv "MAILHOST" server))
 473       (setq result
 474             (cond
 475              (program
 476               (mail-source-fetch-with-program
 477                (format-spec
 478                 program
 479                 (format-spec-make ?p password ?t mail-source-crash-box
 480                                   ?s server ?P port ?u user))))
 481              (function
 482               (funcall function mail-source-crash-box))
 483              ;; The default is to use pop3.el.
 484              (t
 485               (let ((pop3-password password)
 486                     (pop3-maildrop user)
 487                     (pop3-mailhost server)
 488                     (pop3-port port)
 489                     (pop3-authentication-scheme
 490                      (if (eq authentication 'apop) 'apop 'pass))
 491                     (pop3-connection-type connection)
 492                     (pop3-leave-mail-on-server
 493                      (or leave
 494                          (and (boundp 'pop3-leave-mail-on-server)
 495                               pop3-leave-mail-on-server))))
 496                 (save-excursion (pop3-movemail mail-source-crash-box))))))
 497       (if result
 498           (progn
 499             (when (eq authentication 'password)
 500               (unless (assoc from mail-source-password-cache)
 501                 (push (cons from password) mail-source-password-cache)))
 502             (prog1
 503                 (mail-source-callback callback server)
 504               ;; Update display-time's mail flag, if relevant.
 505               (if (equal source mail-source-primary-source)
 506                   (setq mail-source-new-mail-available nil))
 507               (mail-source-run-script
 508                postscript
 509                (format-spec-make ?p password ?t mail-source-crash-box
 510                                  ?s server ?P port ?u user))))
 511         ;; We nix out the password in case the error
 512         ;; was because of a wrong password being given.
 513         (setq mail-source-password-cache
 514               (delq (assoc from mail-source-password-cache)
 515                     mail-source-password-cache))
 516         0))))
 517
 518 (defun mail-source-check-pop (source)
 519   "Check whether there is new mail."
 520   (mail-source-bind (pop source)
 521     (let ((from (format "%s:%s:%s" server user port))
 522           (mail-source-string (format "pop:%s@%s" user server))
 523           result)
 524       (when (eq authentication 'password)
 525         (setq password
 526               (or password
 527                   (cdr (assoc from mail-source-password-cache))
 528                   (mail-source-read-passwd
 529                    (format "Password for %s at %s: " user server))))
 530         (unless (assoc from mail-source-password-cache)
 531           (push (cons from password) mail-source-password-cache)))
 532       (when server
 533         (setenv "MAILHOST" server))
 534       (setq result
 535             (cond
 536              ;; No easy way to check whether mail is waiting for these.
 537              (program)
 538              (function)
 539              ;; The default is to use pop3.el.
 540              (t
 541               (let ((pop3-password password)
 542                     (pop3-maildrop user)
 543                     (pop3-mailhost server)
 544                     (pop3-port port)
 545                     (pop3-authentication-scheme
 546                      (if (eq authentication 'apop) 'apop 'pass)))
 547                 (save-excursion (pop3-get-message-count))))))
 548       (if result
 549           ;; Inform display-time that we have new mail.
 550           (setq mail-source-new-mail-available (> result 0))
 551         ;; We nix out the password in case the error
 552         ;; was because of a wrong password being given.
 553         (setq mail-source-password-cache
 554               (delq (assoc from mail-source-password-cache)
 555                     mail-source-password-cache)))
 556       result)))
 557
 558 (defun mail-source-new-mail-p ()
 559   "Handler for `display-time' to indicate when new mail is available."
 560   ;; Only report flag setting; flag is updated on a different schedule.
 561   mail-source-new-mail-available)
 562
 563
 564 (defvar mail-source-report-new-mail nil)
 565 (defvar mail-source-report-new-mail-timer nil)
 566 (defvar mail-source-report-new-mail-idle-timer nil)
 567
 568 (eval-when-compile (require 'timer))
 569
 570 (defun mail-source-start-idle-timer ()
 571   ;; Start our idle timer if necessary, so we delay the check until the
 572   ;; user isn't typing.
 573   (unless mail-source-report-new-mail-idle-timer
 574     (setq mail-source-report-new-mail-idle-timer
 575           (run-with-idle-timer
 576            mail-source-idle-time-delay
 577            nil
 578            (lambda ()
 579              (setq mail-source-report-new-mail-idle-timer nil)
 580              (mail-source-check-pop mail-source-primary-source))))
 581     ;; Since idle timers created when Emacs is already in the idle
 582     ;; state don't get activated until Emacs _next_ becomes idle, we
 583     ;; need to force our timer to be considered active now.  We do
 584     ;; this by being naughty and poking the timer internals directly
 585     ;; (element 0 of the vector is nil if the timer is active).
 586     (aset mail-source-report-new-mail-idle-timer 0 nil)))
 587
 588 (defun mail-source-report-new-mail (arg)
 589   "Toggle whether to report when new mail is available.
 590 This only works when `display-time' is enabled."
 591   (interactive "P")
 592   (if (not mail-source-primary-source)
 593       (error "Need to set `mail-source-primary-source' to check for new mail."))
 594   (let ((on (if (null arg)
 595                 (not mail-source-report-new-mail)
 596               (> (prefix-numeric-value arg) 0))))
 597     (setq mail-source-report-new-mail on)
 598     (and mail-source-report-new-mail-timer
 599          (cancel-timer mail-source-report-new-mail-timer))
 600     (and mail-source-report-new-mail-idle-timer
 601          (cancel-timer mail-source-report-new-mail-idle-timer))
 602     (setq mail-source-report-new-mail-timer nil)
 603     (setq mail-source-report-new-mail-idle-timer nil)
 604     (if on
 605         (progn
 606           (require 'time)
 607           (setq display-time-mail-function #'mail-source-new-mail-p)
 608           ;; Set up the main timer.
 609           (setq mail-source-report-new-mail-timer
 610                 (run-at-time t (* 60 mail-source-report-new-mail-interval)
 611                              #'mail-source-start-idle-timer))
 612           ;; When you get new mail, clear "Mail" from the mode line.
 613           (add-hook 'nnmail-post-get-new-mail-hook
 614                     'display-time-event-handler)
 615           (message "Mail check enabled"))
 616       (setq display-time-mail-function nil)
 617       (remove-hook 'nnmail-post-get-new-mail-hook
 618                    'display-time-event-handler)
 619       (message "Mail check disabled"))))
 620
 621 (defun mail-source-fetch-maildir (source callback)
 622   "Fetcher for maildir sources."
 623   (mail-source-bind (maildir source)
 624     (let ((found 0)
 625           mail-source-string)
 626       (unless (string-match "/$" path)
 627         (setq path (concat path "/")))
 628       (dolist (subdir subdirs)
 629         (when (file-directory-p (concat path subdir))
 630           (setq mail-source-string (format "maildir:%s%s" path subdir))
 631           (dolist (file (directory-files (concat path subdir) t))
 632             (when (and (not (file-directory-p file))
 633                        (not (if function
 634                                 (funcall function file mail-source-crash-box)
 635                               (let ((coding-system-for-write
 636                                      nnheader-text-coding-system)
 637                                     (coding-system-for-read
 638                                      nnheader-text-coding-system)
 639                                     (output-coding-system
 640                                      nnheader-text-coding-system)
 641                                     (input-coding-system
 642                                      nnheader-text-coding-system))
 643                                 (with-temp-file mail-source-crash-box
 644                                   (insert-file-contents file)
 645                                   (goto-char (point-min))
 646 ;;;                               ;; Unix mail format
 647 ;;;                               (unless (looking-at "\n*From ")
 648 ;;;                                 (insert "From maildir "
 649 ;;;                                         (current-time-string) "\n"))
 650 ;;;                               (while (re-search-forward "^From " nil t)
 651 ;;;                                 (replace-match ">From "))
 652                                   ;; MMDF mail format
 653                                   (insert "\001\001\001\001\n")
 654                                   (goto-char (point-max))
 655                                   (insert "\n\n"))
 656                                 (delete-file file)))))
 657               (incf found (mail-source-callback callback file))))))
 658       found)))
 659
 660 (eval-and-compile
 661   (autoload 'imap-open "imap")
 662   (autoload 'imap-authenticate "imap")
 663   (autoload 'imap-mailbox-select "imap")
 664   (autoload 'imap-mailbox-unselect "imap")
 665   (autoload 'imap-mailbox-close "imap")
 666   (autoload 'imap-search "imap")
 667   (autoload 'imap-fetch "imap")
 668   (autoload 'imap-close "imap")
 669   (autoload 'imap-error-text "imap")
 670   (autoload 'imap-message-flags-add "imap")
 671   (autoload 'imap-list-to-message-set "imap"))
 672
 673 (defun mail-source-fetch-imap (source callback)
 674   "Fetcher for imap sources."
 675   (mail-source-bind (imap source)
 676     (let ((from (format "%s:%s:%s" server user port))
 677           (found 0)
 678           (buf (get-buffer-create
 679                 (format " *imap source %s:%s:%s *" server user mailbox)))
 680           (mail-source-string (format "imap:%s:%s" server mailbox))
 681           remove)
 682       (if (and (imap-open server port stream authentication buf)
 683                (imap-authenticate
 684                 user (or (cdr (assoc from mail-source-password-cache))
 685                          password) buf)
 686                (imap-mailbox-select mailbox nil buf))
 687           (let (str
 688                 (coding-system-for-write 'binary)
 689                 (output-coding-system 'binary))
 690             (with-temp-file mail-source-crash-box
 691               ;; remember password
 692               (with-current-buffer buf
 693                 (when (or imap-password
 694                           (assoc from mail-source-password-cache))
 695                   (push (cons from imap-password) mail-source-password-cache)))
 696               ;; if predicate is nil, use all uids
 697               (dolist (uid (imap-search (or predicate "1:*") buf))
 698                 (when (setq str (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf))
 699                   (push uid remove)
 700                   (insert "From imap " (current-time-string) "\n")
 701                   (save-excursion
 702                     (insert str "\n\n"))
 703                   (while (re-search-forward "^From " nil t)
 704                     (replace-match ">From "))
 705                   (goto-char (point-max))))
 706               (nnheader-ms-strip-cr))
 707             (incf found (mail-source-callback callback server))
 708             (when (and remove fetchflag)
 709               (imap-message-flags-add
 710                (imap-list-to-message-set remove) fetchflag nil buf))
 711             (if dontexpunge
 712                 (imap-mailbox-unselect buf)
 713               (imap-mailbox-close buf))
 714             (imap-close buf))
 715         (imap-close buf)
 716         ;; We nix out the password in case the error
 717         ;; was because of a wrong password being given.
 718         (setq mail-source-password-cache
 719               (delq (assoc from mail-source-password-cache)
 720                     mail-source-password-cache))
 721         (error (imap-error-text buf)))
 722       (kill-buffer buf)
 723       found)))
 724
 725 (eval-and-compile
 726   (autoload 'webmail-fetch "webmail"))
 727
 728 (defun mail-source-fetch-webmail (source callback)
 729   "Fetch for webmail source."
 730   (mail-source-bind (webmail source)
 731     (let ((mail-source-string (format "webmail:%s:%s" subtype user))
 732           (webmail-newmail-only dontexpunge)
 733           (webmail-move-to-trash-can (not dontexpunge)))
 734       (when (eq authentication 'password)
 735         (setq password
 736               (or password
 737                   (cdr (assoc (format "webmail:%s:%s" subtype user)
 738                               mail-source-password-cache))
 739                   (mail-source-read-passwd
 740                    (format "Password for %s at %s: " user subtype))))
 741         (when (and password
 742                    (not (assoc (format "webmail:%s:%s" subtype user)
 743                                mail-source-password-cache)))
 744           (push (cons (format "webmail:%s:%s" subtype user) password)
 745                 mail-source-password-cache)))
 746       (webmail-fetch mail-source-crash-box subtype user password)
 747       (mail-source-callback callback (symbol-name subtype)))))
 748
 749 (provide 'mail-source)
 750
 751 ;;; mail-source.el ends here