X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=lisp%2Fmail-source.el;h=0ae90a86702b635c56efc7d5e4e6513429404d36;hb=3cf1618f34957ba08d8f91bdd552f9408d1d7a0f;hp=982db425ac4f21058b8839cf702c1db5cf202888;hpb=3738187cad20787b5b99c4061256e30e19ee721a;p=elisp%2Fgnus.git- diff --git a/lisp/mail-source.el b/lisp/mail-source.el index 982db42..0ae90a8 100644 --- a/lisp/mail-source.el +++ b/lisp/mail-source.el @@ -1,5 +1,5 @@ ;;; mail-source.el --- functions for fetching mail -;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc. +;; Copyright (C) 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news, mail @@ -28,14 +28,13 @@ (eval-when-compile (require 'cl) (require 'imap) - (eval-when-compile (defvar display-time-mail-function))) -(eval-and-compile + (defvar display-time-mail-function) (autoload 'pop3-movemail "pop3") - (autoload 'pop3-get-message-count "pop3") + (autoload 'pop3-get-message-count "pop3")) +(eval-and-compile (autoload 'nnheader-cancel-timer "nnheader") (autoload 'nnheader-run-at-time "nnheader")) (require 'format-spec) -(require 'mm-util) (require 'message) ;; for `message-directory' (defgroup mail-source nil @@ -48,18 +47,19 @@ (eval-when-compile (mapcar (lambda (a) (list 'const (car a))) - imap-authenticator-alist))) + imap-authenticator-alist))) (defconst mail-source-imap-streams (eval-when-compile (mapcar (lambda (a) (list 'const (car a))) - imap-stream-alist))) + 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. 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 +83,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 +119,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")) @@ -193,17 +205,17 @@ See Info node `(gnus)Mail Source Specifiers'." (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))) + (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")) @@ -218,6 +230,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." @@ -244,8 +261,24 @@ If non-nil, this maildrop will be checked periodically for new mail." :group 'mail-source :type 'integer) -(defcustom mail-source-delete-incoming nil - "*If non-nil, delete incoming files after handling." +(defcustom mail-source-delete-incoming t + "*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) @@ -291,6 +324,9 @@ Common keywords should be listed here.") (:path (or (getenv "MAIL") (expand-file-name (user-login-name) rmail-spool-directory)))) (directory + (:prescript) + (:prescript-delay) + (:postscript) (:path) (:suffix ".spool") (:predicate identity)) @@ -304,7 +340,9 @@ Common keywords should be listed here.") (:program) (:function) (:password) - (:authentication password)) + (:connection) + (:authentication password) + (:leave)) (maildir (:path (or (getenv "MAILDIR") "~/Maildir/")) (:subdirs ("new" "cur")) @@ -378,7 +416,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)) @@ -421,7 +459,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." @@ -460,18 +498,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? " 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))))))))) -(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. @@ -486,16 +553,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." @@ -537,7 +609,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) @@ -572,29 +645,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))) + 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)))) @@ -630,6 +687,8 @@ If ARGS, PROMPT is used as an argument to `format'." (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 @@ -638,6 +697,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)) found))) (defun mail-source-fetch-pop (source callback) @@ -655,7 +715,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)) @@ -671,12 +731,18 @@ 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))) + (if (eq authentication 'apop) 'apop 'pass)) + (pop3-connection-type connection) + (pop3-leave-mail-on-server + (or leave + (and (boundp 'pop3-leave-mail-on-server) + (symbol-value 'pop3-leave-mail-on-server))))) (if (or debug-on-quit debug-on-error) (save-excursion (pop3-movemail mail-source-crash-box)) (condition-case err @@ -719,7 +785,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))) @@ -732,6 +798,7 @@ 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) @@ -759,6 +826,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-send-mail-with-smtp' or +`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. @@ -848,19 +933,23 @@ This only works when `display-time' is enabled." (not (if function (funcall function file mail-source-crash-box) (let ((coding-system-for-write - mm-text-coding-system) + nnheader-text-coding-system) (coding-system-for-read - mm-text-coding-system)) + nnheader-text-coding-system) + (output-coding-system + nnheader-text-coding-system) + (input-coding-system + nnheader-text-coding-system)) (with-temp-file mail-source-crash-box (insert-file-contents file) (goto-char (point-min)) -;;; ;; 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)) +;;; ;; 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")) @@ -880,8 +969,7 @@ 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")) + (autoload 'imap-range-to-message-set "imap")) (defvar mail-source-imap-file-coding-system 'binary "Coding system for the crashbox made by `mail-source-fetch-imap'.") @@ -889,23 +977,25 @@ This only works when `display-time' is enabled." (defun mail-source-fetch-imap (source callback) "Fetcher for imap sources." (mail-source-bind (imap source) - (let ((from (format "%s:%s:%s" server user port)) - (found 0) - (buf (get-buffer-create (generate-new-buffer-name " *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) + (let* ((from (format "%s:%s:%s" server user port)) + (found 0) + (buffer-name " *imap source*") + (buf (get-buffer-create (generate-new-buffer-name buffer-name))) + (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 buffer-name) (imap-authenticate user (or (cdr (assoc from mail-source-password-cache)) password) buf) (imap-mailbox-select mailbox nil buf)) (let ((coding-system-for-write mail-source-imap-file-coding-system) + (output-coding-system 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) + (set-buffer-multibyte nil) ;; remember password (with-current-buffer buf (when (or imap-password @@ -941,7 +1031,7 @@ 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) found))) @@ -959,7 +1049,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)