From 187f7c02b3bdc30c49ca0c5ddf29899a5140b3a3 Mon Sep 17 00:00:00 2001 From: tomo Date: Tue, 26 Jan 1999 05:51:55 +0000 Subject: [PATCH] This commit was manufactured by cvs2svn to create tag 'pgnus- ichikawa-199901261900'. --- lisp/mail-source.el | 339 --------------------------------------------------- 1 file changed, 339 deletions(-) delete mode 100644 lisp/mail-source.el diff --git a/lisp/mail-source.el b/lisp/mail-source.el deleted file mode 100644 index f7d1b83..0000000 --- a/lisp/mail-source.el +++ /dev/null @@ -1,339 +0,0 @@ -;;; mail-source.el --- functions for fetching mail -;; Copyright (C) 1999 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; Keywords: news, mail - -;; This file is part of GNU Emacs. - -;; 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 -;; the Free Software Foundation; either version 2, 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 -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; 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., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;;; Code: - -(eval-when-compile (require 'cl)) -(eval-and-compile - (autoload 'pop3-movemail "pop3")) - -(defgroup mail-source nil - "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 - :type 'file) - -(defcustom mail-source-directory "~/Mail/" - "Directory where files (if any) will be stored." - :group 'mail-source - :type 'directory) - -(defcustom mail-source-default-file-modes 384 - "Set the mode bits of all new mail files to this integer." - :group 'mail-source - :type 'integer) - -(defcustom mail-source-delete-incoming nil - "*If non-nil, delete incoming files after handling." - :group 'mail-source - :type 'boolean) - -;;; Internal variables. - -(eval-and-compile - (defvar mail-source-keyword-map - '((file - (:path (or (getenv "MAIL") - (concat "/usr/spool/mail/" (user-login-name))))) - (directory - (:path) - (:suffix ".spool") - (:match)) - (pop - (:server (getenv "MAILHOST")) - (:port "pop3") - (:user (or (user-login-name) (getenv "LOGNAME") (getenv "USER"))) - (:password)) - (maildir - (:path))) - "Mapping from keywords to default values. -All keywords that can be used must be listed here.")) - -(defvar mail-source-fetcher-alist - '((file mail-source-fetch-file) - (directory mail-source-fetch-directory) - (pop mail-source-fetch-pop) - (qmail mail-source-fetch-qmail)) - "A mapping from source type to fetcher function.") - -(defvar mail-source-password-cache nil) - -;;; Functions - -(eval-and-compile - (defun mail-source-strip-keyword (keyword) - "Strip the leading colon off the KEYWORD." - (intern (substring (symbol-name keyword) 1)))) - -(eval-when-compile - (defun mail-source-bind-1 (type) - (let* ((defaults (cdr (assq type mail-source-keyword-map))) - default bind) - (while (setq default (pop defaults)) - (push (list (mail-source-strip-keyword (car default)) - nil) - 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) - ,@body)) - -(put 'mail-source-bind 'lisp-indent-function 2) -(put 'mail-source-bind 'edebug-form-spec '(form form body)) - -(defun mail-source-set-1 (source) - (let* ((type (pop source)) - (defaults (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) - (mail-source-value (cadr default))))))) - -(defun mail-source-value (value) - "Return the value of VALUE." - (cond - ;; String - ((stringp value) - value) - ;; Function - ((and (listp value) - (functionp (car value))) - (eval value)) - ;; Variable - ((and (symbolp value) - (boundp value)) - (symbol-value value)) - ;; Just return the value. - (t - value))) - -(defun mail-source-fetch (source callback) - "Fetch mail from SOURCE and call CALLBACK zero or more times. -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)))) - -(defun mail-source-make-complex-temp-name (prefix) - (let ((newname (make-temp-name prefix)) - (newprefix prefix)) - (while (file-exists-p newname) - (setq newprefix (concat newprefix "x")) - (setq newname (make-temp-name newprefix))) - newname)) - -(defun mail-source-callback (callback info) - "Call CALLBACK on the mail file, and then remove the mail file. -Pass INFO on to CALLBACK." - (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) - 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))) - 1)) - -(defun mail-source-movemail (from to) - "Move FROM to TO using movemail." - (if (not (file-writable-p to)) - (error "Can't write to crash box %s. Not moving mail" to) - (let ((to (file-truename (expand-file-name to))) - errors result) - (setq to (file-truename to) - from (file-truename from)) - ;; Set TO if have not already done so, and rename or copy - ;; the file FROM to TO if and as appropriate. - (cond - ((file-exists-p to) - ;; The crash box exists already. - t) - ((not (file-exists-p from)) - ;; There is no inbox. - (setq to nil)) - (t - ;; If getting from mail spool directory, use movemail to move - ;; rather than just renaming, so as to interlock with the - ;; mailer. - (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)))))) - (when (file-exists-p to) - (set-file-modes to mail-source-default-file-modes)) - (if (and (not (buffer-modified-p errors)) - (zerop result)) - ;; No output => movemail won. - t - (set-buffer errors) - ;; There may be a warning about older revisions. We - ;; ignore that. - (goto-char (point-min)) - (if (search-forward "older revision" nil t) - t - ;; Probably a real error. - (subst-char-in-region (point-min) (point-max) ?\n ?\ ) - (goto-char (point-max)) - (skip-chars-backward " \t") - (delete-region (point) (point-max)) - (goto-char (point-min)) - (when (looking-at "movemail: ") - (delete-region (point-min) (match-end 0))) - (unless (yes-or-no-p - (format "movemail: %s (%d return). Continue? " - (buffer-string) result)) - (error "%s" (buffer-string))) - (setq to nil))))))) - (when (buffer-name errors) - (kill-buffer errors)) - ;; Return whether we moved successfully or not. - to))) - -(defvar mail-source-read-passwd nil) -(defun mail-source-read-passwd (prompt &rest args) - "Read a password using PROMPT. -If ARGS, PROMPT is used as an argument to `format'." - (let ((prompt - (if args - (apply 'format prompt args) - prompt))) - (unless mail-source-read-passwd - (if (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-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))) - -(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) - (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))) - (setq password - (or password - (cdr (assoc from mail-source-password-cache)) - (mail-source-read-passwd - (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))))) - -(provide 'mail-source) - -;;; mail-source.el ends here -- 1.7.10.4