1 |
;;; mail-source.el --- functions for fetching mail |
;;; mail-source.el --- functions for fetching mail |
2 |
;; Copyright (C) 1999, 2000, 2001, 2002 Free Software Foundation, Inc. |
;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004 |
3 |
|
;; Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
6 |
;; Keywords: news, mail |
;; Keywords: news, mail |
33 |
(eval-and-compile |
(eval-and-compile |
34 |
(autoload 'pop3-movemail "pop3") |
(autoload 'pop3-movemail "pop3") |
35 |
(autoload 'pop3-get-message-count "pop3") |
(autoload 'pop3-get-message-count "pop3") |
36 |
(autoload 'nnheader-cancel-timer "nnheader")) |
(autoload 'nnheader-cancel-timer "nnheader") |
37 |
|
(autoload 'nnheader-run-at-time "nnheader")) |
38 |
(require 'format-spec) |
(require 'format-spec) |
39 |
(require 'mm-util) |
(require 'mm-util) |
40 |
|
(require 'message) ;; for `message-directory' |
41 |
|
|
42 |
(defgroup mail-source nil |
(defgroup mail-source nil |
43 |
"The mail-fetching library." |
"The mail-fetching library." |
61 |
This variable is a list of mail source specifiers. |
This variable is a list of mail source specifiers. |
62 |
See Info node `(gnus)Mail Source Specifiers'." |
See Info node `(gnus)Mail Source Specifiers'." |
63 |
:group 'mail-source |
:group 'mail-source |
64 |
|
:link '(custom-manual "(gnus)Mail Source Specifiers") |
65 |
:type `(repeat |
:type `(repeat |
66 |
(choice :format "%[Value Menu%] %v" |
(choice :format "%[Value Menu%] %v" |
67 |
:value (file) |
:value (file) |
85 |
(function :tag "Predicate")) |
(function :tag "Predicate")) |
86 |
(group :inline t |
(group :inline t |
87 |
(const :format "" :value :prescript) |
(const :format "" :value :prescript) |
88 |
(string :tag "Prescript")) |
(choice :tag "Prescript" |
89 |
|
:value nil |
90 |
|
(string :format "%v") |
91 |
|
(function :format "%v"))) |
92 |
(group :inline t |
(group :inline t |
93 |
(const :format "" :value :postscript) |
(const :format "" :value :postscript) |
94 |
(string :tag "Postscript")) |
(choice :tag "Postscript" |
95 |
|
:value nil |
96 |
|
(string :format "%v") |
97 |
|
(function :format "%v"))) |
98 |
(group :inline t |
(group :inline t |
99 |
(const :format "" :value :plugged) |
(const :format "" :value :plugged) |
100 |
(boolean :tag "Plugged")))) |
(boolean :tag "Plugged")))) |
121 |
(string :tag "Program")) |
(string :tag "Program")) |
122 |
(group :inline t |
(group :inline t |
123 |
(const :format "" :value :prescript) |
(const :format "" :value :prescript) |
124 |
(string :tag "Prescript")) |
(choice :tag "Prescript" |
125 |
|
:value nil |
126 |
|
(string :format "%v") |
127 |
|
(function :format "%v"))) |
128 |
(group :inline t |
(group :inline t |
129 |
(const :format "" :value :postscript) |
(const :format "" :value :postscript) |
130 |
(string :tag "Postscript")) |
(choice :tag "Postscript" |
131 |
|
:value nil |
132 |
|
(string :format "%v") |
133 |
|
(function :format "%v"))) |
134 |
(group :inline t |
(group :inline t |
135 |
(const :format "" :value :function) |
(const :format "" :value :function) |
136 |
(function :tag "Function")) |
(function :tag "Function")) |
176 |
:value network |
:value network |
177 |
,@mail-source-imap-streams)) |
,@mail-source-imap-streams)) |
178 |
(group :inline t |
(group :inline t |
179 |
|
(const :format "" :value :program) |
180 |
|
(string :tag "Program")) |
181 |
|
(group :inline t |
182 |
(const :format "" |
(const :format "" |
183 |
:value :authenticator) |
:value :authenticator) |
184 |
(choice :tag "Authenticator" |
(choice :tag "Authenticator" |
232 |
(const :format "" :value :plugged) |
(const :format "" :value :plugged) |
233 |
(boolean :tag "Plugged"))))))) |
(boolean :tag "Plugged"))))))) |
234 |
|
|
235 |
|
(defcustom mail-source-ignore-errors nil |
236 |
|
"*Ignore errors when querying mail sources. |
237 |
|
If nil, the user will be prompted when an error occurs. If non-nil, |
238 |
|
the error will be ignored.") |
239 |
|
|
240 |
(defcustom mail-source-primary-source nil |
(defcustom mail-source-primary-source nil |
241 |
"*Primary source for incoming mail. |
"*Primary source for incoming mail. |
242 |
If non-nil, this maildrop will be checked periodically for new mail." |
If non-nil, this maildrop will be checked periodically for new mail." |
243 |
:group 'mail-source |
:group 'mail-source |
244 |
:type 'sexp) |
:type 'sexp) |
245 |
|
|
246 |
|
(defcustom mail-source-flash t |
247 |
|
"*If non-nil, flash periodically when mail is available." |
248 |
|
:group 'mail-source |
249 |
|
:type 'boolean) |
250 |
|
|
251 |
(defcustom mail-source-crash-box "~/.emacs-mail-crash-box" |
(defcustom mail-source-crash-box "~/.emacs-mail-crash-box" |
252 |
"File where mail will be stored while processing it." |
"File where mail will be stored while processing it." |
253 |
:group 'mail-source |
:group 'mail-source |
254 |
:type 'file) |
:type 'file) |
255 |
|
|
256 |
(defcustom mail-source-directory "~/Mail/" |
(defcustom mail-source-directory message-directory |
257 |
"Directory where files (if any) will be stored." |
"Directory where files (if any) will be stored." |
258 |
:group 'mail-source |
:group 'mail-source |
259 |
:type 'directory) |
:type 'directory) |
264 |
:type 'integer) |
:type 'integer) |
265 |
|
|
266 |
(defcustom mail-source-delete-incoming t |
(defcustom mail-source-delete-incoming t |
267 |
"*If non-nil, delete incoming files after handling." |
"*If non-nil, delete incoming files after handling. |
268 |
|
If t, delete immediately, if nil, never delete. If a positive number, delete |
269 |
|
files older than number of days." |
270 |
|
;; Note: The removing happens in `mail-source-callback', i.e. no old |
271 |
|
;; incoming files will be deleted, unless you receive new mail. |
272 |
|
;; |
273 |
|
;; You may also set this to `nil' and call `mail-source-delete-old-incoming' |
274 |
|
;; from a hook or interactively. |
275 |
|
:group 'mail-source |
276 |
|
:type '(choice (const :tag "immediately" t) |
277 |
|
(const :tag "never" nil) |
278 |
|
(integer :tag "days"))) |
279 |
|
|
280 |
|
(defcustom mail-source-delete-old-incoming-confirm t |
281 |
|
"*If non-nil, ask for for confirmation before deleting old incoming files. |
282 |
|
This variable only applies when `mail-source-delete-incoming' is a positive |
283 |
|
number." |
284 |
:group 'mail-source |
:group 'mail-source |
285 |
:type 'boolean) |
:type 'boolean) |
286 |
|
|
299 |
:group 'mail-source |
:group 'mail-source |
300 |
:type 'number) |
:type 'number) |
301 |
|
|
302 |
|
(defcustom mail-source-movemail-program nil |
303 |
|
"If non-nil, name of program for fetching new mail." |
304 |
|
:group 'mail-source |
305 |
|
:type '(choice (const nil) string)) |
306 |
|
|
307 |
;;; Internal variables. |
;;; Internal variables. |
308 |
|
|
309 |
(defvar mail-source-string "" |
(defvar mail-source-string "" |
345 |
(:authentication password)) |
(:authentication password)) |
346 |
(maildir |
(maildir |
347 |
(:path (or (getenv "MAILDIR") "~/Maildir/")) |
(:path (or (getenv "MAILDIR") "~/Maildir/")) |
348 |
(:subdirs ("new" "cur")) |
(:subdirs ("cur" "new")) |
349 |
(:function)) |
(:function)) |
350 |
(imap |
(imap |
351 |
(:server (getenv "MAILHOST")) |
(:server (getenv "MAILHOST")) |
352 |
(:port) |
(:port) |
353 |
(:stream) |
(:stream) |
354 |
|
(:program) |
355 |
(:authentication) |
(:authentication) |
356 |
(:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER"))) |
(:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER"))) |
357 |
(:password) |
(:password) |
358 |
(:mailbox "INBOX") |
(:mailbox "INBOX") |
359 |
(:predicate "UNSEEN UNDELETED") |
(:predicate "UNSEEN UNDELETED") |
360 |
(:fetchflag "\\Deleted") |
(:fetchflag "\\Deleted") |
361 |
|
(:prescript) |
362 |
|
(:prescript-delay) |
363 |
|
(:postscript) |
364 |
(:dontexpunge)) |
(:dontexpunge)) |
365 |
(webmail |
(webmail |
366 |
(:subtype hotmail) |
(:subtype hotmail) |
419 |
,@body)) |
,@body)) |
420 |
|
|
421 |
(put 'mail-source-bind 'lisp-indent-function 1) |
(put 'mail-source-bind 'lisp-indent-function 1) |
422 |
(put 'mail-source-bind 'edebug-form-spec '(form body)) |
(put 'mail-source-bind 'edebug-form-spec '(sexp body)) |
423 |
|
|
424 |
(defun mail-source-set-1 (source) |
(defun mail-source-set-1 (source) |
425 |
(let* ((type (pop source)) |
(let* ((type (pop source)) |
462 |
,@body)) |
,@body)) |
463 |
|
|
464 |
(put 'mail-source-bind-common 'lisp-indent-function 1) |
(put 'mail-source-bind-common 'lisp-indent-function 1) |
465 |
(put 'mail-source-bind-common 'edebug-form-spec '(form body)) |
(put 'mail-source-bind-common 'edebug-form-spec '(sexp body)) |
466 |
|
|
467 |
(defun mail-source-value (value) |
(defun mail-source-value (value) |
468 |
"Return the value of VALUE." |
"Return the value of VALUE." |
496 |
(setq found (mail-source-callback |
(setq found (mail-source-callback |
497 |
callback mail-source-crash-box))) |
callback mail-source-crash-box))) |
498 |
(+ found |
(+ found |
499 |
(condition-case err |
(if (or debug-on-quit debug-on-error) |
500 |
(funcall function source callback) |
(funcall function source callback) |
501 |
(error |
(condition-case err |
502 |
(unless (yes-or-no-p |
(funcall function source callback) |
503 |
(format "Mail source error (%s). Continue? " err)) |
(error |
504 |
(error "Cannot get new mail")) |
(if (and (not mail-source-ignore-errors) |
505 |
0)))))))) |
(not |
506 |
|
(yes-or-no-p |
507 |
(eval-and-compile |
(format "Mail source %s error (%s). Continue? " |
508 |
(if (fboundp 'make-temp-file) |
(if (memq ':password source) |
509 |
(defalias 'mail-source-make-complex-temp-name 'make-temp-file) |
(let ((s (copy-sequence source))) |
510 |
(defun mail-source-make-complex-temp-name (prefix) |
(setcar (cdr (memq ':password s)) |
511 |
(let ((newname (make-temp-name prefix)) |
"********") |
512 |
(newprefix prefix)) |
s) |
513 |
(while (file-exists-p newname) |
source) |
514 |
(setq newprefix (concat newprefix "x")) |
(cadr err))))) |
515 |
(setq newname (make-temp-name newprefix))) |
(error "Cannot get new mail")) |
516 |
newname)))) |
0))))))))) |
517 |
|
|
518 |
|
(defun mail-source-delete-old-incoming (&optional age confirm) |
519 |
|
"Remove incoming files older than AGE days. |
520 |
|
If CONFIRM is non-nil, ask for confirmation before removing a file." |
521 |
|
(interactive "P") |
522 |
|
(let* ((high2days (/ 65536.0 60 60 24));; convert high bits to days |
523 |
|
(low2days (/ 1.0 65536.0)) ;; convert low bits to days |
524 |
|
(diff (if (natnump age) age 30));; fallback, if no valid AGE given |
525 |
|
currday files) |
526 |
|
(setq files (directory-files |
527 |
|
mail-source-directory t |
528 |
|
(concat mail-source-incoming-file-prefix "*")) |
529 |
|
currday (* (car (current-time)) high2days) |
530 |
|
currday (+ currday (* low2days (nth 1 (current-time))))) |
531 |
|
(while files |
532 |
|
(let* ((ffile (car files)) |
533 |
|
(bfile (gnus-replace-in-string |
534 |
|
ffile "\\`.*/\\([^/]+\\)\\'" "\\1")) |
535 |
|
(filetime (nth 5 (file-attributes ffile))) |
536 |
|
(fileday (* (car filetime) high2days)) |
537 |
|
(fileday (+ fileday (* low2days (nth 1 filetime))))) |
538 |
|
(setq files (cdr files)) |
539 |
|
(when (and (> (- currday fileday) diff) |
540 |
|
(gnus-message 8 "File `%s' is older than %s day(s)" |
541 |
|
bfile diff) |
542 |
|
(or (not confirm) |
543 |
|
(y-or-n-p (concat "Remove file `" bfile "'? ")))) |
544 |
|
(delete-file ffile)))))) |
545 |
|
|
546 |
(defun mail-source-callback (callback info) |
(defun mail-source-callback (callback info) |
547 |
"Call CALLBACK on the mail file, and then remove the mail file. |
"Call CALLBACK on the mail file, and then remove the mail file. |
556 |
(funcall callback mail-source-crash-box info) |
(funcall callback mail-source-crash-box info) |
557 |
(when (file-exists-p mail-source-crash-box) |
(when (file-exists-p mail-source-crash-box) |
558 |
;; Delete or move the incoming mail out of the way. |
;; Delete or move the incoming mail out of the way. |
559 |
(if mail-source-delete-incoming |
(if (eq mail-source-delete-incoming t) |
560 |
(delete-file mail-source-crash-box) |
(delete-file mail-source-crash-box) |
561 |
(let ((incoming |
(let ((incoming |
562 |
(mail-source-make-complex-temp-name |
(mm-make-temp-file |
563 |
(expand-file-name |
(expand-file-name |
564 |
mail-source-incoming-file-prefix |
mail-source-incoming-file-prefix |
565 |
mail-source-directory)))) |
mail-source-directory)))) |
566 |
(unless (file-exists-p (file-name-directory incoming)) |
(unless (file-exists-p (file-name-directory incoming)) |
567 |
(make-directory (file-name-directory incoming) t)) |
(make-directory (file-name-directory incoming) t)) |
568 |
(rename-file mail-source-crash-box incoming t))))))) |
(rename-file mail-source-crash-box incoming t) |
569 |
|
;; remove old incoming files? |
570 |
|
(when (natnump mail-source-delete-incoming) |
571 |
|
(mail-source-delete-old-incoming |
572 |
|
mail-source-delete-incoming |
573 |
|
mail-source-delete-old-incoming-confirm)))))))) |
574 |
|
|
575 |
(defun mail-source-movemail (from to) |
(defun mail-source-movemail (from to) |
576 |
"Move FROM to TO using movemail." |
"Move FROM to TO using movemail." |
605 |
'call-process |
'call-process |
606 |
(append |
(append |
607 |
(list |
(list |
608 |
(expand-file-name "movemail" exec-directory) |
(or mail-source-movemail-program |
609 |
|
(expand-file-name "movemail" exec-directory)) |
610 |
nil errors nil from to))))) |
nil errors nil from to))))) |
611 |
(when (file-exists-p to) |
(when (file-exists-p to) |
612 |
(set-file-modes to mail-source-default-file-modes)) |
(set-file-modes to mail-source-default-file-modes)) |
613 |
(if (and (not (buffer-modified-p errors)) |
(if (and (or (not (buffer-modified-p errors)) |
614 |
(zerop result)) |
(zerop (buffer-size errors))) |
615 |
|
(and (numberp result) |
616 |
|
(zerop result))) |
617 |
;; No output => movemail won. |
;; No output => movemail won. |
618 |
t |
t |
619 |
(set-buffer errors) |
(set-buffer errors) |
630 |
(goto-char (point-min)) |
(goto-char (point-min)) |
631 |
(when (looking-at "movemail: ") |
(when (looking-at "movemail: ") |
632 |
(delete-region (point-min) (match-end 0))) |
(delete-region (point-min) (match-end 0))) |
633 |
|
;; Result may be a signal description string. |
634 |
(unless (yes-or-no-p |
(unless (yes-or-no-p |
635 |
(format "movemail: %s (%d return). Continue? " |
(format "movemail: %s (%s return). Continue? " |
636 |
(buffer-string) result)) |
(buffer-string) result)) |
637 |
(error "%s" (buffer-string))) |
(error "%s" (buffer-string))) |
638 |
(setq to nil))))))) |
(setq to nil))))))) |
648 |
(not (zerop (nth 7 (file-attributes from)))) |
(not (zerop (nth 7 (file-attributes from)))) |
649 |
(delete-file from))) |
(delete-file from))) |
650 |
|
|
|
(defvar mail-source-read-passwd nil) |
|
|
(defun mail-source-read-passwd (prompt &rest args) |
|
|
"Read a password using PROMPT. |
|
|
If ARGS, PROMPT is used as an argument to `format'." |
|
|
(let ((prompt |
|
|
(if args |
|
|
(apply 'format prompt args) |
|
|
prompt))) |
|
|
(unless mail-source-read-passwd |
|
|
(if (or (fboundp 'read-passwd) (load "passwd" t)) |
|
|
(setq mail-source-read-passwd 'read-passwd) |
|
|
(unless (fboundp 'ange-ftp-read-passwd) |
|
|
(autoload 'ange-ftp-read-passwd "ange-ftp")) |
|
|
(setq mail-source-read-passwd 'ange-ftp-read-passwd))) |
|
|
(funcall mail-source-read-passwd prompt))) |
|
|
|
|
651 |
(defun mail-source-fetch-with-program (program) |
(defun mail-source-fetch-with-program (program) |
652 |
(zerop (call-process shell-file-name nil nil nil |
(eq 0 (call-process shell-file-name nil nil nil |
653 |
shell-command-switch program))) |
shell-command-switch program))) |
654 |
|
|
655 |
(defun mail-source-run-script (script spec &optional delay) |
(defun mail-source-run-script (script spec &optional delay) |
656 |
(when script |
(when script |
657 |
(if (and (symbolp script) (fboundp script)) |
(if (functionp script) |
658 |
(funcall script) |
(funcall script) |
659 |
(mail-source-call-script |
(mail-source-call-script |
660 |
(format-spec script spec)))) |
(format-spec script spec)))) |
691 |
"Fetcher for directory sources." |
"Fetcher for directory sources." |
692 |
(mail-source-bind (directory source) |
(mail-source-bind (directory source) |
693 |
(mail-source-run-script |
(mail-source-run-script |
694 |
prescript (format-spec-make ?t path) |
prescript (format-spec-make ?t path) prescript-delay) |
|
prescript-delay) |
|
695 |
(let ((found 0) |
(let ((found 0) |
696 |
(mail-source-string (format "directory:%s" path))) |
(mail-source-string (format "directory:%s" path))) |
697 |
(dolist (file (directory-files |
(dolist (file (directory-files |
700 |
(funcall predicate file) |
(funcall predicate file) |
701 |
(mail-source-movemail file mail-source-crash-box)) |
(mail-source-movemail file mail-source-crash-box)) |
702 |
(incf found (mail-source-callback callback file)))) |
(incf found (mail-source-callback callback file)))) |
703 |
(mail-source-run-script |
(mail-source-run-script postscript (format-spec-make ?t path)) |
|
postscript (format-spec-make ?t path)) |
|
704 |
found))) |
found))) |
705 |
|
|
706 |
(defun mail-source-fetch-pop (source callback) |
(defun mail-source-fetch-pop (source callback) |
718 |
(setq password |
(setq password |
719 |
(or password |
(or password |
720 |
(cdr (assoc from mail-source-password-cache)) |
(cdr (assoc from mail-source-password-cache)) |
721 |
(mail-source-read-passwd |
(read-passwd |
722 |
(format "Password for %s at %s: " user server))))) |
(format "Password for %s at %s: " user server))))) |
723 |
(when server |
(when server |
724 |
(setenv "MAILHOST" server)) |
(setenv "MAILHOST" server)) |
740 |
(pop3-port port) |
(pop3-port port) |
741 |
(pop3-authentication-scheme |
(pop3-authentication-scheme |
742 |
(if (eq authentication 'apop) 'apop 'pass))) |
(if (eq authentication 'apop) 'apop 'pass))) |
743 |
(save-excursion (pop3-movemail mail-source-crash-box)))))) |
(if (or debug-on-quit debug-on-error) |
744 |
|
(save-excursion (pop3-movemail mail-source-crash-box)) |
745 |
|
(condition-case err |
746 |
|
(save-excursion (pop3-movemail mail-source-crash-box)) |
747 |
|
(error |
748 |
|
;; We nix out the password in case the error |
749 |
|
;; was because of a wrong password being given. |
750 |
|
(setq mail-source-password-cache |
751 |
|
(delq (assoc from mail-source-password-cache) |
752 |
|
mail-source-password-cache)) |
753 |
|
(signal (car err) (cdr err))))))))) |
754 |
(if result |
(if result |
755 |
(progn |
(progn |
756 |
(when (eq authentication 'password) |
(when (eq authentication 'password) |
782 |
(setq password |
(setq password |
783 |
(or password |
(or password |
784 |
(cdr (assoc from mail-source-password-cache)) |
(cdr (assoc from mail-source-password-cache)) |
785 |
(mail-source-read-passwd |
(read-passwd |
786 |
(format "Password for %s at %s: " user server)))) |
(format "Password for %s at %s: " user server)))) |
787 |
(unless (assoc from mail-source-password-cache) |
(unless (assoc from mail-source-password-cache) |
788 |
(push (cons from password) mail-source-password-cache))) |
(push (cons from password) mail-source-password-cache))) |
801 |
(pop3-port port) |
(pop3-port port) |
802 |
(pop3-authentication-scheme |
(pop3-authentication-scheme |
803 |
(if (eq authentication 'apop) 'apop 'pass))) |
(if (eq authentication 'apop) 'apop 'pass))) |
804 |
(save-excursion (pop3-get-message-count)))))) |
(if (or debug-on-quit debug-on-error) |
805 |
|
(save-excursion (pop3-get-message-count)) |
806 |
|
(condition-case err |
807 |
|
(save-excursion (pop3-get-message-count)) |
808 |
|
(error |
809 |
|
;; We nix out the password in case the error |
810 |
|
;; was because of a wrong password being given. |
811 |
|
(setq mail-source-password-cache |
812 |
|
(delq (assoc from mail-source-password-cache) |
813 |
|
mail-source-password-cache)) |
814 |
|
(signal (car err) (cdr err))))))))) |
815 |
(if result |
(if result |
816 |
;; Inform display-time that we have new mail. |
;; Inform display-time that we have new mail. |
817 |
(setq mail-source-new-mail-available (> result 0)) |
(setq mail-source-new-mail-available (> result 0)) |
822 |
mail-source-password-cache))) |
mail-source-password-cache))) |
823 |
result))) |
result))) |
824 |
|
|
825 |
|
(defun mail-source-touch-pop () |
826 |
|
"Open and close a POP connection shortly. |
827 |
|
POP server should be defined in `mail-source-primary-source' (which is |
828 |
|
preferred) or `mail-sources'. You may use it for the POP-before-SMTP |
829 |
|
authentication. To do that, you need to set the |
830 |
|
`message-send-mail-function' variable as `message-smtpmail-send-it' |
831 |
|
and put the following line in your ~/.gnus.el file: |
832 |
|
|
833 |
|
\(add-hook 'message-send-mail-hook 'mail-source-touch-pop) |
834 |
|
|
835 |
|
See the Gnus manual for details." |
836 |
|
(let ((sources (if mail-source-primary-source |
837 |
|
(list mail-source-primary-source) |
838 |
|
mail-sources))) |
839 |
|
(while sources |
840 |
|
(if (eq 'pop (car (car sources))) |
841 |
|
(mail-source-check-pop (car sources))) |
842 |
|
(setq sources (cdr sources))))) |
843 |
|
|
844 |
(defun mail-source-new-mail-p () |
(defun mail-source-new-mail-p () |
845 |
"Handler for `display-time' to indicate when new mail is available." |
"Handler for `display-time' to indicate when new mail is available." |
846 |
|
;; Flash (ie. ring the visible bell) if mail is available. |
847 |
|
(if (and mail-source-flash mail-source-new-mail-available) |
848 |
|
(let ((visible-bell t)) |
849 |
|
(ding))) |
850 |
;; Only report flag setting; flag is updated on a different schedule. |
;; Only report flag setting; flag is updated on a different schedule. |
851 |
mail-source-new-mail-available) |
mail-source-new-mail-available) |
852 |
|
|
869 |
mail-source-idle-time-delay |
mail-source-idle-time-delay |
870 |
nil |
nil |
871 |
(lambda () |
(lambda () |
872 |
(setq mail-source-report-new-mail-idle-timer nil) |
(unwind-protect |
873 |
(mail-source-check-pop mail-source-primary-source)))) |
(mail-source-check-pop mail-source-primary-source) |
874 |
|
(setq mail-source-report-new-mail-idle-timer nil))))) |
875 |
;; Since idle timers created when Emacs is already in the idle |
;; Since idle timers created when Emacs is already in the idle |
876 |
;; state don't get activated until Emacs _next_ becomes idle, we |
;; state don't get activated until Emacs _next_ becomes idle, we |
877 |
;; need to force our timer to be considered active now. We do |
;; need to force our timer to be considered active now. We do |
902 |
(setq display-time-mail-function #'mail-source-new-mail-p) |
(setq display-time-mail-function #'mail-source-new-mail-p) |
903 |
;; Set up the main timer. |
;; Set up the main timer. |
904 |
(setq mail-source-report-new-mail-timer |
(setq mail-source-report-new-mail-timer |
905 |
(run-at-time t (* 60 mail-source-report-new-mail-interval) |
(nnheader-run-at-time |
906 |
#'mail-source-start-idle-timer)) |
(* 60 mail-source-report-new-mail-interval) |
907 |
|
(* 60 mail-source-report-new-mail-interval) |
908 |
|
#'mail-source-start-idle-timer)) |
909 |
;; When you get new mail, clear "Mail" from the mode line. |
;; When you get new mail, clear "Mail" from the mode line. |
910 |
(add-hook 'nnmail-post-get-new-mail-hook |
(add-hook 'nnmail-post-get-new-mail-hook |
911 |
'display-time-event-handler) |
'display-time-event-handler) |
936 |
(with-temp-file mail-source-crash-box |
(with-temp-file mail-source-crash-box |
937 |
(insert-file-contents file) |
(insert-file-contents file) |
938 |
(goto-char (point-min)) |
(goto-char (point-min)) |
939 |
;;; ;; Unix mail format |
;;; ;; Unix mail format |
940 |
;;; (unless (looking-at "\n*From ") |
;;; (unless (looking-at "\n*From ") |
941 |
;;; (insert "From maildir " |
;;; (insert "From maildir " |
942 |
;;; (current-time-string) "\n")) |
;;; (current-time-string) "\n")) |
943 |
;;; (while (re-search-forward "^From " nil t) |
;;; (while (re-search-forward "^From " nil t) |
944 |
;;; (replace-match ">From ")) |
;;; (replace-match ">From ")) |
945 |
;;; (goto-char (point-max)) |
;;; (goto-char (point-max)) |
946 |
;;; (insert "\n\n") |
;;; (insert "\n\n") |
947 |
;; MMDF mail format |
;; MMDF mail format |
948 |
(insert "\001\001\001\001\n")) |
(insert "\001\001\001\001\n")) |
971 |
(defun mail-source-fetch-imap (source callback) |
(defun mail-source-fetch-imap (source callback) |
972 |
"Fetcher for imap sources." |
"Fetcher for imap sources." |
973 |
(mail-source-bind (imap source) |
(mail-source-bind (imap source) |
974 |
|
(mail-source-run-script |
975 |
|
prescript (format-spec-make ?p password ?t mail-source-crash-box |
976 |
|
?s server ?P port ?u user) |
977 |
|
prescript-delay) |
978 |
(let ((from (format "%s:%s:%s" server user port)) |
(let ((from (format "%s:%s:%s" server user port)) |
979 |
(found 0) |
(found 0) |
980 |
(buf (get-buffer-create (generate-new-buffer-name " *imap source*"))) |
(buf (generate-new-buffer " *imap source*")) |
981 |
(mail-source-string (format "imap:%s:%s" server mailbox)) |
(mail-source-string (format "imap:%s:%s" server mailbox)) |
982 |
|
(imap-shell-program (or (list program) imap-shell-program)) |
983 |
remove) |
remove) |
984 |
(if (and (imap-open server port stream authentication buf) |
(if (and (imap-open server port stream authentication buf) |
985 |
(imap-authenticate |
(imap-authenticate |
994 |
(mm-disable-multibyte) |
(mm-disable-multibyte) |
995 |
;; remember password |
;; remember password |
996 |
(with-current-buffer buf |
(with-current-buffer buf |
997 |
(when (or imap-password |
(when (and imap-password |
998 |
(assoc from mail-source-password-cache)) |
(not (assoc from mail-source-password-cache))) |
999 |
(push (cons from imap-password) mail-source-password-cache))) |
(push (cons from imap-password) mail-source-password-cache))) |
1000 |
;; if predicate is nil, use all uids |
;; if predicate is nil, use all uids |
1001 |
(dolist (uid (imap-search (or predicate "1:*") buf)) |
(dolist (uid (imap-search (or predicate "1:*") buf)) |
1002 |
(when (setq str (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf)) |
(when (setq str |
1003 |
|
(if (imap-capability 'IMAP4rev1 buf) |
1004 |
|
(caddar (imap-fetch uid "BODY.PEEK[]" |
1005 |
|
'BODYDETAIL nil buf)) |
1006 |
|
(imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf))) |
1007 |
(push uid remove) |
(push uid remove) |
1008 |
(insert "From imap " (current-time-string) "\n") |
(insert "From imap " (current-time-string) "\n") |
1009 |
(save-excursion |
(save-excursion |
1014 |
(nnheader-ms-strip-cr)) |
(nnheader-ms-strip-cr)) |
1015 |
(incf found (mail-source-callback callback server)) |
(incf found (mail-source-callback callback server)) |
1016 |
(when (and remove fetchflag) |
(when (and remove fetchflag) |
1017 |
|
(setq remove (nreverse remove)) |
1018 |
(imap-message-flags-add |
(imap-message-flags-add |
1019 |
(imap-range-to-message-set (gnus-compress-sequence remove)) |
(imap-range-to-message-set (gnus-compress-sequence remove)) |
1020 |
fetchflag nil buf)) |
fetchflag nil buf)) |
1021 |
(if dontexpunge |
(if dontexpunge |
1022 |
(imap-mailbox-unselect buf) |
(imap-mailbox-unselect buf) |
1023 |
(imap-mailbox-close buf)) |
(imap-mailbox-close nil buf)) |
1024 |
(imap-close buf)) |
(imap-close buf)) |
1025 |
(imap-close buf) |
(imap-close buf) |
1026 |
;; We nix out the password in case the error |
;; We nix out the password in case the error |
1028 |
(setq mail-source-password-cache |
(setq mail-source-password-cache |
1029 |
(delq (assoc from mail-source-password-cache) |
(delq (assoc from mail-source-password-cache) |
1030 |
mail-source-password-cache)) |
mail-source-password-cache)) |
1031 |
(error (imap-error-text buf))) |
(error "IMAP error: %s" (imap-error-text buf))) |
1032 |
(kill-buffer buf) |
(kill-buffer buf) |
1033 |
|
(mail-source-run-script |
1034 |
|
postscript |
1035 |
|
(format-spec-make ?p password ?t mail-source-crash-box |
1036 |
|
?s server ?P port ?u user)) |
1037 |
found))) |
found))) |
1038 |
|
|
1039 |
(eval-and-compile |
(eval-and-compile |
1050 |
(or password |
(or password |
1051 |
(cdr (assoc (format "webmail:%s:%s" subtype user) |
(cdr (assoc (format "webmail:%s:%s" subtype user) |
1052 |
mail-source-password-cache)) |
mail-source-password-cache)) |
1053 |
(mail-source-read-passwd |
(read-passwd |
1054 |
(format "Password for %s at %s: " user subtype)))) |
(format "Password for %s at %s: " user subtype)))) |
1055 |
(when (and password |
(when (and password |
1056 |
(not (assoc (format "webmail:%s:%s" subtype user) |
(not (assoc (format "webmail:%s:%s" subtype user) |