* nnmail.el (nnmail-cache-insert): make sure that the
[gnus] / lisp / mail-source.el
index 73891cd..3f6fe7d 100644 (file)
@@ -1,5 +1,5 @@
 ;;; mail-source.el --- functions for fetching mail
-;; Copyright (C) 1999, 2000, 2001, 2002 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: news, mail
@@ -60,6 +60,7 @@
 This variable is a list of mail source specifiers.
 See Info node `(gnus)Mail Source Specifiers'."
   :group 'mail-source
+  :link '(custom-manual "(gnus)Mail Source Specifiers")
   :type `(repeat
          (choice :format "%[Value Menu%] %v"
                  :value (file)
@@ -83,10 +84,16 @@ See Info node `(gnus)Mail Source Specifiers'."
                                          (function :tag "Predicate"))
                                   (group :inline t
                                          (const :format "" :value :prescript)
-                                         (string :tag "Prescript"))
+                                         (choice :tag "Prescript"
+                                                 :value nil
+                                                 (string :format "%v")
+                                                 (function :format "%v")))
                                   (group :inline t
                                          (const :format "" :value :postscript)
-                                         (string :tag "Postscript"))
+                                         (choice :tag "Postscript"
+                                                 :value nil
+                                                 (string :format "%v")
+                                                 (function :format "%v")))
                                   (group :inline t
                                          (const :format "" :value :plugged)
                                          (boolean :tag "Plugged"))))
@@ -113,10 +120,16 @@ See Info node `(gnus)Mail Source Specifiers'."
                                          (string :tag "Program"))
                                   (group :inline t
                                          (const :format "" :value :prescript)
-                                         (string :tag "Prescript"))
+                                         (choice :tag "Prescript"
+                                                 :value nil
+                                                 (string :format "%v")
+                                                 (function :format "%v")))
                                   (group :inline t
                                          (const :format "" :value :postscript)
-                                         (string :tag "Postscript"))
+                                         (choice :tag "Postscript"
+                                                 :value nil
+                                                 (string :format "%v")
+                                                 (function :format "%v")))
                                   (group :inline t
                                          (const :format "" :value :function)
                                          (function :tag "Function"))
