X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmail-source.el;h=94c3eef79633021a182d0dd252f517a23c4d05a4;hb=aef74cc46d606bb69682a499643bc158186eef00;hp=506fc3d40c89762db4ca45f436f35084b482434b;hpb=178fc161c59aebf50ba3042c6aecb56888cb4d49;p=gnus diff --git a/lisp/mail-source.el b/lisp/mail-source.el index 506fc3d40..94c3eef79 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 @@ -25,21 +25,198 @@ ;;; 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") + (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. +(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) + :type `(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) + (string :tag "Prescript")) + (group :inline t + (const :format "" :value :postscript) + (string :tag "Postscript")) + (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" + (number :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) + (string :tag "Prescript")) + (group :inline t + (const :format "" :value :postscript) + (string :tag "Postscript")) + (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")))) + (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 + number 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-primary-source nil "*Primary source for incoming mail. @@ -47,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) @@ -67,6 +249,11 @@ If non-nil, this maildrop will be checked periodically for new mail." :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 @@ -97,7 +284,7 @@ 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 (:path) (:suffix ".spool") @@ -114,12 +301,14 @@ Common keywords should be listed here.") (:password) (:authentication password)) (maildir - (:path "~/Maildir/new/") + (:path (or (getenv "MAILDIR") "~/Maildir/")) + (:subdirs ("new" "cur")) (:function)) (imap (:server (getenv "MAILHOST")) (:port) (:stream) + (:program) (:authentication) (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER"))) (:password) @@ -266,7 +455,7 @@ Return the number of files that were found." (error (unless (yes-or-no-p (format "Mail source error (%s). Continue? " err)) - (error "Cannot get new mail.")) + (error "Cannot get new mail")) 0)))))))) (defun mail-source-make-complex-temp-name (prefix) @@ -295,7 +484,8 @@ Pass INFO on to CALLBACK." (let ((incoming (mail-source-make-complex-temp-name (expand-file-name - "Incoming" mail-source-directory)))) + 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))))))) @@ -337,7 +527,8 @@ Pass INFO on to CALLBACK." 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 @@ -355,8 +546,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))))))) @@ -390,7 +582,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 @@ -477,7 +669,15 @@ If ARGS, PROMPT is used as an argument to `format'." (pop3-port port) (pop3-authentication-scheme (if (eq authentication 'apop) 'apop 'pass))) - (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) @@ -528,7 +728,15 @@ If ARGS, PROMPT is used as an argument to `format'." (pop3-port port) (pop3-authentication-scheme (if (eq authentication 'apop) 'apop 'pass))) - (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)) @@ -541,6 +749,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) @@ -549,7 +761,10 @@ 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)) +(eval-when-compile + (if (featurep 'xemacs) + (require 'itimer) + (require 'timer))) (defun mail-source-start-idle-timer () ;; Start our idle timer if necessary, so we delay the check until the @@ -560,8 +775,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 @@ -574,25 +790,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)) + (nnheader-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) @@ -606,13 +825,35 @@ This only works when `display-time' is enabled." "Fetcher for maildir sources." (mail-source-bind (maildir source) (let ((found 0) - (mail-source-string (format "maildir:%s" path))) - (dolist (file (directory-files path t)) - (when (and (not (file-directory-p file)) - (not (if function - (funcall function file mail-source-crash-box) - (rename-file file mail-source-crash-box)))) - (incf found (mail-source-callback callback file)))) + mail-source-string) + (unless (string-match "/$" path) + (setq path (concat path "/"))) + (dolist (subdir subdirs) + (when (file-directory-p (concat path subdir)) + (setq mail-source-string (format "maildir:%s%s" path subdir)) + (dolist (file (directory-files (concat path subdir) t)) + (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)) + (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)) +;;; (insert "\n\n") + ;; MMDF mail format + (insert "\001\001\001\001\n")) + (delete-file file))))) + (incf found (mail-source-callback callback file)))))) found))) (eval-and-compile @@ -627,8 +868,12 @@ 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) @@ -636,14 +881,19 @@ 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 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 @@ -663,7 +913,8 @@ This only works when `display-time' is enabled." (incf found (mail-source-callback callback server)) (when (and remove fetchflag) (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)) @@ -690,14 +941,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)))))