X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmail-source.el;h=7dbe30b91d8626d67f5cfa541f472929736f22dc;hb=d61550e80bccf607ec141be5a25df88fa8f4ac8e;hp=b40163c4d4095e187041399c5425d0a3654d1862;hpb=0fd27ffa960ebecdc1a624050d41021119da8df2;p=gnus diff --git a/lisp/mail-source.el b/lisp/mail-source.el index b40163c4d..7dbe30b91 100644 --- a/lisp/mail-source.el +++ b/lisp/mail-source.el @@ -1,16 +1,17 @@ ;;; mail-source.el --- functions for fetching mail -;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004 -;; Free Software Foundation, Inc. + +;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, +;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news, mail ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -18,26 +19,29 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: ;;; Code: -(eval-when-compile - (require 'cl) - (require 'imap) - (eval-when-compile (defvar display-time-mail-function))) +;; For Emacs < 22.2. (eval-and-compile - (autoload 'pop3-movemail "pop3") - (autoload 'pop3-get-message-count "pop3") - (autoload 'nnheader-cancel-timer "nnheader")) + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + (require 'format-spec) +(eval-when-compile + (require 'cl) + (require 'imap)) +(autoload 'auth-source-user-or-password "auth-source") +(autoload 'pop3-movemail "pop3") +(autoload 'pop3-get-message-count "pop3") +(autoload 'nnheader-cancel-timer "nnheader") (require 'mm-util) (require 'message) ;; for `message-directory' +(defvar display-time-mail-function) + (defgroup mail-source nil "The mail-fetching library." :version "21.1" @@ -55,187 +59,201 @@ (list 'const (car a))) imap-stream-alist))) -(defcustom mail-sources nil - "*Where the mail backends will look for incoming mail. +(defcustom mail-sources '((file)) + "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 + :version "23.1" ;; No Gnus :link '(custom-manual "(gnus)Mail Source Specifiers") - :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) - (choice :tag "Prescript" - :value nil - (string :format "%v") - (function :format "%v"))) - (group :inline t - (const :format "" :value :postscript) - (choice :tag "Postscript" - :value nil - (string :format "%v") - (function :format "%v"))) - (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) - (choice :tag "Prescript" - :value nil - (string :format "%v") - (function :format "%v"))) - (group :inline t - (const :format "" :value :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 "" - :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"))))))) + :type `(choice + (const :tag "None" nil) + (repeat :tag "List" + (choice :format "%[Value Menu%] %v" + :value (file) + (cons :tag "Group parameter `mail-source'" + (const :format "" group)) + (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) + (choice :tag "Prescript" + :value nil + (string :format "%v") + (function :format "%v"))) + (group :inline t + (const :format "" :value :postscript) + (choice :tag "Postscript" + :value nil + (string :format "%v") + (function :format "%v"))) + (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" + (integer :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) + (choice :tag "Prescript" + :value nil + (string :format "%v") + (function :format "%v") + (const :tag "None" nil))) + (group :inline t + (const :format "" :value :postscript) + (choice :tag "Postscript" + :value nil + (string :format "%v") + (function :format "%v") + (const :tag "None" nil))) + (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")) + (group :inline t + (const :format "" :value :stream) + (choice :tag "Stream" + :value nil + (const :tag "Clear" nil) + (const starttls) + (const :tag "SSL/TLS" ssl))))) + (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 + integer 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-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 "21.4" + :version "22.1" :group 'mail-source :type 'boolean) @@ -265,25 +283,28 @@ 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 + 10 ;; development versions + ;; 2 ;; released versions + "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. +files older than number of days. + +Removing of old files happens in `mail-source-callback', i.e. no +old incoming files will be deleted unless you receive new mail. +You may also set this variable to nil and call +`mail-source-delete-old-incoming' interactively." :group 'mail-source + :version "22.2" ;; No Gnus / Gnus 5.10.10 (default changed) :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. +(defcustom mail-source-delete-old-incoming-confirm nil + "If non-nil, ask for confirmation before deleting old incoming files. This variable only applies when `mail-source-delete-incoming' is a positive number." - :version "21.4" + :version "22.2" ;; No Gnus / Gnus 5.10.10 (default changed) :group 'mail-source :type 'boolean) @@ -304,7 +325,7 @@ number." (defcustom mail-source-movemail-program nil "If non-nil, name of program for fetching new mail." - :version "21.4" + :version "22.1" :group 'mail-source :type '(choice (const nil) string)) @@ -346,7 +367,8 @@ Common keywords should be listed here.") (:program) (:function) (:password) - (:authentication password)) + (:authentication password) + (:stream nil)) (maildir (:path (or (getenv "MAILDIR") "~/Maildir/")) (:subdirs ("cur" "new")) @@ -395,6 +417,8 @@ All keywords that can be used must be listed here.")) "Strip the leading colon off the KEYWORD." (intern (substring (symbol-name keyword) 1)))) +;; generate a list of variable names paired with nil values +;; suitable for usage in a `let' form (eval-and-compile (defun mail-source-bind-1 (type) (let* ((defaults (cdr (assq type mail-source-keyword-map))) @@ -413,27 +437,58 @@ At run time, the mail source specifier SOURCE will be inspected, and the variables will be set according to it. Variables not specified will be given default values. +The user and password will be loaded from the auth-source values +if those are available. They override the original user and +password in a second `let' form. + After this is done, BODY will be executed in the scope -of the `let' form. +of the second `let' form. The variables bound and their default values are described by the `mail-source-keyword-map' variable." - `(let ,(mail-source-bind-1 (car type-source)) + `(let* ,(mail-source-bind-1 (car type-source)) (mail-source-set-1 ,(cadr type-source)) ,@body)) (put 'mail-source-bind 'lisp-indent-function 1) (put 'mail-source-bind 'edebug-form-spec '(sexp body)) +;; TODO: use the list format for auth-source-user-or-password modes (defun mail-source-set-1 (source) (let* ((type (pop source)) (defaults (cdr (assq type mail-source-keyword-map))) - default value keyword) + default value keyword auth-info user-auth pass-auth) (while (setq default (pop defaults)) + ;; for each default :SYMBOL, set SYMBOL to the plist value for :SYMBOL + ;; using `mail-source-value' to evaluate the plist value (set (mail-source-strip-keyword (setq keyword (car default))) - (if (setq value (plist-get source keyword)) - (mail-source-value value) - (mail-source-value (cadr default))))))) + ;; note the following reasons for this structure: + ;; 1) the auth-sources user and password override everything + ;; 2) it avoids macros, so it's cleaner + ;; 3) it falls through to the mail-sources and then default values + (cond + ((and + (eq keyword :user) + (setq user-auth + (nth 0 (auth-source-user-or-password + '("login" "password") + ;; this is "host" in auth-sources + (if (boundp 'server) (symbol-value 'server) "") + type)))) + user-auth) + ((and + (eq keyword :password) + (setq pass-auth + (nth 1 + (auth-source-user-or-password + '("login" "password") + ;; this is "host" in auth-sources + (if (boundp 'server) (symbol-value 'server) "") + type)))) + pass-auth) + (t (if (setq value (plist-get source keyword)) + (mail-source-value value) + (mail-source-value (cadr default))))))))) (eval-and-compile (defun mail-source-bind-common-1 () @@ -475,8 +530,7 @@ See `mail-source-bind'." ((stringp value) value) ;; Function - ((and (listp value) - (functionp (car value))) + ((and (listp value) (symbolp (car value)) (fboundp (car value))) (eval value)) ;; Just return the value. (t @@ -512,7 +566,7 @@ Return the number of files that were found." (format "Mail source %s error (%s). Continue? " (if (memq ':password source) (let ((s (copy-sequence source))) - (setcar (cdr (memq ':password s)) + (setcar (cdr (memq ':password s)) "********") s) source) @@ -530,7 +584,8 @@ If CONFIRM is non-nil, ask for confirmation before removing a file." currday files) (setq files (directory-files mail-source-directory t - (concat mail-source-incoming-file-prefix "*")) + (concat "\\`" + (regexp-quote mail-source-incoming-file-prefix))) currday (* (car (current-time)) high2days) currday (+ currday (* low2days (nth 1 (current-time))))) (while files @@ -542,10 +597,13 @@ If CONFIRM is non-nil, ask for confirmation before removing a file." (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 "'? ")))) + (if confirm + (y-or-n-p + (format "\ +Delete old (> %s day(s)) incoming mail file `%s'? " diff bfile)) + (gnus-message 8 "\ +Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) + t)) (delete-file ffile)))))) (defun mail-source-callback (callback info) @@ -667,12 +725,20 @@ If CONFIRM is non-nil, ask for confirmation before removing a file." (sleep-for delay))) (defun mail-source-call-script (script) - (let ((background nil)) + (let ((background nil) + (stderr (get-buffer-create " *mail-source-stderr*")) + result) (when (string-match "& *$" script) (setq script (substring script 0 (match-beginning 0)) background 0)) - (call-process shell-file-name nil background nil - shell-command-switch script))) + (setq result + (call-process shell-file-name nil background nil + shell-command-switch script)) + (when (and result + (not (zerop result))) + (set-buffer stderr) + (message "Mail source error: %s" (buffer-string))) + (kill-buffer stderr))) ;;; ;;; Different fetchers @@ -713,6 +779,7 @@ If CONFIRM is non-nil, ask for confirmation before removing a file." (defun mail-source-fetch-pop (source callback) "Fetcher for single-file sources." (mail-source-bind (pop source) + ;; fixme: deal with stream type in format specs (mail-source-run-script prescript (format-spec-make ?p password ?t mail-source-crash-box @@ -741,12 +808,14 @@ If CONFIRM is non-nil, ask for confirmation before removing a file." (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-stream-type stream)) (if (or debug-on-quit debug-on-error) (save-excursion (pop3-movemail mail-source-crash-box)) (condition-case err @@ -803,6 +872,7 @@ If CONFIRM is non-nil, ask for confirmation before removing a file." (function) ;; The default is to use pop3.el. (t + (require 'pop3) (let ((pop3-password password) (pop3-maildrop user) (pop3-mailhost server) @@ -863,11 +933,6 @@ See the Gnus manual for details." (defvar mail-source-report-new-mail-timer nil) (defvar mail-source-report-new-mail-idle-timer nil) -(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 ;; user isn't typing. @@ -959,24 +1024,28 @@ This only works when `display-time' is enabled." (mail-source-delete-crash-box))))) found))) -(eval-and-compile - (autoload 'imap-open "imap") - (autoload 'imap-authenticate "imap") - (autoload 'imap-mailbox-select "imap") - (autoload 'imap-mailbox-unselect "imap") - (autoload 'imap-mailbox-close "imap") - (autoload 'imap-search "imap") - (autoload 'imap-fetch "imap") - (autoload 'imap-close "imap") - (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-open "imap") +(autoload 'imap-authenticate "imap") +(autoload 'imap-mailbox-select "imap") +(autoload 'imap-mailbox-unselect "imap") +(autoload 'imap-mailbox-close "imap") +(autoload 'imap-search "imap") +(autoload 'imap-fetch "imap") +(autoload 'imap-close "imap") +(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 'gnus-compress-sequence "gnus-range") (defvar mail-source-imap-file-coding-system 'binary "Coding system for the crashbox made by `mail-source-fetch-imap'.") +;; Autoloads will bring in imap before this is called. +(declare-function imap-capability "imap" (&optional identifier buffer)) + (defun mail-source-fetch-imap (source callback) "Fetcher for imap sources." (mail-source-bind (imap source) @@ -1017,7 +1086,8 @@ This only works when `display-time' is enabled." (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)) @@ -1046,8 +1116,7 @@ This only works when `display-time' is enabled." ?s server ?P port ?u user)) found))) -(eval-and-compile - (autoload 'webmail-fetch "webmail")) +(autoload 'webmail-fetch "webmail") (defun mail-source-fetch-webmail (source callback) "Fetch for webmail source." @@ -1073,5 +1142,5 @@ This only works when `display-time' is enabled." (provide 'mail-source) -;;; arch-tag: 72948025-1d17-4d6c-bb12-ef1aa2c490fd +;; arch-tag: 72948025-1d17-4d6c-bb12-ef1aa2c490fd ;;; mail-source.el ends here