;;; mail-source.el --- functions for fetching mail
-;; Copyright (C) 1999, 2000, 2001, 2002 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005
+;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news, mail
(eval-and-compile
(autoload 'pop3-movemail "pop3")
(autoload 'pop3-get-message-count "pop3")
- (autoload 'nnheader-cancel-timer "nnheader")
- (autoload 'nnheader-run-at-time "nnheader"))
+ (autoload 'nnheader-cancel-timer "nnheader"))
(require 'format-spec)
(require 'mm-util)
(require 'message) ;; for `message-directory'
(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.
If non-nil, this maildrop will be checked periodically for new mail."
:type 'file)
(defcustom mail-source-directory message-directory
- "Directory where files (if any) will be stored."
+ "Directory where incoming mail source files (if any) will be stored."
:group 'mail-source
:type 'directory)
: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-movemail-program nil
"If non-nil, name of program for fetching new mail."
+ :version "22.1"
:group 'mail-source
:type '(choice (const nil) string))
(:authentication password))
(maildir
(:path (or (getenv "MAILDIR") "~/Maildir/"))
- (:subdirs ("new" "cur"))
+ (:subdirs ("cur" "new"))
(:function))
(imap
(:server (getenv "MAILHOST"))
(:mailbox "INBOX")
(:predicate "UNSEEN UNDELETED")
(:fetchflag "\\Deleted")
+ (:prescript)
+ (:prescript-delay)
+ (:postscript)
(:dontexpunge))
(webmail
(:subtype hotmail)
(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
(if (or debug-on-quit debug-on-error)
(funcall function source callback)
(condition-case err
(funcall function source callback)
(error
- (unless (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)))
+ (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.
-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
- 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)))))))
+ (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."
(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)
(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
(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)
+ prescript (format-spec-make ?t path) prescript-delay)
(let ((found 0)
(mail-source-string (format "directory:%s" path)))
(dolist (file (directory-files
(when (and (file-regular-p file)
(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))
+ (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)
(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))
(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
(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)))
"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:
+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)))
(eval-when-compile
(if (featurep 'xemacs)
- (require 'itimer)
+ (require 'timer-funcs)
(require 'timer)))
(defun mail-source-start-idle-timer ()
(setq display-time-mail-function #'mail-source-new-mail-p)
;; Set up the main timer.
(setq mail-source-report-new-mail-timer
- (nnheader-run-at-time
+ (run-at-time
(* 60 mail-source-report-new-mail-interval)
(* 60 mail-source-report-new-mail-interval)
#'mail-source-start-idle-timer))
;; 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
(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)
(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))
(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-range-to-message-set (gnus-compress-sequence remove))
fetchflag nil buf))
(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
(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)
(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
projects / gnus / blobdiff