X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmail-source.el;h=f4a9e191010f0264b1135b8351f8539cc2d5b36b;hp=f98c195eada1a40719933a096a6b535626dfdd79;hb=HEAD;hpb=4c2a7a1c25d5b10316f35f28c972ef3e70225f25

diff --git a/lisp/mail-source.el b/lisp/mail-source.el
index f98c195ea..f4a9e1910 100644
--- a/lisp/mail-source.el
+++ b/lisp/mail-source.el
@@ -1,6 +1,6 @@
 ;;; mail-source.el --- functions for fetching mail
 
-;; Copyright (C) 1999-2011  Free Software Foundation, Inc.
+;; Copyright (C) 1999-2016 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: news, mail
@@ -24,15 +24,11 @@
 
 ;;; Code:
 
-;; For Emacs <22.2 and XEmacs.
-(eval-and-compile
-  (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 'auth-source-search "auth-source")
 (autoload 'pop3-movemail "pop3")
 (autoload 'pop3-get-message-count "pop3")
 (autoload 'nnheader-cancel-timer "nnheader")
@@ -63,7 +59,7 @@
 This variable is a list of mail source specifiers.
 See Info node `(gnus)Mail Source Specifiers'."
   :group 'mail-source
-  :version "23.1" ;; No Gnus
+  :version "24.4"
   :link '(custom-manual "(gnus)Mail Source Specifiers")
   :type `(choice
 	  (const :tag "None" nil)
@@ -159,7 +155,18 @@ See Info node `(gnus)Mail Source Specifiers'."
 						   :value nil
 						   (const :tag "Clear" nil)
 						   (const starttls)
-						   (const :tag "SSL/TLS" ssl)))))
+						   (const :tag "SSL/TLS" ssl)))
+				    (group :inline t
+					   (const :format "" :value :leave)
+					   (choice :format "\
+%{Leave mail on server%}:\n\t\t%[Value Menu%] %v"
+						   :value nil
+						   (const :tag "\
+Don't leave mails" nil)
+						   (const :tag "\
+Leave all mails" t)
+						   (number :tag "\
+Leave mails for this many days" :value 14)))))
 		   (cons :tag "Maildir (qmail, postfix...)"
 			 (const :format "" maildir)
 			 (checklist :tag "Options" :greedy t
@@ -332,6 +339,7 @@ Common keywords should be listed here.")
        (:prescript)
        (:prescript-delay)
        (:postscript)
+       ;; note server and port need to come before user and password
        (:server (getenv "MAILHOST"))
        (:port 110)
        (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
@@ -339,12 +347,14 @@ Common keywords should be listed here.")
        (:function)
        (:password)
        (:authentication password)
-       (:stream nil))
+       (:stream nil)
+       (:leave))
       (maildir
        (:path (or (getenv "MAILDIR") "~/Maildir/"))
        (:subdirs ("cur" "new"))
        (:function))
       (imap
+       ;; note server and port need to come before user and password
        (:server (getenv "MAILHOST"))
        (:port)
        (:stream)
@@ -417,42 +427,66 @@ the `mail-source-keyword-map' variable."
 (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 auth-info user-auth pass-auth)
+         (defaults (cdr (assq type mail-source-keyword-map)))
+         (search '(:max 1))
+         found default value keyword auth-info user-auth pass-auth)
+
+    ;; append to the search the useful info from the source and the defaults:
+    ;; user, host, and port
+
+    ;; the msname is the mail-source parameter
+    (dolist (msname '(:server :user :port))
+      ;; the asname is the auth-source parameter
+      (let* ((asname (case msname
+                       (:server :host)  ; auth-source uses :host
+                       (t msname)))
+             ;; this is the mail-source default
+             (msdef1 (or (plist-get source msname)
+                         (nth 1 (assoc msname defaults))))
+             ;; ...evaluated
+             (msdef (mail-source-value msdef1)))
+        (setq search (append (list asname
+                                   (if msdef msdef t))
+                             search))))
+    ;; if the port is unknown yet, get it from the mail-source type
+    (unless (plist-get search :port)
+      (setq search (append (list :port (symbol-name type)))))
+
     (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)))
-	   ;; 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)))))))))
+           ;; 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 (plist-get
+                              ;; cache the search result in `found'
+                              (or found
+                                  (setq found (nth 0 (apply 'auth-source-search
+                                                            search))))
+                              :user)))
+             user-auth)
+            ((and
+              (eq keyword :password)
+              (setq pass-auth (plist-get
+                               ;; cache the search result in `found'
+                               (or found
+                                   (setq found (nth 0 (apply 'auth-source-search
+                                                             search))))
+                               :secret)))
+             ;; maybe set the password to the return of the :secret function
+             (if (functionp pass-auth)
+                 (setq pass-auth (funcall pass-auth))
+               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 ()
@@ -578,7 +612,7 @@ If CONFIRM is non-nil, ask for confirmation before removing a file."
 	(when (and (> (- currday fileday) diff)
 		   (if confirm
 		       (y-or-n-p
-			(format "\
+			(gnus-format-message "\
 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)
@@ -695,12 +729,6 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
       ;; Return whether we moved successfully or not.
       to)))
 
-(defun mail-source-movemail-and-remove (from to)
-  "Move FROM to TO using movemail, then remove FROM if empty."
-  (or (not (mail-source-movemail from to))
-      (not (zerop (nth 7 (file-attributes from))))
-      (delete-file from)))
-
 (defun mail-source-fetch-with-program (program)
   (eq 0 (call-process shell-file-name nil nil nil
 		      shell-command-switch program)))
@@ -722,13 +750,16 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
       (setq script (substring script 0 (match-beginning 0))
 	    background 0))
     (setq result
-	  (call-process shell-file-name nil background nil
+	  (call-process shell-file-name nil stderr nil
 			shell-command-switch script))
-    (when (and result
-	       (not (zerop result)))
-      (set-buffer stderr)
-      (message "Mail source error: %s" (buffer-string)))
-    (kill-buffer stderr)))
+    (if (and result
+             (not (zerop result)))
+        (progn
+          (split-window-vertically)
+          (other-window 1)
+          (switch-to-buffer stderr)
+          (message "Mail source error: %s " (buffer-string)))
+      (kill-buffer stderr))))
 
 ;;;
 ;;; Different fetchers
