* mm-encode.el (mm-sign-option, mm-encrypt-option): New user option;

[gnus] / lisp / mail-source.el

diff --git a/lisp/mail-source.el b/lisp/mail-source.el
index 9f9f973..7dbe30b 100644 (file)
--- a/lisp/mail-source.el
+++ b/lisp/mail-source.el
@@ -1,17 +1,17 @@
 ;;; mail-source.el --- functions for fetching mail
 
 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
 ;;; mail-source.el --- functions for fetching mail
 
 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,

-;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;;   2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.

 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: news, mail
 
 ;; This file is part of GNU Emacs.
 
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; 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
 ;; it under the terms of the GNU General Public License as published by

-;; the Free Software Foundation; either version 3, 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
 
 ;; GNU Emacs is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of


@@ -19,9 +19,7 @@
 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License
 ;; 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., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

 
 ;;; Commentary:
 
 
 ;;; Commentary:
 


@@ -35,16 +33,15 @@
 (eval-when-compile
   (require 'cl)
   (require 'imap))
 (eval-when-compile
   (require 'cl)
   (require 'imap))

-(eval-and-compile
-  (autoload 'pop3-movemail "pop3")
-  (autoload 'pop3-get-message-count "pop3")
-  (autoload 'nnheader-cancel-timer "nnheader"))
+(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)
 
 (require 'mm-util)
 (require 'message) ;; for `message-directory'
 
 (defvar display-time-mail-function)
 

-

 (defgroup mail-source nil
   "The mail-fetching library."
   :version "21.1"
 (defgroup mail-source nil
   "The mail-fetching library."
   :version "21.1"


@@ -67,13 +64,15 @@
 This variable is a list of mail source specifiers.
 See Info node `(gnus)Mail Source Specifiers'."
   :group 'mail-source
 This variable is a list of mail source specifiers.
 See Info node `(gnus)Mail Source Specifiers'."
   :group 'mail-source

-  :version "23.0" ;; No Gnus
+  :version "23.1" ;; No Gnus

   :link '(custom-manual "(gnus)Mail Source Specifiers")
   :type `(choice
          (const :tag "None" nil)
          (repeat :tag "List"
           (choice :format "%[Value Menu%] %v"
                   :value (file)
   :link '(custom-manual "(gnus)Mail Source Specifiers")
   :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
                   (cons :tag "Spool file"
                         (const :format "" file)
                         (checklist :tag "Options" :greedy t


@@ -284,25 +283,28 @@ If non-nil, this maildrop will be checked periodically for new mail."
   :group 'mail-source
   :type 'integer)
 
   :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
 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
   :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")))
 
   :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 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."
 This variable only applies when `mail-source-delete-incoming' is a positive
 number."

-  :version "22.1"
+  :version "22.2" ;; No Gnus / Gnus 5.10.10 (default changed)

   :group 'mail-source
   :type 'boolean)
 
   :group 'mail-source
   :type 'boolean)
 


@@ -415,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))))
 
     "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)))
 (eval-and-compile
   (defun mail-source-bind-1 (type)
     (let* ((defaults (cdr (assq type mail-source-keyword-map)))


@@ -433,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.
 
 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
 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."
 
 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))
 
      (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)))
 (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))
     (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)))
       (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 ()
 
 (eval-and-compile
   (defun mail-source-bind-common-1 ()


@@ -495,8 +530,7 @@ See `mail-source-bind'."
    ((stringp value)
     value)
    ;; Function
    ((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
     (eval value))
    ;; Just return the value.
    (t


@@ -550,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
         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
          currday (* (car (current-time)) high2days)
          currday (+ currday (* low2days (nth 1 (current-time)))))
     (while files


@@ -562,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)
             (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)
          (delete-file ffile))))))
 
 (defun mail-source-callback (callback info)


@@ -986,20 +1024,19 @@ This only works when `display-time' is enabled."
              (mail-source-delete-crash-box)))))
       found)))
 
              (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")
 
 
 (autoload 'gnus-compress-sequence "gnus-range")
 


@@ -1079,8 +1116,7 @@ This only works when `display-time' is enabled."
                         ?s server ?P port ?u user))
       found)))
 
                         ?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."
 
 (defun mail-source-fetch-webmail (source callback)
   "Fetch for webmail source."


@@ -1106,5 +1142,5 @@ This only works when `display-time' is enabled."
 
 (provide 'mail-source)
 
 
 (provide 'mail-source)
 

-;;; arch-tag: 72948025-1d17-4d6c-bb12-ef1aa2c490fd
+;; arch-tag: 72948025-1d17-4d6c-bb12-ef1aa2c490fd

 ;;; mail-source.el ends here
 ;;; mail-source.el ends here