@@ -218,6 +231,11 @@ See Info node `(gnus)Mail Source Specifiers'."
                                          (const :format "" :value :plugged)
                                          (boolean :tag "Plugged")))))))
 
+(defcustom mail-source-ignore-errors nil
+  "*Ignore errors when querying mail sources.
+If nil, the user will be prompted when an error occurs.  If non-nil,
+the error will be ignored.")
+
 (defcustom mail-source-primary-source nil
   "*Primary source for incoming mail.
 If non-nil, this maildrop will be checked periodically for new mail."
@@ -245,7 +263,23 @@ If non-nil, this maildrop will be checked periodically for new mail."
   :type 'integer)
 
 (defcustom mail-source-delete-incoming nil
-  "*If non-nil, delete incoming files after handling."
+  "*If non-nil, delete incoming files after handling.
+If t, delete immediately, if nil, never delete.  If a positive number, delete
+files older than number of days."
+  ;; Note: The removing happens in `mail-source-callback', i.e. no old
+  ;; incoming files will be deleted, unless you receive new mail.
+  ;;
+  ;; You may also set this to `nil' and call `mail-source-delete-old-incoming'
+  ;; from a hook or interactively.
+  :group 'mail-source
+  :type '(choice (const :tag "immediately" t)
+                (const :tag "never" nil)
+                (integer :tag "days")))
+
+(defcustom mail-source-delete-old-incoming-confirm t
+  "*If non-nil, ask for for confirmation before deleting old incoming files.
+This variable only applies when `mail-source-delete-incoming' is a positive
+number."
   :group 'mail-source
   :type 'boolean)
 
@@ -310,7 +344,7 @@ Common keywords should be listed here.")
        (:authentication password))
       (maildir
        (:path (or (getenv "MAILDIR") "~/Maildir/"))
-       (:subdirs ("new" "cur"))
+       (:subdirs ("cur" "new"))
        (:function))
       (imap
        (:server (getenv "MAILHOST"))
@@ -323,6 +357,9 @@ Common keywords should be listed here.")
        (:mailbox "INBOX")
        (:predicate "UNSEEN UNDELETED")
        (:fetchflag "\\Deleted")
+       (:prescript)
+       (:prescript-delay)
+       (:postscript)
        (:dontexpunge))
       (webmail
        (:subtype hotmail)
@@ -463,22 +500,47 @@ Return the number of files that were found."
                 (condition-case err
                     (funcall function source callback)
                   (error
-                   (unless (yes-or-no-p
-                            (format "Mail source error (%s).  Continue? " 
-                                    (cadr err)))
+                   (if (and (not mail-source-ignore-errors)
+                            (not
+                             (yes-or-no-p
+                              (format "Mail source %s error (%s).  Continue? "
+                                      (if (memq ':password source)
+                                          (let ((s (copy-sequence source)))
+                                            (setcar (cdr (memq ':password s)) 
+                                                    "********")
+                                            s)
+                                        source)
+                                      (cadr err)))))
                      (error "Cannot get new mail"))
                    0)))))))))
 
-(eval-and-compile
-  (if (fboundp 'make-temp-file)
-      (defalias 'mail-source-make-complex-temp-name 'make-temp-file)
-    (defun mail-source-make-complex-temp-name (prefix)
-      (let ((newname (make-temp-name prefix))
-           (newprefix prefix))
-       (while (file-exists-p newname)
-         (setq newprefix (concat newprefix "x"))
-         (setq newname (make-temp-name newprefix)))
-       newname))))
+(defun mail-source-delete-old-incoming (&optional age confirm)
+  "Remove incoming files older than AGE days.
+If CONFIRM is non-nil, ask for confirmation before removing a file."
+  (interactive "P")
+  (let* ((high2days (/ 65536.0 60 60 24));; convert high bits to days
+        (low2days  (/ 1.0 65536.0))     ;; convert low bits to days
+        (diff (if (natnump age) age 30));; fallback, if no valid AGE given
+        currday files)
+    (setq files (directory-files
+                mail-source-directory t
+                (concat mail-source-incoming-file-prefix "*"))
+         currday (* (car (current-time)) high2days)
+         currday (+ currday (* low2days (nth 1 (current-time)))))
+    (while files
+      (let* ((ffile (car files))
+            (bfile (gnus-replace-in-string
+                    ffile "\\`.*/\\([^/]+\\)\\'" "\\1"))
+            (filetime (nth 5 (file-attributes ffile)))
+            (fileday (* (car filetime) high2days))
+            (fileday (+ fileday (* low2days (nth 1 filetime)))))
+       (setq files (cdr files))
+       (when (and (> (- currday fileday) diff)
+                  (gnus-message 8 "File `%s' is older than %s day(s)"
+                                bfile diff)
+                  (or (not confirm)
+                      (y-or-n-p (concat "Remove file `" bfile "'? "))))
+         (delete-file ffile))))))
 
 (defun mail-source-callback (callback info)
   "Call CALLBACK on the mail file, and then remove the mail file.
@@ -493,16 +555,21 @@ Pass INFO on to CALLBACK."
        (funcall callback mail-source-crash-box info)
       (when (file-exists-p mail-source-crash-box)
        ;; Delete or move the incoming mail out of the way.
-       (if mail-source-delete-incoming
+       (if (eq mail-source-delete-incoming t)
            (delete-file mail-source-crash-box)
          (let ((incoming
-                (mail-source-make-complex-temp-name
+                (mm-make-temp-file
                  (expand-file-name
                   mail-source-incoming-file-prefix
                   mail-source-directory))))
            (unless (file-exists-p (file-name-directory incoming))
              (make-directory (file-name-directory incoming) t))
-           (rename-file mail-source-crash-box incoming t)))))))
+           (rename-file mail-source-crash-box incoming t)
+           ;; remove old incoming files?
+           (when (natnump mail-source-delete-incoming)
+             (mail-source-delete-old-incoming
+              mail-source-delete-incoming
+              mail-source-delete-old-incoming-confirm))))))))
 
 (defun mail-source-movemail (from to)
   "Move FROM to TO using movemail."
@@ -544,7 +611,8 @@ Pass INFO on to CALLBACK."
                (set-file-modes to mail-source-default-file-modes))
              (if (and (or (not (buffer-modified-p errors))
                           (zerop (buffer-size errors)))
-                      (zerop result))
+                      (and (numberp result)
+                           (zerop result)))
                  ;; No output => movemail won.
                  t
                (set-buffer errors)
@@ -579,29 +647,13 @@ Pass INFO on to CALLBACK."
       (not (zerop (nth 7 (file-attributes from))))
       (delete-file from)))
 