@@ -777,6 +808,10 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
      prescript-delay)
     (let ((from (format "%s:%s:%s" server user port))
 	  (mail-source-string (format "pop:%s@%s" user server))
+	  (process-environment (if server
+				   (cons (concat "MAILHOST=" server)
+					 process-environment)
+				 process-environment))
 	  result)
       (when (eq authentication 'password)
 	(setq password
@@ -784,8 +819,6 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
 		  (cdr (assoc from mail-source-password-cache))
 		  (read-passwd
 		   (format "Password for %s at %s: " user server)))))
-      (when server
-	(setenv "MAILHOST" server))
       (setq result
 	    (cond
 	     (program
@@ -805,7 +838,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
 		    (pop3-port port)
 		    (pop3-authentication-scheme
 		     (if (eq authentication 'apop) 'apop 'pass))
-		    (pop3-stream-type stream))
+		    (pop3-stream-type stream)
+		    (pop3-leave-mail-on-server leave))
 		(if (or debug-on-quit debug-on-error)
 		    (save-excursion (pop3-movemail mail-source-crash-box))
 		  (condition-case err
@@ -844,6 +878,10 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
   (mail-source-bind (pop source)
     (let ((from (format "%s:%s:%s" server user port))
 	  (mail-source-string (format "pop:%s@%s" user server))
+	  (process-environment (if server
+				   (cons (concat "MAILHOST=" server)
+					 process-environment)
+				 process-environment))
 	  result)
       (when (eq authentication 'password)
 	(setq password
@@ -853,8 +891,6 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile)
 		   (format "Password for %s at %s: " user server))))
 	(unless (assoc from mail-source-password-cache)
 	  (push (cons from password) mail-source-password-cache)))
-      (when server
-	(setenv "MAILHOST" server))
       (setq result
 	    (cond
 	     ;; No easy way to check whether mail is waiting for these.
@@ -898,7 +934,7 @@ authentication.  To do that, you need to set the
 `message-send-mail-function' variable as `message-smtpmail-send-it'
 and put the following line in your ~/.gnus.el file:
 
-\(add-hook 'message-send-mail-hook 'mail-source-touch-pop)
+\(add-hook \\='message-send-mail-hook \\='mail-source-touch-pop)
 
 See the Gnus manual for details."
   (let ((sources (if mail-source-primary-source
@@ -991,6 +1027,7 @@ This only works when `display-time' is enabled."
 	  (dolist (file (directory-files (concat path subdir) t))
 	    (when (and (not (file-directory-p file))
 		       (not (if function
+				;; `function' should return nil if successful.
 				(funcall function file mail-source-crash-box)
 			      (let ((coding-system-for-write
 				     mm-text-coding-system)
@@ -1009,7 +1046,8 @@ This only works when `display-time' is enabled."
 ;;;				  (insert "\n\n")
 				  ;; MMDF mail format
 				  (insert "\001\001\001\001\n"))
-				(delete-file file)))))
+				(delete-file file)
+				nil))))
 	      (incf found (mail-source-callback callback file))
 	      (mail-source-delete-crash-box)))))
       found)))
@@ -1052,10 +1090,13 @@ This only works when `display-time' is enabled."
       (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))
+                         password) buf))
+          (let ((mailbox-list (if (listp mailbox) mailbox (list mailbox))))
+            (dolist (mailbox mailbox-list)
+              (when (imap-mailbox-select mailbox nil buf)
 	  (let ((coding-system-for-write mail-source-imap-file-coding-system)
 		str)
+            (message "Fetching from %s..." mailbox)
 	    (with-temp-file mail-source-crash-box
 	      ;; Avoid converting 8-bit chars from inserted strings to
 	      ;; multibyte.
@@ -1090,8 +1131,8 @@ This only works when `display-time' is enabled."
 	       fetchflag nil buf))
 	    (if dontexpunge
 		(imap-mailbox-unselect buf)
-	      (imap-mailbox-close nil buf))
-	    (imap-close buf))
+              (imap-mailbox-close nil buf)))))
+            (imap-close buf))
 	(imap-close buf)
 	;; We nix out the password in case the error
 	;; was because of a wrong password being given.