Mail-source supports common parameters and plugged.

[gnus] / lisp / mail-source.el

diff --git a/lisp/mail-source.el b/lisp/mail-source.el
index e8516d0..7de5354 100644 (file)
--- a/lisp/mail-source.el
+++ b/lisp/mail-source.el
@@ -55,7 +55,7 @@ This variable is a list of mail source specifiers."
   :group 'mail-source
   :type 'integer)
 
-(defcustom mail-source-delete-incoming nil
+(defcustom mail-source-delete-incoming t
   "*If non-nil, delete incoming files after handling."
   :group 'mail-source
   :type 'boolean)
@@ -66,6 +66,11 @@ This variable is a list of mail source specifiers."
   "A dynamically bound string that says what the current mail source is.")
 
 (eval-and-compile
+  (defvar mail-source-common-keyword-map
+    '((:plugged))
+    "Mapping from keywords to default values.
+Common keywords should be listed here.")
+
   (defvar mail-source-keyword-map
     '((file
        (:prescript)
@@ -101,7 +106,12 @@ This variable is a list of mail source specifiers."
        (:mailbox "INBOX")
        (:predicate "UNSEEN UNDELETED")
        (:fetchflag "\Deleted")
-       (:dontexpunge)))
+       (:dontexpunge))
+      (webmail
+       (:subtype hotmail)
+       (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
+       (:password)
+       (:authentication password)))
     "Mapping from keywords to default values.
 All keywords that can be used must be listed here."))
 
@@ -110,11 +120,14 @@ All keywords that can be used must be listed here."))
     (directory mail-source-fetch-directory)
     (pop mail-source-fetch-pop)
     (maildir mail-source-fetch-maildir)
-    (imap mail-source-fetch-imap))
+    (imap mail-source-fetch-imap)
+    (webmail mail-source-fetch-webmail))
   "A mapping from source type to fetcher function.")
 
 (defvar mail-source-password-cache nil)
 
+(defvar mail-source-plugged t)
+
 ;;; Functions
 
 (eval-and-compile
@@ -162,6 +175,39 @@ the `mail-source-keyword-map' variable."
               (mail-source-value value)
             (mail-source-value (cadr default)))))))
 
+(eval-and-compile
+  (defun mail-source-bind-common-1 ()
+    (let* ((defaults mail-source-common-keyword-map)
+          default bind)
+      (while (setq default (pop defaults))
+       (push (list (mail-source-strip-keyword (car default))
+                   nil)
+             bind))
+      bind)))
+
+(defun mail-source-set-common-1 (source)
+  (let* ((type (pop source))
+        (defaults mail-source-common-keyword-map)
+        (defaults-1 (cdr (assq type mail-source-keyword-map)))
+        default value keyword)
+    (while (setq default (pop defaults))
+      (set (mail-source-strip-keyword (setq keyword (car default)))
+          (if (setq value (plist-get source keyword))
+              (mail-source-value value)
+            (if (setq value (plist-get defaults-1 keyword))
+                (mail-source-value value)
+              (mail-source-value (cadr default))))))))
+
+(defmacro mail-source-bind-common (source &rest body)
+  "Return a `let' form that binds all common variables.
+See `mail-source-bind'."
+  `(let ,(mail-source-bind-common-1)
+     (mail-source-set-common-1 source)
+     ,@body))
+
+(put 'mail-source-bind-common 'lisp-indent-function 1)
+(put 'mail-source-bind-common 'edebug-form-spec '(form body))
+
 (defun mail-source-value (value)
   "Return the value of VALUE."
   (cond
@@ -181,24 +227,26 @@ the `mail-source-keyword-map' variable."
 CALLBACK will be called with the name of the file where (some of)
 the mail from SOURCE is put.
 Return the number of files that were found."
-  (save-excursion
-    (let ((function (cadr (assq (car source) mail-source-fetcher-alist)))
-         (found 0))
-      (unless function
-       (error "%S is an invalid mail source specification" source))
-      ;; If there's anything in the crash box, we do it first.
-      (when (file-exists-p mail-source-crash-box)
-       (message "Processing mail from %s..." mail-source-crash-box)
-       (setq found (mail-source-callback
-                     callback mail-source-crash-box)))
-      (+ found
-         (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))))))
+  (mail-source-bind-common source
+    (if (or mail-source-plugged plugged)
+       (save-excursion
+         (let ((function (cadr (assq (car source) mail-source-fetcher-alist)))
+               (found 0))
+           (unless function
+             (error "%S is an invalid mail source specification" source))
+           ;; If there's anything in the crash box, we do it first.
+           (when (file-exists-p mail-source-crash-box)
+             (message "Processing mail from %s..." mail-source-crash-box)
+             (setq found (mail-source-callback
+                          callback mail-source-crash-box)))
+           (+ found
+              (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))
@@ -433,7 +481,7 @@ If ARGS, PROMPT is used as an argument to `format'."
     (let ((found 0)
          (mail-source-string (format "maildir:%s" path)))
       (dolist (file (directory-files path t))
-       (when (and (file-regular-p file)
+       (when (and (not (file-directory-p file))
                   (not (if function
                            (funcall function file mail-source-crash-box)
                          (rename-file file mail-source-crash-box))))
@@ -490,6 +538,20 @@ If ARGS, PROMPT is used as an argument to `format'."
       (kill-buffer buf)
       found)))
 
+(eval-and-compile
+  (autoload 'webmail-fetch "webmail"))
+
+(defun mail-source-fetch-webmail (source callback)
+  "Fetch for webmail source."
+  (mail-source-bind (webmail source)
+    (when (eq authentication 'password)
+      (setq password
+           (or password
+               (mail-source-read-passwd
+                (format "Password for %s at %s: " user subtype)))))
+    (webmail-fetch mail-source-crash-box subtype user password)
+    (mail-source-callback callback (symbol-name subtype))))
+
 (provide 'mail-source)
 
 ;;; mail-source.el ends here