;;; lpf-frobs.el --- useful elisp functions for LPF mailing list maintenance

;;; Author: Noah Friedman <friedman@prep.ai.mit.edu>
;;; Maintainer: friedman@prep.ai.mit.edu
;;; Keywords: extensions
;;; Created: 1994-08-28
;;; Public domain

;;; $Id: lpf-frobs.el,v 1.1 1994/08/28 22:10:07 friedman Exp $

;;; Commentary:

;;; TODO: document these.

;;; Code:

(require 'sendmail)

(defvar lpf-directory (expand-file-name "~rms/lpf/"))
(defvar lpf-reply-file "reply")
(defvar lpf-reply-address-list-file "info-requests-email")

(defvar lpf-mail-reply-method 'rmail-reply)
(defvar lpf-mail-send-method 'mail-send-and-exit)

(defvar lpf-strip-header-list '("Cc")
  "*Headers always to strip from outgoing replies.")

(defvar lpf-strip-header-list-1 '("From" "Reply-To")
  "*Headers to strip only when replying via lpf-reply-1.
Headers listed in `lpf-strip-header-list' are also stripped.")


(defun lpf-reply ()
  (interactive)

  (let* ((mail-header-separator "")
         (addr (lpf-mail-get-header-contents "From"))
         (request-buffer (find-file-noselect 
                          (concat lpf-directory 
                                  lpf-reply-address-list-file))))
    (save-excursion
      (set-buffer request-buffer)
      (goto-char (point-max))
      (insert (car addr) "\n")
      (let ((version-control 'never))
        (save-buffer))
      (kill-buffer request-buffer)))

  (if (commandp lpf-mail-reply-method)
      (call-interactively lpf-mail-reply-method)
    (funcall lpf-mail-reply-method))

  (lpf-strip-headers lpf-strip-header-list)
  (and (boundp 'lpf-reply-strip-some-headers)
       lpf-reply-strip-some-headers
       (lpf-strip-headers lpf-strip-header-list-1))

  (insert-file-contents (concat lpf-directory lpf-reply-file))
  (if (commandp lpf-mail-send-method)
      (call-interactively lpf-mail-send-method)
    (funcall lpf-mail-send-method)))

(defun lpf-reply-1 ()
  (interactive)
  (let ((lpf-reply-strip-some-headers t))
    (lpf-reply)))


(defun lpf-strip-headers (list)
  (while list
    (lpf-mail-remove-header (car list) 'all)
    (setq list (cdr list))))

(defun lpf-mail-get-header-contents (HEADER)
  "Return a list containing contents of any headers named HEADER.
If no occurrences of HEADER exist in the current mail buffer, return nil."
  (save-excursion
    (save-restriction
      (let (contents-list end beg)
        (while (mail-position-on-field HEADER 'soft)
          (setq end (point)
                beg (progn
                      (re-search-backward (concat HEADER ": "))
                      (goto-char (match-end 0)))
                contents-list (cons (buffer-substring beg end) contents-list))
          (narrow-to-region end (point-max)))
        (nreverse contents-list)))))

(defun lpf-mail-remove-header (HEADER &optional all)
  "Remove first instance of HEADER (and contents) from the current
mail message.  If optional second argument ALL is non-nil, all such
instances are removed."
  (save-excursion
    (let (beg end
          (doit t))
      (while (and (mail-position-on-field HEADER 'soft) doit)
        (setq end (point)
              beg (progn
                    (re-search-backward (concat HEADER ": "))
                    (goto-char (match-beginning 0)))
              doit all)
        (delete-region beg (1+ end))))))

;;; lpf-frobs.el ends here