-(defvar mail-source-read-passwd nil)
-(defun mail-source-read-passwd (prompt &rest args)
-  "Read a password using PROMPT.
-If ARGS, PROMPT is used as an argument to `format'."
-  (let ((prompt
-        (if args
-            (apply 'format prompt args)
-          prompt)))
-    (unless mail-source-read-passwd
-      (if (or (fboundp 'read-passwd) (load "passwd" t))
-         (setq mail-source-read-passwd 'read-passwd)
-       (unless (fboundp 'ange-ftp-read-passwd)
-         (autoload 'ange-ftp-read-passwd "ange-ftp"))
-       (setq mail-source-read-passwd 'ange-ftp-read-passwd)))
-    (funcall mail-source-read-passwd prompt)))
-
 (defun mail-source-fetch-with-program (program)
   (zerop (call-process shell-file-name nil nil nil
                       shell-command-switch program)))
 
 (defun mail-source-run-script (script spec &optional delay)
   (when script
-    (if (and (symbolp script) (fboundp script))
+    (if (functionp script)
        (funcall script)
       (mail-source-call-script
        (format-spec script spec))))
@@ -638,8 +690,7 @@ If ARGS, PROMPT is used as an argument to `format'."
   "Fetcher for directory sources."
   (mail-source-bind (directory source)
     (mail-source-run-script
-     prescript (format-spec-make ?t path)
-     prescript-delay)
+     prescript (format-spec-make ?t path) prescript-delay)
     (let ((found 0)
          (mail-source-string (format "directory:%s" path)))
       (dolist (file (directory-files
@@ -648,8 +699,7 @@ If ARGS, PROMPT is used as an argument to `format'."
                   (funcall predicate file)
                   (mail-source-movemail file mail-source-crash-box))
          (incf found (mail-source-callback callback file))))
-      (mail-source-run-script
-       postscript (format-spec-make ?t path))
+      (mail-source-run-script postscript (format-spec-make ?t path))
       found)))
 
 (defun mail-source-fetch-pop (source callback)
@@ -667,7 +717,7 @@ If ARGS, PROMPT is used as an argument to `format'."
        (setq password
              (or password
                  (cdr (assoc from mail-source-password-cache))
-                 (mail-source-read-passwd
+                 (read-passwd
                   (format "Password for %s at %s: " user server)))))
       (when server
        (setenv "MAILHOST" server))
@@ -731,7 +781,7 @@ If ARGS, PROMPT is used as an argument to `format'."
        (setq password
              (or password
                  (cdr (assoc from mail-source-password-cache))
-                 (mail-source-read-passwd
+                 (read-passwd
                   (format "Password for %s at %s: " user server))))
        (unless (assoc from mail-source-password-cache)
          (push (cons from password) mail-source-password-cache)))
@@ -771,6 +821,24 @@ If ARGS, PROMPT is used as an argument to `format'."
                    mail-source-password-cache)))
       result)))
 
+(defun mail-source-touch-pop ()
+  "Open and close a POP connection shortly.
+POP server should be defined in `mail-source-primary-source' (which is
+preferred) or `mail-sources'.  You may use it for the POP-before-SMTP
+authentication.  To do that, you need to set the option
+`message-send-mail-function' to `message-smtpmail-send-it' and put the
+following line in .gnus file:
+
+\(add-hook 'message-send-mail-hook 'mail-source-touch-pop)
+"
+  (let ((sources (if mail-source-primary-source
+                    (list mail-source-primary-source)
+                  mail-sources)))
+    (while sources
+      (if (eq 'pop (car (car sources)))
+         (mail-source-check-pop (car sources)))
+      (setq sources (cdr sources)))))
+
 (defun mail-source-new-mail-p ()
   "Handler for `display-time' to indicate when new mail is available."
   ;; Flash (ie. ring the visible bell) if mail is available.
@@ -901,9 +969,13 @@ This only works when `display-time' is enabled."
 (defun mail-source-fetch-imap (source callback)
   "Fetcher for imap sources."
   (mail-source-bind (imap source)
+    (mail-source-run-script
+     prescript (format-spec-make ?p password ?t mail-source-crash-box
+                                ?s server ?P port ?u user)
+     prescript-delay)
     (let ((from (format "%s:%s:%s" server user port))
          (found 0)
-         (buf (get-buffer-create (generate-new-buffer-name " *imap source*")))
+         (buf (generate-new-buffer " *imap source*"))
          (mail-source-string (format "imap:%s:%s" server mailbox))
          (imap-shell-program (or (list program) imap-shell-program))
          remove)
@@ -940,6 +1012,7 @@ This only works when `display-time' is enabled."
              (nnheader-ms-strip-cr))
            (incf found (mail-source-callback callback server))
            (when (and remove fetchflag)
+             (setq remove (nreverse remove))
              (imap-message-flags-add
               (imap-range-to-message-set (gnus-compress-sequence remove))
               fetchflag nil buf))
@@ -953,8 +1026,12 @@ This only works when `display-time' is enabled."
        (setq mail-source-password-cache
              (delq (assoc from mail-source-password-cache)
                    mail-source-password-cache))
-       (error (imap-error-text buf)))
+       (error "IMAP error: %s" (imap-error-text buf)))
       (kill-buffer buf)
+      (mail-source-run-script
+       postscript
+       (format-spec-make ?p password ?t mail-source-crash-box
+                        ?s server ?P port ?u user))
       found)))
 
 (eval-and-compile
@@ -971,7 +1048,7 @@ This only works when `display-time' is enabled."
              (or password
                  (cdr (assoc (format "webmail:%s:%s" subtype user)
                              mail-source-password-cache))
-                 (mail-source-read-passwd
+                 (read-passwd
                   (format "Password for %s at %s: " user subtype))))
        (when (and password
                   (not (assoc (format "webmail:%s:%s" subtype user)