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