1;;; mail-source.el --- functions for fetching mail
2
3;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
4;;   2005, 2006, 2007 Free Software Foundation, Inc.
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
23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24;; Boston, MA 02110-1301, USA.
25
26;;; Commentary:
27
28;;; Code:
29
30(eval-when-compile
31  (require 'cl)
32  (require 'imap)
33  (eval-when-compile (defvar display-time-mail-function)))
34(eval-and-compile
35  (autoload 'pop3-movemail "pop3")
36  (autoload 'pop3-get-message-count "pop3")
37  (autoload 'nnheader-cancel-timer "nnheader")
38  (autoload 'nnheader-run-at-time "nnheader"))
39(require 'format-spec)
40(require 'mm-util)
41(require 'message) ;; for `message-directory'
42
43(defgroup mail-source nil
44  "The mail-fetching library."
45  :version "21.1"
46  :group 'gnus)
47
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
60(defcustom mail-sources nil
61  "*Where the mail backends will look for incoming mail.
62This variable is a list of mail source specifiers.
63See Info node `(gnus)Mail Source Specifiers'."
64  :group 'mail-source
65  :link '(custom-manual "(gnus)Mail Source Specifiers")
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"))))))))
237
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,
241the error will be ignored."
242  :version "22.1"
243  :group 'mail-source
244  :type 'boolean)
245
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
252(defcustom mail-source-flash t
253  "*If non-nil, flash periodically when mail is available."
254  :group 'mail-source
255  :type 'boolean)
256
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
262(defcustom mail-source-directory message-directory
263  "Directory where incoming mail source files (if any) will be stored."
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
272(defcustom mail-source-delete-incoming t
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."
290  :version "22.1"
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
309(defcustom mail-source-movemail-program nil
310  "If non-nil, name of program for fetching new mail."
311  :version "22.1"
312  :group 'mail-source
313  :type '(choice (const nil) string))
314
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")
335		  (expand-file-name (user-login-name) rmail-spool-directory))))
336      (directory
337       (:prescript)
338       (:prescript-delay)
339       (:postscript)
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/"))
356       (:subdirs ("cur" "new"))
357       (:function))
358      (imap
359       (:server (getenv "MAILHOST"))
360       (:port)
361       (:stream)
362       (:program)
363       (:authentication)
364       (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
365       (:password)
366       (:mailbox "INBOX")
367       (:predicate "UNSEEN UNDELETED")
368       (:fetchflag "\\Deleted")
369       (:prescript)
370       (:prescript-delay)
371       (:postscript)
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)
430(put 'mail-source-bind 'edebug-form-spec '(sexp body))
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)
473(put 'mail-source-bind-common 'edebug-form-spec '(sexp body))
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
507	       (if (or debug-on-quit debug-on-error)
508		   (funcall function source callback)
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)))
518					     (setcar (cdr (memq ':password s))
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))))))
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.
567	(if (eq mail-source-delete-incoming t)
568	    (delete-file mail-source-crash-box)
569	  (let ((incoming
570		 (mm-make-temp-file
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))
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))))))))
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
616			 (or mail-source-movemail-program
617			     (expand-file-name "movemail" exec-directory))
618			 nil errors nil from to)))))
619	      (when (file-exists-p to)
620		(set-file-modes to mail-source-default-file-modes))
621	      (if (and (or (not (buffer-modified-p errors))
622			   (zerop (buffer-size errors)))
623		       (and (numberp result)
624			    (zerop result)))
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)))
641		  ;; Result may be a signal description string.
642		  (unless (yes-or-no-p
643			   (format "movemail: %s (%s return).  Continue? "
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
659(defun mail-source-fetch-with-program (program)
660  (eq 0 (call-process shell-file-name nil nil nil
661		      shell-command-switch program)))
662
663(defun mail-source-run-script (script spec &optional delay)
664  (when script
665    (if (functionp script)
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)
701    (mail-source-run-script
702     prescript (format-spec-make ?t path) prescript-delay)
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))))
711      (mail-source-run-script postscript (format-spec-make ?t path))
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))
729		  (read-passwd
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
745	      (require 'pop3)
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)))
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)))))))))
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))
794		  (read-passwd
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
807	      (require 'pop3)
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)))
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)))))))))
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
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
854(defun mail-source-new-mail-p ()
855  "Handler for `display-time' to indicate when new mail is available."
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)))
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
868(eval-when-compile
869  (if (featurep 'xemacs)
870      (require 'timer-funcs)
871    (require 'timer)))
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 ()
882	     (unwind-protect
883		 (mail-source-check-pop mail-source-primary-source)
884	       (setq mail-source-report-new-mail-idle-timer nil)))))
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)
897      (error "Need to set `mail-source-primary-source' to check for new mail"))
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
903	 (nnheader-cancel-timer mail-source-report-new-mail-timer))
904    (and mail-source-report-new-mail-idle-timer
905	 (nnheader-cancel-timer mail-source-report-new-mail-idle-timer))
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)
911	  ;; display-time-mail-function is an Emacs 21 feature.
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
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))
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)
942			      (let ((coding-system-for-write
943				     mm-text-coding-system)
944				    (coding-system-for-read
945				     mm-text-coding-system))
946				(with-temp-file mail-source-crash-box
947				  (insert-file-contents file)
948				  (goto-char (point-min))
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))
956;;;				  (insert "\n\n")
957				  ;; MMDF mail format
958				  (insert "\001\001\001\001\n"))
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")
975  (autoload 'imap-range-to-message-set "imap")
976  (autoload 'nnheader-ms-strip-cr "nnheader"))
977
978(defvar mail-source-imap-file-coding-system 'binary
979  "Coding system for the crashbox made by `mail-source-fetch-imap'.")
980
981(defun mail-source-fetch-imap (source callback)
982  "Fetcher for imap sources."
983  (mail-source-bind (imap source)
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)
988    (let ((from (format "%s:%s:%s" server user port))
989	  (found 0)
990	  (buf (generate-new-buffer " *imap source*"))
991	  (mail-source-string (format "imap:%s:%s" server mailbox))
992	  (imap-shell-program (or (list program) imap-shell-program))
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))
999	  (let ((coding-system-for-write mail-source-imap-file-coding-system)
1000		str)
1001	    (with-temp-file mail-source-crash-box
1002	      ;; Avoid converting 8-bit chars from inserted strings to
1003	      ;; multibyte.
1004	      (mm-disable-multibyte)
1005	      ;; remember password
1006	      (with-current-buffer buf
1007		(when (and imap-password
1008			   (not (assoc from mail-source-password-cache)))
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))
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)))
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)
1027	      (setq remove (nreverse remove))
1028	      (imap-message-flags-add
1029	       (imap-range-to-message-set (gnus-compress-sequence remove))
1030	       fetchflag nil buf))
1031	    (if dontexpunge
1032		(imap-mailbox-unselect buf)
1033	      (imap-mailbox-close nil buf))
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))
1041	(error "IMAP error: %s" (imap-error-text buf)))
1042      (kill-buffer buf)
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))
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
1061		  (cdr (assoc (format "webmail:%s:%s" subtype user)
1062			      mail-source-password-cache))
1063		  (read-passwd
1064		   (format "Password for %s at %s: " user subtype))))
1065	(when (and password
1066		   (not (assoc (format "webmail:%s:%s" subtype user)
1067			       mail-source-password-cache)))
1068	  (push (cons (format "webmail:%s:%s" subtype user) password)
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
1075;;; arch-tag: 72948025-1d17-4d6c-bb12-ef1aa2c490fd
1076;;; mail-source.el ends here
1077