X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmail-source.el;h=e2033ef7fcea2d0565ffe2aa076c08acc8178b6f;hb=f5fb31db5f431f309321ffececb8f5f363ced601;hp=e2a954435d16b6c612bcccf8cb8ac328eb7e586b;hpb=8a2e97cacfe486f6049fa39cfd8b3ea9f590adca;p=gnus diff --git a/lisp/mail-source.el b/lisp/mail-source.el index e2a954435..e2033ef7f 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 Free Software Foundation, Inc. +;; Copyright (C) 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news, mail @@ -36,6 +36,7 @@ (autoload 'nnheader-run-at-time "nnheader")) (require 'format-spec) (require 'mm-util) +(require 'message) ;; for `message-directory' (defgroup mail-source nil "The mail-fetching library." @@ -59,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) @@ -82,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")))) @@ -93,12 +101,12 @@ See Info node `(gnus)Mail Source Specifiers'." (const :format "" pop) (checklist :tag "Options" :greedy t (group :inline t - (const :format "" :value :server) + (const :format "" :value :server) (string :tag "Server")) (group :inline t - (const :format "" :value :port) + (const :format "" :value :port) (choice :tag "Port" - :value "pop3" + :value "pop3" (number :format "%v") (string :format "%v"))) (group :inline t @@ -112,15 +120,21 @@ 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")) (group :inline t - (const :format "" + (const :format "" :value :authentication) (choice :tag "Authentication" :value apop @@ -146,8 +160,8 @@ See Info node `(gnus)Mail Source Specifiers'." (string :tag "Server")) (group :inline t (const :format "" :value :port) - (choice :tag "Port" - :value 143 + (choice :tag "Port" + :value 143 number string)) (group :inline t (const :format "" :value :user) @@ -160,6 +174,9 @@ See Info node `(gnus)Mail Source Specifiers'." (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) @@ -172,7 +189,7 @@ See Info node `(gnus)Mail Source Specifiers'." :value "INBOX")) (group :inline t (const :format "" :value :predicate) - (string :tag "Predicate" + (string :tag "Predicate" :value "UNSEEN UNDELETED")) (group :inline t (const :format "" :value :fetchflag) @@ -188,7 +205,7 @@ See Info node `(gnus)Mail Source Specifiers'." (cons :tag "Webmail server" (const :format "" webmail) (checklist :tag "Options" :greedy t - (group :inline t + (group :inline t (const :format "" :value :subtype) ;; Should be generated from ;; `webmail-type-definition', but we @@ -214,18 +231,28 @@ 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." :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/" +(defcustom mail-source-directory message-directory "Directory where files (if any) will be stored." :group 'mail-source :type 'directory) @@ -255,6 +282,11 @@ 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." + :group 'mail-source + :type '(choice (const nil) string)) + ;;; Internal variables. (defvar mail-source-string "" @@ -277,6 +309,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)) @@ -299,6 +334,7 @@ Common keywords should be listed here.") (:server (getenv "MAILHOST")) (:port) (:stream) + (:program) (:authentication) (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER"))) (:password) @@ -363,7 +399,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)) @@ -406,7 +442,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." @@ -440,21 +476,35 @@ Return the number of files that were found." (setq found (mail-source-callback callback mail-source-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))))))))) + +(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-callback (callback info) "Call CALLBACK on the mail file, and then remove the mail file. @@ -513,11 +563,13 @@ 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)) + (if (and (or (not (buffer-modified-p errors)) + (zerop (buffer-size errors))) (zerop result)) ;; No output => movemail won. t @@ -535,8 +587,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))))))) @@ -570,11 +623,11 @@ If ARGS, PROMPT is used as an argument to `format'." (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)))) @@ -610,6 +663,9 @@ 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 @@ -618,6 +674,8 @@ 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) @@ -657,15 +715,17 @@ If ARGS, PROMPT is used as an argument to `format'." (pop3-port port) (pop3-authentication-scheme (if (eq authentication 'apop) 'apop 'pass))) - (condition-case err + (if (or debug-on-quit debug-on-error) (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)))))))) + (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) @@ -716,15 +776,17 @@ If ARGS, PROMPT is used as an argument to `format'." (pop3-port port) (pop3-authentication-scheme (if (eq authentication 'apop) 'apop 'pass))) - (condition-case err + (if (or debug-on-quit debug-on-error) (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)))))))) + (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)) @@ -735,8 +797,30 @@ 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. + (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) @@ -745,7 +829,7 @@ 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 +(eval-when-compile (if (featurep 'xemacs) (require 'itimer) (require 'timer))) @@ -759,8 +843,9 @@ If ARGS, PROMPT is used as an argument to `format'." mail-source-idle-time-delay nil (lambda () - (mail-source-check-pop mail-source-primary-source) - (setq mail-source-report-new-mail-idle-timer nil)))) + (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 @@ -773,7 +858,7 @@ 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)))) @@ -818,20 +903,20 @@ 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)) -;;; ;; 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")) @@ -864,6 +949,7 @@ This only works when `display-time' is enabled." (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) (imap-authenticate @@ -883,7 +969,11 @@ This only works when `display-time' is enabled." (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 @@ -899,7 +989,7 @@ This only works when `display-time' is enabled." 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 @@ -923,14 +1013,14 @@ 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 (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)))))