X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmail-source.el;h=d9b5ed4696d8ba4c77db528eea780e030e54f22a;hp=be0cea43536acdb93a830641630d5bedb2bc00b5;hb=fe70196e10cdd849981dbd014882fb20237d0740;hpb=562f2c24870c2fde45f147eccdc019c42698b481;ds=sidebyside

diff --git a/lisp/mail-source.el b/lisp/mail-source.el
index be0cea435..d9b5ed469 100644
--- a/lisp/mail-source.el
+++ b/lisp/mail-source.el
@@ -1,5 +1,7 @@
 ;;; mail-source.el --- functions for fetching mail
-;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.
+
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
+;;   2005, 2006, 2007 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: news, mail
@@ -18,28 +20,236 @@
 
 ;; You should have received a copy of the GNU General Public License
 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
 
 ;;; Commentary:
 
 ;;; Code:
 
-(eval-when-compile (require 'cl))
+(eval-when-compile
+  (require 'cl)
+  (require 'imap)
+  (eval-when-compile (defvar display-time-mail-function)))
 (eval-and-compile
   (autoload 'pop3-movemail "pop3")
-  (autoload 'pop3-get-message-count "pop3"))
+  (autoload 'pop3-get-message-count "pop3")
+  (autoload 'nnheader-cancel-timer "nnheader"))
 (require 'format-spec)
+(require 'mm-util)
+(require 'message) ;; for `message-directory'
 
 (defgroup mail-source nil
   "The mail-fetching library."
+  :version "21.1"
   :group 'gnus)
 
+;; Define these at compile time to avoid dragging in imap always.
+(defconst mail-source-imap-authenticators
+  (eval-when-compile
+    (mapcar (lambda (a)
+	      (list 'const (car a)))
+     imap-authenticator-alist)))
+(defconst mail-source-imap-streams
+  (eval-when-compile
+    (mapcar (lambda (a)
+	      (list 'const (car a)))
+     imap-stream-alist)))
+
 (defcustom mail-sources nil
   "*Where the mail backends will look for incoming mail.
-This variable is a list of mail source specifiers."
+This variable is a list of mail source specifiers.
+See Info node `(gnus)Mail Source Specifiers'."
   :group 'mail-source
-  :type 'sexp)
+  :link '(custom-manual "(gnus)Mail Source Specifiers")
+  :type `(choice
+	  (const nil)
+	  (repeat
+	   (choice :format "%[Value Menu%] %v"
+		   :value (file)
+		   (cons :tag "Spool file"
+			 (const :format "" file)
+			 (checklist :tag "Options" :greedy t
+				    (group :inline t
+					   (const :format "" :value :path)
+					   file)))
+		   (cons :tag "Several files in a directory"
+			 (const :format "" directory)
+			 (checklist :tag "Options" :greedy t
+				    (group :inline t
+					   (const :format "" :value :path)
+					   (directory :tag "Path"))
+				    (group :inline t
+					   (const :format "" :value :suffix)
+					   (string :tag "Suffix"))
+				    (group :inline t
+					   (const :format "" :value :predicate)
+					   (function :tag "Predicate"))
+				    (group :inline t
+					   (const :format "" :value :prescript)
+					   (choice :tag "Prescript"
+						   :value nil
+						   (string :format "%v")
+						   (function :format "%v")))
+				    (group :inline t
+					   (const :format "" :value :postscript)
+					   (choice :tag "Postscript"
+						   :value nil
+						   (string :format "%v")
+						   (function :format "%v")))
+				    (group :inline t
+					   (const :format "" :value :plugged)
+					   (boolean :tag "Plugged"))))
+		   (cons :tag "POP3 server"
+			 (const :format "" pop)
+			 (checklist :tag "Options" :greedy t
+				    (group :inline t
+					   (const :format "" :value :server)
+					   (string :tag "Server"))
+				    (group :inline t
+					   (const :format "" :value :port)
+					   (choice :tag "Port"
+						   :value "pop3"
+						   (integer :format "%v")
+						   (string :format "%v")))
+				    (group :inline t
+					   (const :format "" :value :user)
+					   (string :tag "User"))
+				    (group :inline t
+					   (const :format "" :value :password)
+					   (string :tag "Password"))
+				    (group :inline t
+					   (const :format "" :value :program)
+					   (string :tag "Program"))
+				    (group :inline t
+					   (const :format "" :value :prescript)
+					   (choice :tag "Prescript"
+						   :value nil
+						   (string :format "%v")
+						   (function :format "%v")
+						   (const :tag "None" nil)))
+				    (group :inline t
+					   (const :format "" :value :postscript)
+					   (choice :tag "Postscript"
+						   :value nil
+						   (string :format "%v")
+						   (function :format "%v")
+						   (const :tag "None" nil)))
+				    (group :inline t
+					   (const :format "" :value :function)
+					   (function :tag "Function"))
+				    (group :inline t
+					   (const :format ""
+						  :value :authentication)
+					   (choice :tag "Authentication"
+						   :value apop
+						   (const password)
+						   (const apop)))
+				    (group :inline t
+					   (const :format "" :value :plugged)
+					   (boolean :tag "Plugged"))
+				    (group :inline t
+					   (const :format "" :value :stream)
+					   (choice :tag "Stream"
+						   :value nil
+						   (const :tag "Clear" nil)
+						   (const starttls)
+						   (const :tag "SSL/TLS" ssl)))))
+		   (cons :tag "Maildir (qmail, postfix...)"
+			 (const :format "" maildir)
+			 (checklist :tag "Options" :greedy t
+				    (group :inline t
+					   (const :format "" :value :path)
+					   (directory :tag "Path"))
+				    (group :inline t
+					   (const :format "" :value :plugged)
+					   (boolean :tag "Plugged"))))
+		   (cons :tag "IMAP server"
+			 (const :format "" imap)
+			 (checklist :tag "Options" :greedy t
+				    (group :inline t
+					   (const :format "" :value :server)
+					   (string :tag "Server"))
+				    (group :inline t
+					   (const :format "" :value :port)
+					   (choice :tag "Port"
+						   :value 143
+						   integer string))
+				    (group :inline t
+					   (const :format "" :value :user)
+					   (string :tag "User"))
+				    (group :inline t
+					   (const :format "" :value :password)
+					   (string :tag "Password"))
+				    (group :inline t
+					   (const :format "" :value :stream)
+					   (choice :tag "Stream"
+						   :value network
+						   ,@mail-source-imap-streams))
+				    (group :inline t
+					   (const :format "" :value :program)
+					   (string :tag "Program"))
+				    (group :inline t
+					   (const :format ""
+						  :value :authenticator)
+					   (choice :tag "Authenticator"
+						   :value login
+						   ,@mail-source-imap-authenticators))
+				    (group :inline t
+					   (const :format "" :value :mailbox)
+					   (string :tag "Mailbox"
+						   :value "INBOX"))
+				    (group :inline t
+					   (const :format "" :value :predicate)
+					   (string :tag "Predicate"
+						   :value "UNSEEN UNDELETED"))
+				    (group :inline t
+					   (const :format "" :value :fetchflag)
+					   (string :tag "Fetchflag"
+						   :value  "\\Deleted"))
+				    (group :inline t
+					   (const :format ""
+						  :value :dontexpunge)
+					   (boolean :tag "Dontexpunge"))
+				    (group :inline t
+					   (const :format "" :value :plugged)
+					   (boolean :tag "Plugged"))))
+		   (cons :tag "Webmail server"
+			 (const :format "" webmail)
+			 (checklist :tag "Options" :greedy t
+				    (group :inline t
+					  (const :format "" :value :subtype)
+					  ;; Should be generated from
+					  ;; `webmail-type-definition', but we
+					  ;; can't require webmail without W3.
+					  (choice :tag "Subtype"
+						  :value hotmail
+						  (const hotmail)
+						  (const yahoo)
+						  (const netaddress)
+						  (const netscape)
+						  (const my-deja)))
+				    (group :inline t
+					   (const :format "" :value :user)
+					   (string :tag "User"))
+				    (group :inline t
+					   (const :format "" :value :password)
+					   (string :tag "Password"))
+				    (group :inline t
+					   (const :format ""
+						  :value :dontexpunge)
+					   (boolean :tag "Dontexpunge"))
+				    (group :inline t
+					   (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."
+  :version "22.1"
+  :group 'mail-source
+  :type 'boolean)
 
 (defcustom mail-source-primary-source nil
   "*Primary source for incoming mail.
@@ -47,13 +257,18 @@ If non-nil, this maildrop will be checked periodically for new mail."
   :group 'mail-source
   :type 'sexp)
 
+(defcustom mail-source-flash t
+  "*If non-nil, flash periodically when mail is available."
+  :group 'mail-source
+  :type 'boolean)
+
 (defcustom mail-source-crash-box "~/.emacs-mail-crash-box"
   "File where mail will be stored while processing it."
   :group 'mail-source
   :type 'file)
 
-(defcustom mail-source-directory "~/Mail/"
-  "Directory where files (if any) will be stored."
+(defcustom mail-source-directory message-directory
+  "Directory where incoming mail source files (if any) will be stored."
   :group 'mail-source
   :type 'directory)
 
@@ -63,10 +278,32 @@ 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."
+  :version "22.1"
   :group 'mail-source
   :type 'boolean)
 
+(defcustom mail-source-incoming-file-prefix "Incoming"
+  "Prefix for file name for storing incoming mail"
+  :group 'mail-source
+  :type 'string)
+
 (defcustom mail-source-report-new-mail-interval 5
   "Interval in minutes between checks for new mail."
   :group 'mail-source
@@ -77,6 +314,12 @@ If non-nil, this maildrop will be checked periodically for new mail."
   :group 'mail-source
   :type 'number)
 
+(defcustom mail-source-movemail-program nil
+  "If non-nil, name of program for fetching new mail."
+  :version "22.1"
+  :group 'mail-source
+  :type '(choice (const nil) string))
+
 ;;; Internal variables.
 
 (defvar mail-source-string ""
@@ -97,8 +340,11 @@ Common keywords should be listed here.")
        (:prescript-delay)
        (:postscript)
        (:path (or (getenv "MAIL")
-		  (concat "/usr/spool/mail/" (user-login-name)))))
+		  (expand-file-name (user-login-name) rmail-spool-directory))))
       (directory
+       (:prescript)
+       (:prescript-delay)
+       (:postscript)
        (:path)
        (:suffix ".spool")
        (:predicate identity))
@@ -112,21 +358,26 @@ Common keywords should be listed here.")
        (:program)
        (:function)
        (:password)
-       (:authentication password))
+       (:authentication password)
+       (:stream nil))
       (maildir
        (:path (or (getenv "MAILDIR") "~/Maildir/"))
-       (:subdirs ("new" "cur"))
+       (:subdirs ("cur" "new"))
        (:function))
       (imap
        (:server (getenv "MAILHOST"))
        (:port)
        (:stream)
+       (:program)
        (:authentication)
        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
        (:password)
        (:mailbox "INBOX")
        (:predicate "UNSEEN UNDELETED")
        (:fetchflag "\\Deleted")
+       (:prescript)
+       (:prescript-delay)
+       (:postscript)
        (:dontexpunge))
       (webmail
        (:subtype hotmail)
@@ -185,7 +436,7 @@ the `mail-source-keyword-map' variable."
      ,@body))
 
 (put 'mail-source-bind 'lisp-indent-function 1)
-(put 'mail-source-bind 'edebug-form-spec '(form body))
+(put 'mail-source-bind 'edebug-form-spec '(sexp body))
 
 (defun mail-source-set-1 (source)
   (let* ((type (pop source))
@@ -228,7 +479,7 @@ See `mail-source-bind'."
      ,@body))
 
 (put 'mail-source-bind-common 'lisp-indent-function 1)
-(put 'mail-source-bind-common 'edebug-form-spec '(form body))
+(put 'mail-source-bind-common 'edebug-form-spec '(sexp body))
 
 (defun mail-source-value (value)
   "Return the value of VALUE."
@@ -260,46 +511,84 @@ Return the number of files that were found."
 	    (when (file-exists-p mail-source-crash-box)
 	      (message "Processing mail from %s..." mail-source-crash-box)
 	      (setq found (mail-source-callback
-			   callback mail-source-crash-box)))
+			   callback mail-source-crash-box))
+	      (mail-source-delete-crash-box))
 	    (+ found
-	       (condition-case err
+	       (if (or debug-on-quit debug-on-error)
 		   (funcall function source callback)
-		 (error
-		  (unless (yes-or-no-p
-			   (format "Mail source error (%s).  Continue? " err))
-		    (error "Cannot get new mail."))
-		  0))))))))
-
-(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))
+		 (condition-case err
+		     (funcall function source callback)
+		   (error
+		    (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)))))))))
+
+(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.
-Pass INFO on to CALLBACK."
+  "Call CALLBACK on the mail file.  Pass INFO on to CALLBACK."
   (if (or (not (file-exists-p mail-source-crash-box))
 	  (zerop (nth 7 (file-attributes mail-source-crash-box))))
       (progn
 	(when (file-exists-p mail-source-crash-box)
 	  (delete-file mail-source-crash-box))
 	0)
-    (prog1
-	(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
-	    (delete-file mail-source-crash-box)
-	  (let ((incoming
-		 (mail-source-make-complex-temp-name
-		  (expand-file-name
-		   "Incoming" 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)))))))
+    (funcall callback mail-source-crash-box info)))
+
+(defun mail-source-delete-crash-box ()
+  (when (file-exists-p mail-source-crash-box)
+    ;; Delete or move the incoming mail out of the way.
+    (if (eq mail-source-delete-incoming t)
+	(delete-file mail-source-crash-box)
+      (let ((incoming
+	     (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)
+	;; 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."
@@ -334,12 +623,15 @@ Pass INFO on to CALLBACK."
 		       'call-process
 		       (append
 			(list
-			 (expand-file-name "movemail" exec-directory)
+			 (or mail-source-movemail-program
+			     (expand-file-name "movemail" exec-directory))
 			 nil errors nil from to)))))
 	      (when (file-exists-p to)
 		(set-file-modes to mail-source-default-file-modes))
-	      (if (and (not (buffer-modified-p errors))
-		       (zerop result))
+	      (if (and (or (not (buffer-modified-p errors))
+			   (zerop (buffer-size errors)))
+		       (and (numberp result)
+			    (zerop result)))
 		  ;; No output => movemail won.
 		  t
 		(set-buffer errors)
@@ -356,8 +648,9 @@ Pass INFO on to CALLBACK."
 		  (goto-char (point-min))
 		  (when (looking-at "movemail: ")
 		    (delete-region (point-min) (match-end 0)))
+		  ;; Result may be a signal description string.
 		  (unless (yes-or-no-p
-			   (format "movemail: %s (%d return).  Continue? "
+			   (format "movemail: %s (%s return).  Continue? "
 				   (buffer-string) result))
 		    (error "%s" (buffer-string)))
 		  (setq to nil)))))))
@@ -373,29 +666,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)))
+  (eq 0 (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))))
@@ -403,12 +680,20 @@ If ARGS, PROMPT is used as an argument to `format'."
     (sleep-for delay)))
 
 (defun mail-source-call-script (script)
-  (let ((background nil))
+  (let ((background nil)
+	(stderr (get-buffer-create " *mail-source-stderr*"))
+	result)
     (when (string-match "& *$" script)
       (setq script (substring script 0 (match-beginning 0))
 	    background 0))
-    (call-process shell-file-name nil background nil
-		  shell-command-switch script)))
+    (setq result
+	  (call-process shell-file-name nil background nil
+			shell-command-switch script))
+    (when (and result
+	       (not (zerop result)))
+      (set-buffer stderr)
+      (message "Mail source error: %s" (buffer-string)))
+    (kill-buffer stderr)))
 
 ;;;
 ;;; Different fetchers
@@ -425,12 +710,15 @@ If ARGS, PROMPT is used as an argument to `format'."
 	  (prog1
 	      (mail-source-callback callback path)
 	    (mail-source-run-script
-	     postscript (format-spec-make ?t mail-source-crash-box)))
+	     postscript (format-spec-make ?t mail-source-crash-box))
+	    (mail-source-delete-crash-box))
 	0))))
 
 (defun mail-source-fetch-directory (source callback)
   "Fetcher for directory sources."
   (mail-source-bind (directory source)
+    (mail-source-run-script
+     prescript (format-spec-make ?t path) prescript-delay)
     (let ((found 0)
 	  (mail-source-string (format "directory:%s" path)))
       (dolist (file (directory-files
@@ -438,12 +726,15 @@ If ARGS, PROMPT is used as an argument to `format'."
 	(when (and (file-regular-p file)
 		   (funcall predicate file)
 		   (mail-source-movemail file mail-source-crash-box))
-	  (incf found (mail-source-callback callback file))))
+	  (incf found (mail-source-callback callback file))
+	  (mail-source-run-script postscript (format-spec-make ?t path))
+	  (mail-source-delete-crash-box)))
       found)))
 
 (defun mail-source-fetch-pop (source callback)
   "Fetcher for single-file sources."
   (mail-source-bind (pop source)
+    ;; fixme: deal with stream type in format specs
     (mail-source-run-script
      prescript
      (format-spec-make ?p password ?t mail-source-crash-box
@@ -456,7 +747,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))
@@ -472,13 +763,25 @@ If ARGS, PROMPT is used as an argument to `format'."
 	      (funcall function mail-source-crash-box))
 	     ;; The default is to use pop3.el.
 	     (t
+	      (require 'pop3)
 	      (let ((pop3-password password)
 		    (pop3-maildrop user)
 		    (pop3-mailhost server)
 		    (pop3-port port)
 		    (pop3-authentication-scheme
-		     (if (eq authentication 'apop) 'apop 'pass)))
-		(save-excursion (pop3-movemail mail-source-crash-box))))))
+		     (if (eq authentication 'apop) 'apop 'pass))
+		    (pop3-stream-type stream))
+		(if (or debug-on-quit debug-on-error)
+		    (save-excursion (pop3-movemail mail-source-crash-box))
+		  (condition-case err
+		      (save-excursion (pop3-movemail mail-source-crash-box))
+		    (error
+		     ;; We nix out the password in case the error
+		     ;; was because of a wrong password being given.
+		     (setq mail-source-password-cache
+			   (delq (assoc from mail-source-password-cache)
+				 mail-source-password-cache))
+		     (signal (car err) (cdr err)))))))))
       (if result
 	  (progn
 	    (when (eq authentication 'password)
@@ -492,7 +795,8 @@ If ARGS, PROMPT is used as an argument to `format'."
 	      (mail-source-run-script
 	       postscript
 	       (format-spec-make ?p password ?t mail-source-crash-box
-				 ?s server ?P port ?u user))))
+				 ?s server ?P port ?u user))
+	      (mail-source-delete-crash-box)))
 	;; We nix out the password in case the error
 	;; was because of a wrong password being given.
 	(setq mail-source-password-cache
@@ -510,7 +814,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)))
@@ -523,13 +827,24 @@ If ARGS, PROMPT is used as an argument to `format'."
 	     (function)
 	     ;; The default is to use pop3.el.
 	     (t
+	      (require 'pop3)
 	      (let ((pop3-password password)
 		    (pop3-maildrop user)
 		    (pop3-mailhost server)
 		    (pop3-port port)
 		    (pop3-authentication-scheme
 		     (if (eq authentication 'apop) 'apop 'pass)))
-		(save-excursion (pop3-get-message-count))))))
+		(if (or debug-on-quit debug-on-error)
+		    (save-excursion (pop3-get-message-count))
+		  (condition-case err
+		      (save-excursion (pop3-get-message-count))
+		    (error
+		     ;; We nix out the password in case the error
+		     ;; was because of a wrong password being given.
+		     (setq mail-source-password-cache
+			   (delq (assoc from mail-source-password-cache)
+				 mail-source-password-cache))
+		     (signal (car err) (cdr err)))))))))
       (if result
 	  ;; Inform display-time that we have new mail.
 	  (setq mail-source-new-mail-available (> result 0))
@@ -540,8 +855,31 @@ 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
+`message-send-mail-function' variable as `message-smtpmail-send-it'
+and put the following line in your ~/.gnus.el file:
+
+\(add-hook 'message-send-mail-hook 'mail-source-touch-pop)
+
+See the Gnus manual for details."
+  (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.
+  (if (and mail-source-flash mail-source-new-mail-available)
+      (let ((visible-bell t))
+	(ding)))
   ;; Only report flag setting; flag is updated on a different schedule.
   mail-source-new-mail-available)
 
@@ -550,8 +888,6 @@ If ARGS, PROMPT is used as an argument to `format'."
 (defvar mail-source-report-new-mail-timer nil)
 (defvar mail-source-report-new-mail-idle-timer nil)
 
-(eval-when-compile (require 'timer))
-
 (defun mail-source-start-idle-timer ()
   ;; Start our idle timer if necessary, so we delay the check until the
   ;; user isn't typing.
@@ -561,8 +897,9 @@ If ARGS, PROMPT is used as an argument to `format'."
 	   mail-source-idle-time-delay
 	   nil
 	   (lambda ()
-	     (setq mail-source-report-new-mail-idle-timer nil)
-	     (mail-source-check-pop mail-source-primary-source))))
+	     (unwind-protect
+		 (mail-source-check-pop mail-source-primary-source)
+	       (setq mail-source-report-new-mail-idle-timer nil)))))
     ;; Since idle timers created when Emacs is already in the idle
     ;; state don't get activated until Emacs _next_ becomes idle, we
     ;; need to force our timer to be considered active now.  We do
@@ -575,25 +912,28 @@ If ARGS, PROMPT is used as an argument to `format'."
 This only works when `display-time' is enabled."
   (interactive "P")
   (if (not mail-source-primary-source)
-      (error "Need to set `mail-source-primary-source' to check for new mail."))
+      (error "Need to set `mail-source-primary-source' to check for new mail"))
   (let ((on (if (null arg)
 		(not mail-source-report-new-mail)
 	      (> (prefix-numeric-value arg) 0))))
     (setq mail-source-report-new-mail on)
     (and mail-source-report-new-mail-timer
-	 (cancel-timer mail-source-report-new-mail-timer))
+	 (nnheader-cancel-timer mail-source-report-new-mail-timer))
     (and mail-source-report-new-mail-idle-timer
-	 (cancel-timer mail-source-report-new-mail-idle-timer))
+	 (nnheader-cancel-timer mail-source-report-new-mail-idle-timer))
     (setq mail-source-report-new-mail-timer nil)
     (setq mail-source-report-new-mail-idle-timer nil)
     (if on
 	(progn
 	  (require 'time)
+	  ;; display-time-mail-function is an Emacs 21 feature.
 	  (setq display-time-mail-function #'mail-source-new-mail-p)
 	  ;; Set up the main timer.
 	  (setq mail-source-report-new-mail-timer
-		(run-at-time t (* 60 mail-source-report-new-mail-interval)
-			     #'mail-source-start-idle-timer))
+		(run-at-time
+		 (* 60 mail-source-report-new-mail-interval)
+		 (* 60 mail-source-report-new-mail-interval)
+		 #'mail-source-start-idle-timer))
 	  ;; When you get new mail, clear "Mail" from the mode line.
 	  (add-hook 'nnmail-post-get-new-mail-hook
 		    'display-time-event-handler)
@@ -617,22 +957,26 @@ This only works when `display-time' is enabled."
 	    (when (and (not (file-directory-p file))
 		       (not (if function
 				(funcall function file mail-source-crash-box)
-			      (let ((coding-system-for-write 
+			      (let ((coding-system-for-write
 				     mm-text-coding-system)
-				    (coding-system-for-read 
+				    (coding-system-for-read
 				     mm-text-coding-system))
 				(with-temp-file mail-source-crash-box
 				  (insert-file-contents file)
 				  (goto-char (point-min))
-				  (unless (looking-at "\n*From ")
-				    (insert "From maildir " 
-					    (current-time-string) "\n"))
-				  (while (re-search-forward "^From " nil t)
-				    (replace-match ">From "))
-				  (goto-char (point-max))
-				  (insert "\n\n"))
+;;;				  ;; Unix mail format
+;;;				  (unless (looking-at "\n*From ")
+;;;				    (insert "From maildir "
+;;;					    (current-time-string) "\n"))
+;;;				  (while (re-search-forward "^From " nil t)
+;;;				    (replace-match ">From "))
+;;;				  (goto-char (point-max))
+;;;				  (insert "\n\n")
+				  ;; MMDF mail format
+				  (insert "\001\001\001\001\n"))
 				(delete-file file)))))
-	      (incf found (mail-source-callback callback file))))))
+	      (incf found (mail-source-callback callback file))
+	      (mail-source-delete-crash-box)))))
       found)))
 
 (eval-and-compile
@@ -647,46 +991,67 @@ This only works when `display-time' is enabled."
   (autoload 'imap-error-text "imap")
   (autoload 'imap-message-flags-add "imap")
   (autoload 'imap-list-to-message-set "imap")
+  (autoload 'imap-range-to-message-set "imap")
   (autoload 'nnheader-ms-strip-cr "nnheader"))
 
+(defvar mail-source-imap-file-coding-system 'binary
+  "Coding system for the crashbox made by `mail-source-fetch-imap'.")
+
 (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)
       (if (and (imap-open server port stream authentication buf)
 	       (imap-authenticate
 		user (or (cdr (assoc from mail-source-password-cache))
 			 password) buf)
 	       (imap-mailbox-select mailbox nil buf))
-	  (let (str (coding-system-for-write 'binary))
+	  (let ((coding-system-for-write mail-source-imap-file-coding-system)
+		str)
 	    (with-temp-file mail-source-crash-box
+	      ;; Avoid converting 8-bit chars from inserted strings to
+	      ;; multibyte.
+	      (mm-disable-multibyte)
 	      ;; remember password
 	      (with-current-buffer buf
-		(when (or imap-password
-			  (assoc from mail-source-password-cache))
+		(when (and imap-password
+			   (not (assoc from mail-source-password-cache)))
 		  (push (cons from imap-password) mail-source-password-cache)))
 	      ;; if predicate is nil, use all uids
 	      (dolist (uid (imap-search (or predicate "1:*") buf))
-		(when (setq str (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf))
+		(when (setq str
+			    (if (imap-capability 'IMAP4rev1 buf)
+				(caddar (imap-fetch uid "BODY.PEEK[]"
+						    'BODYDETAIL nil buf))
+			      (imap-fetch uid "RFC822.PEEK" 'RFC822 nil buf)))
 		  (push uid remove)
 		  (insert "From imap " (current-time-string) "\n")
 		  (save-excursion
 		    (insert str "\n\n"))
-		  (while (re-search-forward "^From " nil t)
+		  (while (let ((case-fold-search nil))
+			   (re-search-forward "^From " nil t))
 		    (replace-match ">From "))
 		  (goto-char (point-max))))
 	      (nnheader-ms-strip-cr))
 	    (incf found (mail-source-callback callback server))
+	    (mail-source-delete-crash-box)
 	    (when (and remove fetchflag)
+	      (setq remove (nreverse remove))
 	      (imap-message-flags-add
-	       (imap-list-to-message-set remove) fetchflag nil buf))
+	       (imap-range-to-message-set (gnus-compress-sequence remove))
+	       fetchflag nil buf))
 	    (if dontexpunge
 		(imap-mailbox-unselect buf)
-	      (imap-mailbox-close buf))
+	      (imap-mailbox-close nil buf))
 	    (imap-close buf))
 	(imap-close buf)
 	;; We nix out the password in case the error
@@ -694,8 +1059,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
@@ -710,18 +1079,20 @@ This only works when `display-time' is enabled."
       (when (eq authentication 'password)
 	(setq password
 	      (or password
-		  (cdr (assoc (format "webmail:%s:%s" subtype user) 
+		  (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) 
+		   (not (assoc (format "webmail:%s:%s" subtype user)
 			       mail-source-password-cache)))
-	  (push (cons (format "webmail:%s:%s" subtype user) password) 
+	  (push (cons (format "webmail:%s:%s" subtype user) password)
 		mail-source-password-cache)))
       (webmail-fetch mail-source-crash-box subtype user password)
-      (mail-source-callback callback (symbol-name subtype)))))
+      (mail-source-callback callback (symbol-name subtype))
+      (mail-source-delete-crash-box))))
 
 (provide 'mail-source)
 
+;;; arch-tag: 72948025-1d17-4d6c-bb12-ef1aa2c490fd
 ;;; mail-source.el ends here