;;; mail-source.el --- functions for fetching mail
-;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
-;; 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2015 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news, mail
;;; Code:
-;; For Emacs < 22.2.
-(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")
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)
: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
(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"))))))))
(: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")))
(: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)
(:prescript)
(:prescript-delay)
(:postscript)
- (:dontexpunge))
- (webmail
- (:subtype hotmail)
- (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
- (:password)
- (:dontexpunge)
- (:authentication password)))
+ (:dontexpunge)))
"Mapping from keywords to default values.
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)
- (webmail mail-source-fetch-webmail))
+ (imap mail-source-fetch-imap))
"A mapping from source type to fetcher function.")
(defvar mail-source-password-cache nil)
(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 ()
((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
value)))
+(autoload 'nnheader-message "nnheader")
+
(defun mail-source-fetch (source callback &optional method)
"Fetch mail from SOURCE and call CALLBACK zero or more times.
CALLBACK will be called with the name of the file where (some of)
(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)
0)
(funcall callback mail-source-crash-box info)))
+(autoload 'gnus-float-time "gnus-util")
+
(defvar mail-source-incoming-last-checked-time nil)
(defun mail-source-delete-crash-box ()
;; Don't check for old incoming files more than once per day to
;; save a lot of file accesses.
(when (or (null mail-source-incoming-last-checked-time)
- (> (time-to-seconds
+ (> (gnus-float-time
(time-since mail-source-incoming-last-checked-time))
(* 24 60 60)))
(setq mail-source-incoming-last-checked-time (current-time))
;; 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)))
(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
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
(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
(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
(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
(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.
`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
(if on
(progn
(require 'time)
- ;; display-time-mail-function is an Emacs 21 feature.
+ ;; display-time-mail-function is an Emacs feature.
(setq display-time-mail-function #'mail-source-new-mail-p)
;; Set up the main timer.
(setq mail-source-report-new-mail-timer
(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)
;;; (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)))
(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.
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.
?s server ?P port ?u user))
found)))
-(autoload 'webmail-fetch "webmail")
-
-(defun mail-source-fetch-webmail (source callback)
- "Fetch for webmail source."
- (mail-source-bind (webmail source)
- (let ((mail-source-string (format "webmail:%s:%s" subtype user))
- (webmail-newmail-only dontexpunge)
- (webmail-move-to-trash-can (not dontexpunge)))
- (when (eq authentication 'password)
- (setq password
- (or password
- (cdr (assoc (format "webmail:%s:%s" subtype user)
- mail-source-password-cache))
- (read-passwd
- (format "Password for %s at %s: " user subtype))))
- (when (and password
- (not (assoc (format "webmail:%s:%s" subtype user)
- mail-source-password-cache)))
- (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))
- (mail-source-delete-crash-box))))
-
(provide 'mail-source)
;;; mail-source.el ends here
projects / gnus / blobdiff