"The mail-fetching library."
:group 'gnus)
-(defcustom mail-source-movemail-program "movemail"
- "*A command to be executed to move mail from the inbox.
-The default is \"movemail\".
-
-This can also be a function. In that case, the function will be
-called with two parameters -- the name of the INBOX file, and the file
-to be moved to."
- :group 'mail-source
- :type '(choice string
- function))
-
-(defcustom mail-source-movemail-args nil
- "*Extra arguments to give to `mail-source-movemail-program' to move mail from the inbox.
-The default is nil."
- :group 'mail-source
- :type '(choice string
- (constant nil)))
-
(defcustom mail-source-crash-box "~/.emacs-mail-crash-box"
"File where mail will be stored while processing it."
:group 'mail-source
;;; Internal variables.
+(defvar mail-source-string ""
+ "A dynamically bound string that says what the current mail source is.")
+
(eval-and-compile
(defvar mail-source-keyword-map
'((file
(concat "/usr/spool/mail/" (user-login-name)))))
(directory
(:path)
- (:suffix ".spool")
- (:match))
+ (:suffix ".spool"))
(pop
(:server (getenv "MAILHOST"))
(:port "pop3")
(:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER")))
+ (:program)
+ (:args)
+ (:function)
(:password))
(maildir
(:path)))
"Strip the leading colon off the KEYWORD."
(intern (substring (symbol-name keyword) 1))))
-(eval-when-compile
+(eval-and-compile
(defun mail-source-bind-1 (type)
(let* ((defaults (cdr (assq type mail-source-keyword-map)))
default bind)
bind))
bind)))
-(defmacro mail-source-bind (type source &rest body)
- "Bind all variables in SOURCE."
- `(let ,(mail-source-bind-1 type)
- (mail-source-set-1 source)
+(defmacro mail-source-bind (type-source &rest body)
+ "Return a `let' form that binds all variables in source TYPE.
+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.
+
+After this is done, BODY will be executed in the scope
+of the `let' form."
+ `(let ,(mail-source-bind-1 (car type-source))
+ (mail-source-set-1 ,(cadr type-source))
,@body))
-(put 'mail-source-bind 'lisp-indent-function 2)
-(put 'mail-source-bind 'edebug-form-spec '(form form body))
+(put 'mail-source-bind 'lisp-indent-function 1)
+(put 'mail-source-bind 'edebug-form-spec '(form body))
(defun mail-source-set-1 (source)
(let* ((type (pop source))
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."
- (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 (funcall function source callback))))
+ (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 (funcall function source callback)))))
(defun mail-source-make-complex-temp-name (prefix)
(let ((newname (make-temp-name prefix))
(if (or (not (file-exists-p mail-source-crash-box))
(zerop (nth 7 (file-attributes mail-source-crash-box))))
(progn
- (delete-file mail-source-crash-box)
+ (when (file-exists-p mail-source-crash-box)
+ (delete-file mail-source-crash-box))
0)
(funcall callback mail-source-crash-box info)
- (if mail-source-delete-incoming
- (delete-file mail-source-crash-box)
- (let ((incoming
- (mail-source-make-complex-temp-name
- (expand-file-name
- "Incoming" mail-source-directory))))
- (unless (file-exists-p (file-name-directory incoming))
- (make-directory (file-name-directory incoming) t))
- (rename-file mail-source-crash-box incoming t)))
+ (when (file-exists-p mail-source-crash-box)
+ ;; Delete or move the incoming mail out of the way.
+ (if mail-source-delete-incoming
+ (delete-file mail-source-crash-box)
+ (let ((incoming
+ (mail-source-make-complex-temp-name
+ (expand-file-name
+ "Incoming" mail-source-directory))))
+ (unless (file-exists-p (file-name-directory incoming))
+ (make-directory (file-name-directory incoming) t))
+ (rename-file mail-source-crash-box incoming t))))
1))
(defun mail-source-movemail (from to)
((not (file-exists-p from))
;; There is no inbox.
(setq to nil))
+ ((zerop (nth 7 (file-attributes from)))
+ ;; Empty file.
+ (setq to nil))
(t
;; If getting from mail spool directory, use movemail to move
;; rather than just renaming, so as to interlock with the
(unwind-protect
(save-excursion
(setq errors (generate-new-buffer " *mail source loss*"))
- (buffer-disable-undo errors)
- (if (functionp mail-source-movemail-program)
- (condition-case err
- (progn
- (funcall mail-source-movemail-program from to)
- (setq result 0))
- (error
- (save-excursion
- (set-buffer errors)
- (insert (prin1-to-string err))
- (setq result 255))))
- (let ((default-directory "/"))
- (setq result
- (apply
- 'call-process
- (append
- (list
- (expand-file-name
- mail-source-movemail-program exec-directory)
- nil errors nil from to)
- (when mail-source-movemail-args
- mail-source-movemail-args))))))
+ (let ((default-directory "/"))
+ (setq result
+ (apply
+ 'call-process
+ (append
+ (list
+ (expand-file-name "movemail" exec-directory)
+ nil errors nil from to)))))
(when (file-exists-p to)
(set-file-modes to mail-source-default-file-modes))
(if (and (not (buffer-modified-p errors))
(buffer-string) result))
(error "%s" (buffer-string)))
(setq to nil)))))))
- (when (buffer-name errors)
+ (when (and errors
+ (buffer-name errors))
(kill-buffer errors))
;; Return whether we moved successfully or not.
to)))
(apply 'format prompt args)
prompt)))
(unless mail-source-read-passwd
- (if (load "passwd" t)
+ (if (or (fboundp 'read-passwd) (load "passwd" t))
(setq mail-source-read-passwd 'read-passwd)
(unless (fboundp 'ange-ftp-read-passwd)
(autoload 'ange-ftp-read-passwd "ange-ftp"))
(setq mail-source-read-passwd 'ange-ftp-read-passwd)))
(funcall mail-source-read-passwd prompt)))
+(defun mail-source-fetch-with-program (program args to)
+ (zerop (apply 'call-process program nil nil nil
+ (append (split-string args) (list to)))))
+
+;;;
+;;; Different fetchers
+;;;
+
(defun mail-source-fetch-file (source callback)
"Fetcher for single-file sources."
- (mail-source-bind file source
- (if (mail-source-movemail path mail-source-crash-box)
- (mail-source-callback callback path)
- 0)))
+ (mail-source-bind (file source)
+ (let ((mail-source-string (format "file:%s" path)))
+ (if (mail-source-movemail path mail-source-crash-box)
+ (mail-source-callback callback path)
+ 0))))
(defun mail-source-fetch-directory (source callback)
"Fetcher for directory sources."
- (mail-source-bind directory source
- (let ((files (directory-files
- path t
- (or match (concat (regexp-quote suffix) "$"))))
- (found 0)
- file)
- (while (setq file (pop files))
- (when (mail-source-movemail file mail-source-crash-box)
+ (mail-source-bind (directory source)
+ (let ((found 0)
+ (mail-source-string (format "directory:%s" path)))
+ (dolist (file (directory-files
+ path t (concat (regexp-quote suffix) "$")))
+ (when (and (file-regular-p file)
+ (mail-source-movemail file mail-source-crash-box))
(incf found (mail-source-callback callback file))))
found)))
(defun mail-source-fetch-pop (source callback)
"Fetcher for single-file sources."
- (mail-source-bind pop source
- (let ((from (format "%s:%s:%s" server user port)))
+ (mail-source-bind (pop source)
+ (let ((from (format "%s:%s:%s" server user port))
+ (mail-source-string (format "pop:%s@%s" user server)))
(setq password
(or password
(cdr (assoc from mail-source-password-cache))
(format "Password for %s at %s: " user server))))
(unless (assoc from mail-source-password-cache)
(push (cons from password) mail-source-password-cache))
- (let ((pop3-password password)
- (pop3-maildrop user)
- (pop3-mailhost server))
- (if (pop3-movemail mail-source-crash-box)
- (mail-source-callback callback server)
- ;; We nix out the password in case the error
- ;; was because of a wrong password being given.
- (setq mail-source-password-cache
- (delq (assoc from mail-source-password-cache)
- mail-source-password-cache))
- 0)))))
+ (when server
+ (setenv "MAILHOST" server))
+ (if (cond
+ (program
+ (when (listp args)
+ (setq args (eval args)))
+ (mail-source-fetch-with-program
+ program args mail-source-crash-box))
+ (function
+ (funcall function mail-source-crash-box))
+ ;; The default is to use pop3.el.
+ (t
+ (let ((pop3-password password)
+ (pop3-maildrop user)
+ (pop3-mailhost server))
+ (save-excursion (pop3-movemail mail-source-crash-box)))))
+ (mail-source-callback callback server)
+ ;; We nix out the password in case the error
+ ;; was because of a wrong password being given.
+ (setq mail-source-password-cache
+ (delq (assoc from mail-source-password-cache)
+ mail-source-password-cache))
+ 0))))
(provide 'mail-source)
projects / gnus / blobdiff