X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmail-source.el;h=6cc9e78f03481dec90aac327fd95bdbc4c43336c;hb=ef8176426ccbbef9c762cd81a43749e1e575f1da;hp=0f3f7a7fb4ec2d073518ef5a9c181d1d484f5bff;hpb=a707b63af25b91cb730c12e65156ca364bf49a44;p=elisp%2Fgnus.git- diff --git a/lisp/mail-source.el b/lisp/mail-source.el index 0f3f7a7..6cc9e78 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 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news, mail @@ -30,15 +30,17 @@ (require 'imap) (eval-when-compile (defvar display-time-mail-function))) (eval-and-compile + (defvar pop3-leave-mail-on-server) (autoload 'pop3-movemail "pop3") (autoload 'pop3-get-message-count "pop3") (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 "The mail-fetching library." + :version "21.1" :group 'gnus) ;; Define these at compile time to avoid dragging in imap always. @@ -46,12 +48,12 @@ (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. @@ -92,12 +94,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 @@ -119,7 +121,7 @@ See Info node `(gnus)Mail Source Specifiers'." (const :format "" :value :function) (function :tag "Function")) (group :inline t - (const :format "" + (const :format "" :value :authentication) (choice :tag "Authentication" :value apop @@ -145,8 +147,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 +162,9 @@ See Info node `(gnus)Mail Source Specifiers'." :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" @@ -171,7 +176,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) @@ -187,18 +192,18 @@ See Info node `(gnus)Mail Source Specifiers'." (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 :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")) @@ -219,12 +224,17 @@ 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) @@ -234,7 +244,7 @@ If non-nil, this maildrop will be checked periodically for new mail." :group 'mail-source :type 'integer) -(defcustom mail-source-delete-incoming t +(defcustom mail-source-delete-incoming nil "*If non-nil, delete incoming files after handling." :group 'mail-source :type 'boolean) @@ -254,6 +264,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 "" @@ -289,7 +304,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")) @@ -298,6 +315,7 @@ Common keywords should be listed here.") (:server (getenv "MAILHOST")) (:port) (:stream) + (:program) (:authentication) (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER"))) (:password) @@ -439,13 +457,15 @@ 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)))))))) + (condition-case err + (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)) @@ -512,11 +532,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 @@ -534,8 +556,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))))))) @@ -569,7 +592,7 @@ 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 @@ -655,16 +678,23 @@ If ARGS, PROMPT is used as an argument to `format'." (pop3-mailhost server) (pop3-port port) (pop3-authentication-scheme - (if (eq authentication 'apop) 'apop 'pass))) - (condition-case err + (if (eq authentication 'apop) 'apop 'pass)) + (pop3-connection-type connection) + (pop3-leave-mail-on-server + (or leave + (and (boundp 'pop3-leave-mail-on-server) + pop3-leave-mail-on-server)))) + (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) @@ -715,15 +745,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)) @@ -736,6 +768,10 @@ If ARGS, PROMPT is used as an argument to `format'." (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) @@ -744,7 +780,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))) @@ -758,8 +794,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 @@ -772,7 +809,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)))) @@ -817,20 +854,24 @@ 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 - mm-text-coding-system) - (coding-system-for-read - mm-text-coding-system)) + (let ((coding-system-for-write + nnheader-text-coding-system) + (coding-system-for-read + 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")) @@ -850,8 +891,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'.") @@ -861,8 +901,10 @@ This only works when `display-time' is enabled." (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*"))) + (buf (get-buffer-create + (format " *imap source %s:%s:%s *" server user mailbox))) (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 @@ -870,11 +912,12 @@ This only works when `display-time' is enabled." 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 @@ -882,7 +925,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 @@ -898,7 +945,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 @@ -922,14 +969,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)))))