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