HCoop / bpt / emacs.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
* bookmark.el (bookmark-buffer-file-name): Abbreviate the bookmark path.
[bpt/emacs.git] / lisp / gnus / mail-source.el
CommitLineData
c113de23 1;;; mail-source.el --- functions for fetching mail
e84b4b86
TTN		 2
3;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
88e6695f 4;; 2005, 2006 Free Software Foundation, Inc.
c113de23
GM		 5
6;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7;; Keywords: news, mail
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software; you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation; either version 2, or (at your option)
14;; any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs; see the file COPYING. If not, write to the
3a35cf56
LK		 23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24;; Boston, MA 02110-1301, USA.
c113de23
GM		 25
26;;; Commentary:
27
28;;; Code:
29
4f926b3e
DL		 30(eval-when-compile
31 (require 'cl)
32 (require 'imap)
33 (eval-when-compile (defvar display-time-mail-function)))
c113de23
GM		 34(eval-and-compile
35 (autoload 'pop3-movemail "pop3")
4f926b3e 36 (autoload 'pop3-get-message-count "pop3")
23f87bed
MB		 37 (autoload 'nnheader-cancel-timer "nnheader")
38 (autoload 'nnheader-run-at-time "nnheader"))
c113de23 39(require 'format-spec)
4f926b3e 40(require 'mm-util)
23f87bed 41(require 'message) ;; for `message-directory'
c113de23
GM		 42
43(defgroup mail-source nil
44 "The mail-fetching library."
ce9401f3 45 :version "21.1"
c113de23
GM		 46 :group 'gnus)
47
4f926b3e
DL		 48;; Define these at compile time to avoid dragging in imap always.
49(defconst mail-source-imap-authenticators
50 (eval-when-compile
51 (mapcar (lambda (a)
52 (list 'const (car a)))
53 imap-authenticator-alist)))
54(defconst mail-source-imap-streams
55 (eval-when-compile
56 (mapcar (lambda (a)
57 (list 'const (car a)))
58 imap-stream-alist)))
59
72fc0418 60(defcustom mail-sources nil
c113de23 61 "*Where the mail backends will look for incoming mail.
ce9401f3
DL		 62This variable is a list of mail source specifiers.
63See Info node `(gnus)Mail Source Specifiers'."
c113de23 64 :group 'mail-source
23f87bed 65 :link '(custom-manual "(gnus)Mail Source Specifiers")
26c9afc3
MB		 66 :type `(choice
67 (const nil)
68 (repeat
69 (choice :format "%[Value Menu%] %v"
70 :value (file)
71 (cons :tag "Spool file"
72 (const :format "" file)
73 (checklist :tag "Options" :greedy t
74 (group :inline t
75 (const :format "" :value :path)
76 file)))
77 (cons :tag "Several files in a directory"
78 (const :format "" directory)
79 (checklist :tag "Options" :greedy t
80 (group :inline t
81 (const :format "" :value :path)
82 (directory :tag "Path"))
83 (group :inline t
84 (const :format "" :value :suffix)
85 (string :tag "Suffix"))
86 (group :inline t
87 (const :format "" :value :predicate)
88 (function :tag "Predicate"))
89 (group :inline t
90 (const :format "" :value :prescript)
91 (choice :tag "Prescript"
92 :value nil
93 (string :format "%v")
94 (function :format "%v")))
95 (group :inline t
96 (const :format "" :value :postscript)
97 (choice :tag "Postscript"
98 :value nil
99 (string :format "%v")
100 (function :format "%v")))
101 (group :inline t
102 (const :format "" :value :plugged)
103 (boolean :tag "Plugged"))))
104 (cons :tag "POP3 server"
105 (const :format "" pop)
106 (checklist :tag "Options" :greedy t
107 (group :inline t
108 (const :format "" :value :server)
109 (string :tag "Server"))
110 (group :inline t
111 (const :format "" :value :port)
112 (choice :tag "Port"
113 :value "pop3"
114 (number :format "%v")
115 (string :format "%v")))
116 (group :inline t
117 (const :format "" :value :user)
118 (string :tag "User"))
119 (group :inline t
120 (const :format "" :value :password)
121 (string :tag "Password"))
122 (group :inline t
123 (const :format "" :value :program)
124 (string :tag "Program"))
125 (group :inline t
126 (const :format "" :value :prescript)
127 (choice :tag "Prescript"
128 :value nil
129 (string :format "%v")
130 (function :format "%v")))
131 (group :inline t
132 (const :format "" :value :postscript)
133 (choice :tag "Postscript"
134 :value nil
135 (string :format "%v")
136 (function :format "%v")))
137 (group :inline t
138 (const :format "" :value :function)
139 (function :tag "Function"))
140 (group :inline t
141 (const :format ""
142 :value :authentication)
143 (choice :tag "Authentication"
144 :value apop
145 (const password)
146 (const apop)))
147 (group :inline t
148 (const :format "" :value :plugged)
149 (boolean :tag "Plugged"))))
150 (cons :tag "Maildir (qmail, postfix...)"
151 (const :format "" maildir)
152 (checklist :tag "Options" :greedy t
153 (group :inline t
154 (const :format "" :value :path)
155 (directory :tag "Path"))
156 (group :inline t
157 (const :format "" :value :plugged)
158 (boolean :tag "Plugged"))))
159 (cons :tag "IMAP server"
160 (const :format "" imap)
161 (checklist :tag "Options" :greedy t
162 (group :inline t
163 (const :format "" :value :server)
164 (string :tag "Server"))
165 (group :inline t
166 (const :format "" :value :port)
167 (choice :tag "Port"
168 :value 143
169 number string))
170 (group :inline t
171 (const :format "" :value :user)
172 (string :tag "User"))
173 (group :inline t
174 (const :format "" :value :password)
175 (string :tag "Password"))
176 (group :inline t
177 (const :format "" :value :stream)
178 (choice :tag "Stream"
179 :value network
180 ,@mail-source-imap-streams))
181 (group :inline t
182 (const :format "" :value :program)
183 (string :tag "Program"))
184 (group :inline t
185 (const :format ""
186 :value :authenticator)
187 (choice :tag "Authenticator"
188 :value login
189 ,@mail-source-imap-authenticators))
190 (group :inline t
191 (const :format "" :value :mailbox)
192 (string :tag "Mailbox"
193 :value "INBOX"))
194 (group :inline t
195 (const :format "" :value :predicate)
196 (string :tag "Predicate"
197 :value "UNSEEN UNDELETED"))
198 (group :inline t
199 (const :format "" :value :fetchflag)
200 (string :tag "Fetchflag"
201 :value "\\Deleted"))
202 (group :inline t
203 (const :format ""
204 :value :dontexpunge)
205 (boolean :tag "Dontexpunge"))
206 (group :inline t
207 (const :format "" :value :plugged)
208 (boolean :tag "Plugged"))))
209 (cons :tag "Webmail server"
210 (const :format "" webmail)
211 (checklist :tag "Options" :greedy t
212 (group :inline t
213 (const :format "" :value :subtype)
214 ;; Should be generated from
215 ;; `webmail-type-definition', but we
216 ;; can't require webmail without W3.
217 (choice :tag "Subtype"
218 :value hotmail
219 (const hotmail)
220 (const yahoo)
221 (const netaddress)
222 (const netscape)
223 (const my-deja)))
224 (group :inline t
225 (const :format "" :value :user)
226 (string :tag "User"))
227 (group :inline t
228 (const :format "" :value :password)
229 (string :tag "Password"))
230 (group :inline t
231 (const :format ""
232 :value :dontexpunge)
233 (boolean :tag "Dontexpunge"))
234 (group :inline t
235 (const :format "" :value :plugged)
236 (boolean :tag "Plugged"))))))))
c113de23 237
23f87bed
MB		 238(defcustom mail-source-ignore-errors nil
239 "*Ignore errors when querying mail sources.
240If nil, the user will be prompted when an error occurs. If non-nil,
a08b59c9 241the error will be ignored."
bf247b6e 242 :version "22.1"
a08b59c9
MB		 243 :group 'mail-source
244 :type 'boolean)
23f87bed 245
c113de23
GM		 246(defcustom mail-source-primary-source nil
247 "*Primary source for incoming mail.
248If non-nil, this maildrop will be checked periodically for new mail."
249 :group 'mail-source
250 :type 'sexp)
251
23f87bed
MB		 252(defcustom mail-source-flash t
253 "*If non-nil, flash periodically when mail is available."
254 :group 'mail-source
255 :type 'boolean)
256
c113de23
GM		 257(defcustom mail-source-crash-box "~/.emacs-mail-crash-box"
258 "File where mail will be stored while processing it."
259 :group 'mail-source
260 :type 'file)
261
23f87bed 262(defcustom mail-source-directory message-directory
531e5812 263 "Directory where incoming mail source files (if any) will be stored."
c113de23
GM		 264 :group 'mail-source
265 :type 'directory)
266
267(defcustom mail-source-default-file-modes 384
268 "Set the mode bits of all new mail files to this integer."
269 :group 'mail-source
270 :type 'integer)
271
805b7fc0 272(defcustom mail-source-delete-incoming t
23f87bed
MB		 273 "*If non-nil, delete incoming files after handling.
274If t, delete immediately, if nil, never delete. If a positive number, delete
275files older than number of days."
276 ;; Note: The removing happens in `mail-source-callback', i.e. no old
277 ;; incoming files will be deleted, unless you receive new mail.
278 ;;
279 ;; You may also set this to `nil' and call `mail-source-delete-old-incoming'
280 ;; from a hook or interactively.
281 :group 'mail-source
282 :type '(choice (const :tag "immediately" t)
283 (const :tag "never" nil)
284 (integer :tag "days")))
285
286(defcustom mail-source-delete-old-incoming-confirm t
287 "*If non-nil, ask for for confirmation before deleting old incoming files.
288This variable only applies when `mail-source-delete-incoming' is a positive
289number."
bf247b6e 290 :version "22.1"
c113de23
GM		 291 :group 'mail-source
292 :type 'boolean)
293
294(defcustom mail-source-incoming-file-prefix "Incoming"
295 "Prefix for file name for storing incoming mail"
296 :group 'mail-source
297 :type 'string)
298
299(defcustom mail-source-report-new-mail-interval 5
300 "Interval in minutes between checks for new mail."
301 :group 'mail-source
302 :type 'number)
303
304(defcustom mail-source-idle-time-delay 5
305 "Number of idle seconds to wait before checking for new mail."
306 :group 'mail-source
307 :type 'number)
308
23f87bed
MB		 309(defcustom mail-source-movemail-program nil
310 "If non-nil, name of program for fetching new mail."
bf247b6e 311 :version "22.1"
23f87bed
MB		 312 :group 'mail-source
313 :type '(choice (const nil) string))
314
c113de23
GM		 315;;; Internal variables.
316
317(defvar mail-source-string ""
318 "A dynamically bound string that says what the current mail source is.")
319
320(defvar mail-source-new-mail-available nil
321 "Flag indicating when new mail is available.")
322
323(eval-and-compile
324 (defvar mail-source-common-keyword-map
325 '((:plugged))
326 "Mapping from keywords to default values.
327Common keywords should be listed here.")
328
329 (defvar mail-source-keyword-map
330 '((file
331 (:prescript)
332 (:prescript-delay)
333 (:postscript)
334 (:path (or (getenv "MAIL")
4f926b3e 335 (expand-file-name (user-login-name) rmail-spool-directory))))
c113de23 336 (directory
cf92160d
SZ		 337 (:prescript)
338 (:prescript-delay)
339 (:postscript)
c113de23
GM		 340 (:path)
341 (:suffix ".spool")
342 (:predicate identity))
343 (pop
344 (:prescript)
345 (:prescript-delay)
346 (:postscript)
347 (:server (getenv "MAILHOST"))
348 (:port 110)
349 (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
350 (:program)
351 (:function)
352 (:password)
353 (:authentication password))
354 (maildir
355 (:path (or (getenv "MAILDIR") "~/Maildir/"))
23f87bed 356 (:subdirs ("cur" "new"))
c113de23
GM		 357 (:function))
358 (imap
359 (:server (getenv "MAILHOST"))
360 (:port)
361 (:stream)
23f87bed 362 (:program)
c113de23
GM		 363 (:authentication)
364 (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
365 (:password)
366 (:mailbox "INBOX")
367 (:predicate "UNSEEN UNDELETED")
368 (:fetchflag "\\Deleted")
23f87bed
MB		 369 (:prescript)
370 (:prescript-delay)
371 (:postscript)
c113de23
GM		 372 (:dontexpunge))
373 (webmail
374 (:subtype hotmail)
375 (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
376 (:password)
377 (:dontexpunge)
378 (:authentication password)))
379 "Mapping from keywords to default values.
380All keywords that can be used must be listed here."))
381
382(defvar mail-source-fetcher-alist
383 '((file mail-source-fetch-file)
384 (directory mail-source-fetch-directory)
385 (pop mail-source-fetch-pop)
386 (maildir mail-source-fetch-maildir)
387 (imap mail-source-fetch-imap)
388 (webmail mail-source-fetch-webmail))
389 "A mapping from source type to fetcher function.")
390
391(defvar mail-source-password-cache nil)
392
393(defvar mail-source-plugged t)
394
395;;; Functions
396
397(eval-and-compile
398 (defun mail-source-strip-keyword (keyword)
399 "Strip the leading colon off the KEYWORD."
400 (intern (substring (symbol-name keyword) 1))))
401
402(eval-and-compile
403 (defun mail-source-bind-1 (type)
404 (let* ((defaults (cdr (assq type mail-source-keyword-map)))
405 default bind)
406 (while (setq default (pop defaults))
407 (push (list (mail-source-strip-keyword (car default))
408 nil)
409 bind))
410 bind)))
411
412(defmacro mail-source-bind (type-source &rest body)
413 "Return a `let' form that binds all variables in source TYPE.
414TYPE-SOURCE is a list where the first element is the TYPE, and
415the second variable is the SOURCE.
416At run time, the mail source specifier SOURCE will be inspected,
417and the variables will be set according to it. Variables not
418specified will be given default values.
419
420After this is done, BODY will be executed in the scope
421of the `let' form.
422
423The variables bound and their default values are described by
424the `mail-source-keyword-map' variable."
425 `(let ,(mail-source-bind-1 (car type-source))
426 (mail-source-set-1 ,(cadr type-source))
427 ,@body))
428
429(put 'mail-source-bind 'lisp-indent-function 1)
23f87bed 430(put 'mail-source-bind 'edebug-form-spec '(sexp body))
c113de23
GM		 431
432(defun mail-source-set-1 (source)
433 (let* ((type (pop source))
434 (defaults (cdr (assq type mail-source-keyword-map)))
435 default value keyword)
436 (while (setq default (pop defaults))
437 (set (mail-source-strip-keyword (setq keyword (car default)))
438 (if (setq value (plist-get source keyword))
439 (mail-source-value value)
440 (mail-source-value (cadr default)))))))
441
442(eval-and-compile
443 (defun mail-source-bind-common-1 ()
444 (let* ((defaults mail-source-common-keyword-map)
445 default bind)
446 (while (setq default (pop defaults))
447 (push (list (mail-source-strip-keyword (car default))
448 nil)
449 bind))
450 bind)))
451
452(defun mail-source-set-common-1 (source)
453 (let* ((type (pop source))
454 (defaults mail-source-common-keyword-map)
455 (defaults-1 (cdr (assq type mail-source-keyword-map)))
456 default value keyword)
457 (while (setq default (pop defaults))
458 (set (mail-source-strip-keyword (setq keyword (car default)))
459 (if (setq value (plist-get source keyword))
460 (mail-source-value value)
461 (if (setq value (assq keyword defaults-1))
462 (mail-source-value (cadr value))
463 (mail-source-value (cadr default))))))))
464
465(defmacro mail-source-bind-common (source &rest body)
466 "Return a `let' form that binds all common variables.
467See `mail-source-bind'."
468 `(let ,(mail-source-bind-common-1)
469 (mail-source-set-common-1 source)
470 ,@body))
471
472(put 'mail-source-bind-common 'lisp-indent-function 1)
23f87bed 473(put 'mail-source-bind-common 'edebug-form-spec '(sexp body))
c113de23
GM		 474
475(defun mail-source-value (value)
476 "Return the value of VALUE."
477 (cond
478 ;; String
479 ((stringp value)
480 value)
481 ;; Function
482 ((and (listp value)
483 (functionp (car value)))
484 (eval value))
485 ;; Just return the value.
486 (t
487 value)))
488
489(defun mail-source-fetch (source callback)
490 "Fetch mail from SOURCE and call CALLBACK zero or more times.
491CALLBACK will be called with the name of the file where (some of)
492the mail from SOURCE is put.
493Return the number of files that were found."
494 (mail-source-bind-common source
495 (if (or mail-source-plugged plugged)
496 (save-excursion
497 (let ((function (cadr (assq (car source) mail-source-fetcher-alist)))
498 (found 0))
499 (unless function
500 (error "%S is an invalid mail source specification" source))
501 ;; If there's anything in the crash box, we do it first.
502 (when (file-exists-p mail-source-crash-box)
503 (message "Processing mail from %s..." mail-source-crash-box)
504 (setq found (mail-source-callback
505 callback mail-source-crash-box)))
506 (+ found
23f87bed 507 (if (or debug-on-quit debug-on-error)
c113de23 508 (funcall function source callback)
23f87bed
MB		 509 (condition-case err
510 (funcall function source callback)
511 (error
512 (if (and (not mail-source-ignore-errors)
513 (not
514 (yes-or-no-p
515 (format "Mail source %s error (%s). Continue? "
516 (if (memq ':password source)
517 (let ((s (copy-sequence source)))
bf247b6e 518 (setcar (cdr (memq ':password s))
23f87bed
MB		 519 "********")
520 s)
521 source)
522 (cadr err)))))
523 (error "Cannot get new mail"))
524 0)))))))))
525
526(defun mail-source-delete-old-incoming (&optional age confirm)
527 "Remove incoming files older than AGE days.
528If CONFIRM is non-nil, ask for confirmation before removing a file."
529 (interactive "P")
530 (let* ((high2days (/ 65536.0 60 60 24));; convert high bits to days
531 (low2days (/ 1.0 65536.0)) ;; convert low bits to days
532 (diff (if (natnump age) age 30));; fallback, if no valid AGE given
533 currday files)
534 (setq files (directory-files
535 mail-source-directory t
536 (concat mail-source-incoming-file-prefix "*"))
537 currday (* (car (current-time)) high2days)
538 currday (+ currday (* low2days (nth 1 (current-time)))))
539 (while files
540 (let* ((ffile (car files))
541 (bfile (gnus-replace-in-string
542 ffile "\\`.*/\\([^/]+\\)\\'" "\\1"))
543 (filetime (nth 5 (file-attributes ffile)))
544 (fileday (* (car filetime) high2days))
545 (fileday (+ fileday (* low2days (nth 1 filetime)))))
546 (setq files (cdr files))
547 (when (and (> (- currday fileday) diff)
548 (gnus-message 8 "File `%s' is older than %s day(s)"
549 bfile diff)
550 (or (not confirm)
551 (y-or-n-p (concat "Remove file `" bfile "'? "))))
552 (delete-file ffile))))))
c113de23
GM		 553
554(defun mail-source-callback (callback info)
555 "Call CALLBACK on the mail file, and then remove the mail file.
556Pass INFO on to CALLBACK."
557 (if (or (not (file-exists-p mail-source-crash-box))
558 (zerop (nth 7 (file-attributes mail-source-crash-box))))
559 (progn
560 (when (file-exists-p mail-source-crash-box)
561 (delete-file mail-source-crash-box))
562 0)
563 (prog1
564 (funcall callback mail-source-crash-box info)
565 (when (file-exists-p mail-source-crash-box)
566 ;; Delete or move the incoming mail out of the way.
23f87bed 567 (if (eq mail-source-delete-incoming t)
c113de23
GM		 568 (delete-file mail-source-crash-box)
569 (let ((incoming
23f87bed 570 (mm-make-temp-file
c113de23
GM		 571 (expand-file-name
572 mail-source-incoming-file-prefix
573 mail-source-directory))))
574 (unless (file-exists-p (file-name-directory incoming))
575 (make-directory (file-name-directory incoming) t))
23f87bed
MB		 576 (rename-file mail-source-crash-box incoming t)
577 ;; remove old incoming files?
578 (when (natnump mail-source-delete-incoming)
579 (mail-source-delete-old-incoming
580 mail-source-delete-incoming
581 mail-source-delete-old-incoming-confirm))))))))
c113de23
GM		 582
583(defun mail-source-movemail (from to)
584 "Move FROM to TO using movemail."
585 (if (not (file-writable-p to))
586 (error "Can't write to crash box %s. Not moving mail" to)
587 (let ((to (file-truename (expand-file-name to)))
588 errors result)
589 (setq to (file-truename to)
590 from (file-truename from))
591 ;; Set TO if have not already done so, and rename or copy
592 ;; the file FROM to TO if and as appropriate.
593 (cond
594 ((file-exists-p to)
595 ;; The crash box exists already.
596 t)
597 ((not (file-exists-p from))
598 ;; There is no inbox.
599 (setq to nil))
600 ((zerop (nth 7 (file-attributes from)))
601 ;; Empty file.
602 (setq to nil))
603 (t
604 ;; If getting from mail spool directory, use movemail to move
605 ;; rather than just renaming, so as to interlock with the
606 ;; mailer.
607 (unwind-protect
608 (save-excursion
609 (setq errors (generate-new-buffer " *mail source loss*"))
610 (let ((default-directory "/"))
611 (setq result
612 (apply
613 'call-process
614 (append
615 (list
23f87bed
MB		 616 (or mail-source-movemail-program
617 (expand-file-name "movemail" exec-directory))
c113de23
GM		 618 nil errors nil from to)))))
619 (when (file-exists-p to)
620 (set-file-modes to mail-source-default-file-modes))
23f87bed
MB		 621 (if (and (or (not (buffer-modified-p errors))
622 (zerop (buffer-size errors)))
623 (and (numberp result)
624 (zerop result)))
c113de23
GM		 625 ;; No output => movemail won.
626 t
627 (set-buffer errors)
628 ;; There may be a warning about older revisions. We
629 ;; ignore that.
630 (goto-char (point-min))
631 (if (search-forward "older revision" nil t)
632 t
633 ;; Probably a real error.
634 (subst-char-in-region (point-min) (point-max) ?\n ?\ )
635 (goto-char (point-max))
636 (skip-chars-backward " \t")
637 (delete-region (point) (point-max))
638 (goto-char (point-min))
639 (when (looking-at "movemail: ")
640 (delete-region (point-min) (match-end 0)))
23f87bed 641 ;; Result may be a signal description string.
c113de23 642 (unless (yes-or-no-p
23f87bed 643 (format "movemail: %s (%s return). Continue? "
c113de23
GM		 644 (buffer-string) result))
645 (error "%s" (buffer-string)))
646 (setq to nil)))))))
647 (when (and errors
648 (buffer-name errors))
649 (kill-buffer errors))
650 ;; Return whether we moved successfully or not.
651 to)))
652
653(defun mail-source-movemail-and-remove (from to)
654 "Move FROM to TO using movemail, then remove FROM if empty."
655 (or (not (mail-source-movemail from to))
656 (not (zerop (nth 7 (file-attributes from))))
657 (delete-file from)))
658
c113de23 659(defun mail-source-fetch-with-program (program)
23f87bed
MB		 660 (eq 0 (call-process shell-file-name nil nil nil
661 shell-command-switch program)))
c113de23
GM		 662
663(defun mail-source-run-script (script spec &optional delay)
664 (when script
23f87bed 665 (if (functionp script)
c113de23
GM		 666 (funcall script)
667 (mail-source-call-script
668 (format-spec script spec))))
669 (when delay
670 (sleep-for delay)))
671
672(defun mail-source-call-script (script)
673 (let ((background nil))
674 (when (string-match "& *$" script)
675 (setq script (substring script 0 (match-beginning 0))
676 background 0))
677 (call-process shell-file-name nil background nil
678 shell-command-switch script)))
679
680;;;
681;;; Different fetchers
682;;;
683
684(defun mail-source-fetch-file (source callback)
685 "Fetcher for single-file sources."
686 (mail-source-bind (file source)
687 (mail-source-run-script
688 prescript (format-spec-make ?t mail-source-crash-box)
689 prescript-delay)
690 (let ((mail-source-string (format "file:%s" path)))
691 (if (mail-source-movemail path mail-source-crash-box)
692 (prog1
693 (mail-source-callback callback path)
694 (mail-source-run-script
695 postscript (format-spec-make ?t mail-source-crash-box)))
696 0))))
697
698(defun mail-source-fetch-directory (source callback)
699 "Fetcher for directory sources."
700 (mail-source-bind (directory source)
35037882 701 (mail-source-run-script
23f87bed 702 prescript (format-spec-make ?t path) prescript-delay)
c113de23
GM		 703 (let ((found 0)
704 (mail-source-string (format "directory:%s" path)))
705 (dolist (file (directory-files
706 path t (concat (regexp-quote suffix) "$")))
707 (when (and (file-regular-p file)
708 (funcall predicate file)
709 (mail-source-movemail file mail-source-crash-box))
710 (incf found (mail-source-callback callback file))))
23f87bed 711 (mail-source-run-script postscript (format-spec-make ?t path))
c113de23
GM		 712 found)))
713
714(defun mail-source-fetch-pop (source callback)
715 "Fetcher for single-file sources."
716 (mail-source-bind (pop source)
717 (mail-source-run-script
718 prescript
719 (format-spec-make ?p password ?t mail-source-crash-box
720 ?s server ?P port ?u user)
721 prescript-delay)
722 (let ((from (format "%s:%s:%s" server user port))
723 (mail-source-string (format "pop:%s@%s" user server))
724 result)
725 (when (eq authentication 'password)
726 (setq password
727 (or password
728 (cdr (assoc from mail-source-password-cache))
23f87bed 729 (read-passwd
c113de23
GM		 730 (format "Password for %s at %s: " user server)))))
731 (when server
732 (setenv "MAILHOST" server))
733 (setq result
734 (cond
735 (program
736 (mail-source-fetch-with-program
737 (format-spec
738 program
739 (format-spec-make ?p password ?t mail-source-crash-box
740 ?s server ?P port ?u user))))
741 (function
742 (funcall function mail-source-crash-box))
743 ;; The default is to use pop3.el.
744 (t
292f71fe 745 (require 'pop3)
c113de23
GM		 746 (let ((pop3-password password)
747 (pop3-maildrop user)
748 (pop3-mailhost server)
749 (pop3-port port)
750 (pop3-authentication-scheme
751 (if (eq authentication 'apop) 'apop 'pass)))
23f87bed
MB		 752 (if (or debug-on-quit debug-on-error)
753 (save-excursion (pop3-movemail mail-source-crash-box))
754 (condition-case err
755 (save-excursion (pop3-movemail mail-source-crash-box))
756 (error
757 ;; We nix out the password in case the error
758 ;; was because of a wrong password being given.
759 (setq mail-source-password-cache
760 (delq (assoc from mail-source-password-cache)
761 mail-source-password-cache))
762 (signal (car err) (cdr err)))))))))
c113de23
GM		 763 (if result
764 (progn
765 (when (eq authentication 'password)
766 (unless (assoc from mail-source-password-cache)
767 (push (cons from password) mail-source-password-cache)))
768 (prog1
769 (mail-source-callback callback server)
770 ;; Update display-time's mail flag, if relevant.
771 (if (equal source mail-source-primary-source)
772 (setq mail-source-new-mail-available nil))
773 (mail-source-run-script
774 postscript
775 (format-spec-make ?p password ?t mail-source-crash-box
776 ?s server ?P port ?u user))))
777 ;; We nix out the password in case the error
778 ;; was because of a wrong password being given.
779 (setq mail-source-password-cache
780 (delq (assoc from mail-source-password-cache)
781 mail-source-password-cache))
782 0))))
783
784(defun mail-source-check-pop (source)
785 "Check whether there is new mail."
786 (mail-source-bind (pop source)
787 (let ((from (format "%s:%s:%s" server user port))
788 (mail-source-string (format "pop:%s@%s" user server))
789 result)
790 (when (eq authentication 'password)
791 (setq password
792 (or password
793 (cdr (assoc from mail-source-password-cache))
23f87bed 794 (read-passwd
c113de23
GM		 795 (format "Password for %s at %s: " user server))))
796 (unless (assoc from mail-source-password-cache)
797 (push (cons from password) mail-source-password-cache)))
798 (when server
799 (setenv "MAILHOST" server))
800 (setq result
801 (cond
802 ;; No easy way to check whether mail is waiting for these.
803 (program)
804 (function)
805 ;; The default is to use pop3.el.
806 (t
292f71fe 807 (require 'pop3)
c113de23
GM		 808 (let ((pop3-password password)
809 (pop3-maildrop user)
810 (pop3-mailhost server)
811 (pop3-port port)
812 (pop3-authentication-scheme
813 (if (eq authentication 'apop) 'apop 'pass)))
23f87bed
MB		 814 (if (or debug-on-quit debug-on-error)
815 (save-excursion (pop3-get-message-count))
816 (condition-case err
817 (save-excursion (pop3-get-message-count))
818 (error
819 ;; We nix out the password in case the error
820 ;; was because of a wrong password being given.
821 (setq mail-source-password-cache
822 (delq (assoc from mail-source-password-cache)
823 mail-source-password-cache))
824 (signal (car err) (cdr err)))))))))
c113de23
GM		 825 (if result
826 ;; Inform display-time that we have new mail.
827 (setq mail-source-new-mail-available (> result 0))
828 ;; We nix out the password in case the error
829 ;; was because of a wrong password being given.
830 (setq mail-source-password-cache
831 (delq (assoc from mail-source-password-cache)
832 mail-source-password-cache)))
833 result)))
834
23f87bed
MB		 835(defun mail-source-touch-pop ()
836 "Open and close a POP connection shortly.
837POP server should be defined in `mail-source-primary-source' (which is
838preferred) or `mail-sources'. You may use it for the POP-before-SMTP
839authentication. To do that, you need to set the
840`message-send-mail-function' variable as `message-smtpmail-send-it'
841and put the following line in your ~/.gnus.el file:
842
843\(add-hook 'message-send-mail-hook 'mail-source-touch-pop)
844
845See the Gnus manual for details."
846 (let ((sources (if mail-source-primary-source
847 (list mail-source-primary-source)
848 mail-sources)))
849 (while sources
850 (if (eq 'pop (car (car sources)))
851 (mail-source-check-pop (car sources)))
852 (setq sources (cdr sources)))))
853
c113de23
GM		 854(defun mail-source-new-mail-p ()
855 "Handler for `display-time' to indicate when new mail is available."
23f87bed
MB		 856 ;; Flash (ie. ring the visible bell) if mail is available.
857 (if (and mail-source-flash mail-source-new-mail-available)
858 (let ((visible-bell t))
859 (ding)))
c113de23
GM		 860 ;; Only report flag setting; flag is updated on a different schedule.
861 mail-source-new-mail-available)
862
863
864(defvar mail-source-report-new-mail nil)
865(defvar mail-source-report-new-mail-timer nil)
866(defvar mail-source-report-new-mail-idle-timer nil)
867
a1506d29 868(eval-when-compile
126cbb42 869 (if (featurep 'xemacs)
fa9a04e1 870 (require 'timer-funcs)
126cbb42 871 (require 'timer)))
c113de23
GM		 872
873(defun mail-source-start-idle-timer ()
874 ;; Start our idle timer if necessary, so we delay the check until the
875 ;; user isn't typing.
876 (unless mail-source-report-new-mail-idle-timer
877 (setq mail-source-report-new-mail-idle-timer
878 (run-with-idle-timer
879 mail-source-idle-time-delay
880 nil
881 (lambda ()
23f87bed
MB		 882 (unwind-protect
883 (mail-source-check-pop mail-source-primary-source)
884 (setq mail-source-report-new-mail-idle-timer nil)))))
c113de23
GM		 885 ;; Since idle timers created when Emacs is already in the idle
886 ;; state don't get activated until Emacs _next_ becomes idle, we
887 ;; need to force our timer to be considered active now. We do
888 ;; this by being naughty and poking the timer internals directly
889 ;; (element 0 of the vector is nil if the timer is active).
890 (aset mail-source-report-new-mail-idle-timer 0 nil)))
891
892(defun mail-source-report-new-mail (arg)
893 "Toggle whether to report when new mail is available.
894This only works when `display-time' is enabled."
895 (interactive "P")
896 (if (not mail-source-primary-source)
715a2ca2 897 (error "Need to set `mail-source-primary-source' to check for new mail"))
c113de23
GM		 898 (let ((on (if (null arg)
899 (not mail-source-report-new-mail)
900 (> (prefix-numeric-value arg) 0))))
901 (setq mail-source-report-new-mail on)
902 (and mail-source-report-new-mail-timer
72fc0418 903 (nnheader-cancel-timer mail-source-report-new-mail-timer))
c113de23 904 (and mail-source-report-new-mail-idle-timer
72fc0418 905 (nnheader-cancel-timer mail-source-report-new-mail-idle-timer))
c113de23
GM		 906 (setq mail-source-report-new-mail-timer nil)
907 (setq mail-source-report-new-mail-idle-timer nil)
908 (if on
909 (progn
910 (require 'time)
ce9401f3 911 ;; display-time-mail-function is an Emacs 21 feature.
c113de23
GM		 912 (setq display-time-mail-function #'mail-source-new-mail-p)
913 ;; Set up the main timer.
914 (setq mail-source-report-new-mail-timer
23f87bed
MB		 915 (nnheader-run-at-time
916 (* 60 mail-source-report-new-mail-interval)
917 (* 60 mail-source-report-new-mail-interval)
918 #'mail-source-start-idle-timer))
c113de23
GM		 919 ;; When you get new mail, clear "Mail" from the mode line.
920 (add-hook 'nnmail-post-get-new-mail-hook
921 'display-time-event-handler)
922 (message "Mail check enabled"))
923 (setq display-time-mail-function nil)
924 (remove-hook 'nnmail-post-get-new-mail-hook
925 'display-time-event-handler)
926 (message "Mail check disabled"))))
927
928(defun mail-source-fetch-maildir (source callback)
929 "Fetcher for maildir sources."
930 (mail-source-bind (maildir source)
931 (let ((found 0)
932 mail-source-string)
933 (unless (string-match "/$" path)
934 (setq path (concat path "/")))
935 (dolist (subdir subdirs)
936 (when (file-directory-p (concat path subdir))
937 (setq mail-source-string (format "maildir:%s%s" path subdir))
938 (dolist (file (directory-files (concat path subdir) t))
939 (when (and (not (file-directory-p file))
940 (not (if function
941 (funcall function file mail-source-crash-box)
a1506d29 942 (let ((coding-system-for-write
c113de23 943 mm-text-coding-system)
a1506d29 944 (coding-system-for-read
c113de23
GM		 945 mm-text-coding-system))
946 (with-temp-file mail-source-crash-box
947 (insert-file-contents file)
948 (goto-char (point-min))
23f87bed
MB		 949;;; ;; Unix mail format
950;;; (unless (looking-at "\n*From ")
951;;; (insert "From maildir "
952;;; (current-time-string) "\n"))
953;;; (while (re-search-forward "^From " nil t)
954;;; (replace-match ">From "))
955;;; (goto-char (point-max))
126cbb42 956;;; (insert "\n\n")
c113de23 957 ;; MMDF mail format
126cbb42 958 (insert "\001\001\001\001\n"))
c113de23
GM		 959 (delete-file file)))))
960 (incf found (mail-source-callback callback file))))))
961 found)))
962
963(eval-and-compile
964 (autoload 'imap-open "imap")
965 (autoload 'imap-authenticate "imap")
966 (autoload 'imap-mailbox-select "imap")
967 (autoload 'imap-mailbox-unselect "imap")
968 (autoload 'imap-mailbox-close "imap")
969 (autoload 'imap-search "imap")
970 (autoload 'imap-fetch "imap")
971 (autoload 'imap-close "imap")
972 (autoload 'imap-error-text "imap")
973 (autoload 'imap-message-flags-add "imap")
974 (autoload 'imap-list-to-message-set "imap")
72fc0418 975 (autoload 'imap-range-to-message-set "imap")
c113de23
GM		 976 (autoload 'nnheader-ms-strip-cr "nnheader"))
977
72fc0418
DL		 978(defvar mail-source-imap-file-coding-system 'binary
979 "Coding system for the crashbox made by `mail-source-fetch-imap'.")
980
c113de23
GM		 981(defun mail-source-fetch-imap (source callback)
982 "Fetcher for imap sources."
983 (mail-source-bind (imap source)
23f87bed
MB		 984 (mail-source-run-script
985 prescript (format-spec-make ?p password ?t mail-source-crash-box
986 ?s server ?P port ?u user)
987 prescript-delay)
c113de23
GM		 988 (let ((from (format "%s:%s:%s" server user port))
989 (found 0)
23f87bed 990 (buf (generate-new-buffer " *imap source*"))
c113de23 991 (mail-source-string (format "imap:%s:%s" server mailbox))
23f87bed 992 (imap-shell-program (or (list program) imap-shell-program))
c113de23
GM		 993 remove)
994 (if (and (imap-open server port stream authentication buf)
995 (imap-authenticate
996 user (or (cdr (assoc from mail-source-password-cache))
997 password) buf)
998 (imap-mailbox-select mailbox nil buf))
4f926b3e 999 (let ((coding-system-for-write mail-source-imap-file-coding-system)
126cbb42 1000 str)
c113de23 1001 (with-temp-file mail-source-crash-box
4f926b3e
DL		 1002 ;; Avoid converting 8-bit chars from inserted strings to
1003 ;; multibyte.
1004 (mm-disable-multibyte)
c113de23
GM		 1005 ;; remember password
1006 (with-current-buffer buf
23f87bed
MB		 1007 (when (and imap-password
1008 (not (assoc from mail-source-password-cache)))
c113de23
GM		 1009 (push (cons from imap-password) mail-source-password-cache)))
1010 ;; if predicate is nil, use all uids
1011 (dolist (uid (imap-search (or predicate "1:*") buf))
23f87bed
MB		 1012 (when (setq str
1013 (if (imap-capability 'IMAP4rev1 buf)
1014 (caddar (imap-fetch uid "BODY.PEEK[]"
1015 'BODYDETAIL nil buf))
1016 (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf)))
c113de23
GM		 1017 (push uid remove)
1018 (insert "From imap " (current-time-string) "\n")
1019 (save-excursion
1020 (insert str "\n\n"))
1021 (while (re-search-forward "^From " nil t)
1022 (replace-match ">From "))
1023 (goto-char (point-max))))
1024 (nnheader-ms-strip-cr))
1025 (incf found (mail-source-callback callback server))
1026 (when (and remove fetchflag)
23f87bed 1027 (setq remove (nreverse remove))
c113de23 1028 (imap-message-flags-add
72fc0418
DL		 1029 (imap-range-to-message-set (gnus-compress-sequence remove))
1030 fetchflag nil buf))
c113de23
GM		 1031 (if dontexpunge
1032 (imap-mailbox-unselect buf)
23f87bed 1033 (imap-mailbox-close nil buf))
c113de23
GM		 1034 (imap-close buf))
1035 (imap-close buf)
1036 ;; We nix out the password in case the error
1037 ;; was because of a wrong password being given.
1038 (setq mail-source-password-cache
1039 (delq (assoc from mail-source-password-cache)
1040 mail-source-password-cache))
23f87bed 1041 (error "IMAP error: %s" (imap-error-text buf)))
c113de23 1042 (kill-buffer buf)
23f87bed
MB		 1043 (mail-source-run-script
1044 postscript
1045 (format-spec-make ?p password ?t mail-source-crash-box
1046 ?s server ?P port ?u user))
c113de23
GM		 1047 found)))
1048
1049(eval-and-compile
1050 (autoload 'webmail-fetch "webmail"))
1051
1052(defun mail-source-fetch-webmail (source callback)
1053 "Fetch for webmail source."
1054 (mail-source-bind (webmail source)
1055 (let ((mail-source-string (format "webmail:%s:%s" subtype user))
1056 (webmail-newmail-only dontexpunge)
1057 (webmail-move-to-trash-can (not dontexpunge)))
1058 (when (eq authentication 'password)
1059 (setq password
1060 (or password
a1506d29 1061 (cdr (assoc (format "webmail:%s:%s" subtype user)
c113de23 1062 mail-source-password-cache))
23f87bed 1063 (read-passwd
c113de23
GM		 1064 (format "Password for %s at %s: " user subtype))))
1065 (when (and password
a1506d29 1066 (not (assoc (format "webmail:%s:%s" subtype user)
c113de23 1067 mail-source-password-cache)))
a1506d29 1068 (push (cons (format "webmail:%s:%s" subtype user) password)
c113de23
GM		 1069 mail-source-password-cache)))
1070 (webmail-fetch mail-source-crash-box subtype user password)
1071 (mail-source-callback callback (symbol-name subtype)))))
1072
1073(provide 'mail-source)
1074
ab5796a9 1075;;; arch-tag: 72948025-1d17-4d6c-bb12-ef1aa2c490fd
c113de23 1076;;; mail-source.el ends here
Unnamed repository; edit this file 'description' to name the repository.