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