From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 30 Apr 1995 06:54:43 +0000 (+0000)
Subject: * Generalize and simplify sendmail interface, to give more control
X-Git-Tag: 20090517-FFI~6369
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=69ec162a8763576de7efef6885e9fac61d261bc0;p=mit-scheme.git

* Generalize and simplify sendmail interface, to give more control
  over the configuration of a mail buffer by a program.

* Restructure parts of the RMAIL code that deal with replies and
  output to mail files.  Export some of this code for use by other
  programs.
---

diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index bb9fff2dd..aaa15e996 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edwin.pkg,v 1.169 1995/04/17 21:46:25 cph Exp $
+$Id: edwin.pkg,v 1.170 1995/04/30 06:52:22 cph Exp $
 
 Copyright (c) 1989-95 Massachusetts Institute of Technology
 
@@ -1439,7 +1439,16 @@ MIT in each case. |#
 	  edwin-variable$rmail-primary-inbox-list
 	  edwin-variable$rmail-primary-pop-server
 	  edwin-variable$rmail-reply-with-re
-	  rmail-spool-directory))
+	  prompt-for-rmail-output-filename
+	  rfc822-addresses->string
+	  rfc822-first-address
+	  rfc822-region->babyl
+	  rfc822-region-reply-headers
+	  rfc822-strip-quoted-names
+	  rmail-output-to-rmail-file
+	  rmail-output-to-unix-mail-file
+	  rmail-spool-directory
+	  with-buffer-open))
 
 (define-package (edwin stepper)
   (files "eystep")
diff --git a/v7/src/edwin/rmail.scm b/v7/src/edwin/rmail.scm
index 5ec44bd0f..116ef645a 100644
--- a/v7/src/edwin/rmail.scm
+++ b/v7/src/edwin/rmail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: rmail.scm,v 1.39 1995/04/23 06:08:53 cph Exp $
+;;;	$Id: rmail.scm,v 1.40 1995/04/30 06:53:42 cph Exp $
 ;;;
 ;;;	Copyright (c) 1991-95 Massachusetts Institute of Technology
 ;;;
@@ -987,8 +987,9 @@ While composing the message, use \\[mail-yank-original] to yank the
 original message into it."
   ()
   (lambda ()
-    (make-mail-buffer false select-buffer-other-window
-		      false false false false (current-buffer))))
+    (make-mail-buffer '(("To" "") ("Subject" ""))
+		      (current-buffer)
+		      select-buffer-other-window)))
 
 (define-command rmail-continue
   "Continue composing outgoing message previously being composed."
@@ -1004,27 +1005,26 @@ original message into it."
 	  (memo (current-msg-memo)))
       (set-attribute! memo 'FORWARDED)
       (make-mail-buffer
-       false
-       (if (window-has-no-neighbors? (current-window))
-	   select-buffer
-	   select-buffer-other-window)
-       false
        (without-clipping buffer
 	 (lambda ()
 	   (with-values (lambda () (original-header-limits memo))
 	     (lambda (start end)
-	       (string-append
-		"["
-		(let ((from (fetch-first-field "from" start end)))
-		  (if from
-		      (addresses->string (strip-quoted-names from))
-		      ""))
-		": "
-		(or (fetch-first-field "subject" start end) "")
-		"]")))))
-       false
-       false
-       false)
+	       `(("To" "")
+		 ("Subject"
+		  ,(string-append
+		    "["
+		    (let ((from (fetch-first-field "from" start end)))
+		      (if from
+			  (rfc822-addresses->string
+			   (rfc822-strip-quoted-names from))
+			  ""))
+		    ": "
+		    (or (fetch-first-field "subject" start end) "")
+		    "]")))))))
+       #f
+       (if (window-has-no-neighbors? (current-window))
+	   select-buffer
+	   select-buffer-other-window))
       (insert-region (buffer-start buffer)
 		     (buffer-end buffer)
 		     (buffer-end (current-buffer))))))
@@ -1040,59 +1040,74 @@ original message into it."
     (let ((buffer (current-buffer))
 	  (memo (current-msg-memo)))
       (set-attribute! memo 'ANSWERED)
-      (without-clipping buffer
-	(lambda ()
-	  (with-values (lambda () (original-header-limits memo))
-	    (lambda (start end)
-	      (let ((resent-reply-to
-		     (fetch-last-field "resent-reply-to" start end))
-		    (from (fetch-first-field "from" start end)))
-		(make-mail-buffer
-		 false
-		 select-buffer-other-window
-		 (addresses->string
-		  (strip-quoted-names
-		   (or resent-reply-to
-		       (fetch-all-fields "reply-to" start end)
-		       from)))
-		 (let ((subject
-			(or (and resent-reply-to
-				 (fetch-last-field "resent-subject" start end))
-			    (fetch-first-field "subject" start end))))
-		   (if (ref-variable rmail-reply-with-re)
-		       (if (and subject
-				(not (string-prefix-ci? "re: " subject)))
-			   (string-append "Re: " subject)
-			   subject)
-		       (if (and subject (string-prefix-ci? "re: " subject))
-			   (string-tail subject 4)
-			   subject)))
-		 (if resent-reply-to
-		     (make-in-reply-to-field
-		      from
-		      (fetch-last-field "resent-date" start end)
-		      (fetch-last-field "resent-message-id" start end))
-		     (make-in-reply-to-field
-		      from
-		      (fetch-first-field "date" start end)
-		      (fetch-first-field "message-id" start end)))
-		 (and (not just-sender?)
-		      (let ((to
-			     (if resent-reply-to
-				 (fetch-last-field "resent-to" start end)
-				 (fetch-all-fields "to" start end)))
-			    (cc
-			     (if resent-reply-to
-				 (fetch-last-field "resent-cc" start end)
-				 (fetch-all-fields "cc" start end))))
-			(let ((cc
-			       (if (and to cc)
-				   (string-append to ", " cc)
-				   (or to cc))))
-			  (and cc
-			       (addresses->string
-				(dont-reply-to (strip-quoted-names cc)))))))
-		 buffer)))))))))
+      (make-mail-buffer (without-clipping buffer
+			  (lambda ()
+			    (rfc822-region-reply-headers
+			     (call-with-values
+				 (lambda () (original-header-limits memo))
+			       make-region)
+			     (not just-sender?))))
+			buffer
+			select-buffer-other-window))))
+
+(define (rfc822-region-reply-headers region cc?)
+  (let ((start (region-start region))
+	(end (region-end region)))
+    (let ((resent-reply-to (fetch-last-field "resent-reply-to" start end))
+	  (from (fetch-first-field "from" start end)))
+      `(("To"
+	 ,(rfc822-addresses->string
+	   (rfc822-strip-quoted-names
+	    (or resent-reply-to
+		(fetch-all-fields "reply-to" start end)
+		from))))
+	("CC"
+	 ,(and cc?
+	       (let ((to
+		      (if resent-reply-to
+			  (fetch-last-field "resent-to" start end)
+			  (fetch-all-fields "to" start end)))
+		     (cc
+		      (if resent-reply-to
+			  (fetch-last-field "resent-cc" start end)
+			  (fetch-all-fields "cc" start end))))
+		 (let ((cc
+			(if (and to cc)
+			    (string-append to ", " cc)
+			    (or to cc))))
+		   (and cc
+			(let ((addresses
+			       (dont-reply-to
+				(rfc822-strip-quoted-names cc))))
+			  (and (not (null? addresses))
+			       (rfc822-addresses->string addresses))))))))
+	("In-reply-to"
+	 ,(if resent-reply-to
+	      (make-in-reply-to-field
+	       from
+	       (fetch-last-field "resent-date" start end)
+	       (fetch-last-field "resent-message-id" start end))
+	      (make-in-reply-to-field
+	       from
+	       (fetch-first-field "date" start end)
+	       (fetch-first-field "message-id" start end))))
+	("Subject"
+	 ,(let ((subject
+		 (or (and resent-reply-to
+			  (fetch-last-field "resent-subject"
+					    start end))
+		     (fetch-first-field "subject" start end))))
+	    (cond ((not subject) "")
+		  ((ref-variable rmail-reply-with-re)
+		   (if (string-prefix-ci? "re:" subject)
+		       subject
+		       (string-append "Re: " subject)))
+		  (else
+		   (do ((subject
+			 subject
+			 (string-trim-left (string-tail subject 3))))
+		       ((not (string-prefix-ci? "re:" subject))
+			subject))))))))))
 
 (define (original-header-limits memo)
   (let ((start (msg-memo/start memo))
@@ -1156,7 +1171,7 @@ original message into it."
 (define (header-end start end)
   (or (search-forward "\n\n" start end false) end))
 
-(define (strip-quoted-names string)
+(define (rfc822-strip-quoted-names string)
   (let ((address-list (strip-quoted-names-1 (string->rfc822-tokens string))))
     (if (and address-list (null? (cdr address-list)))
 	(car address-list)
@@ -1183,9 +1198,10 @@ original message into it."
 	    (else
 	     (cons (car addresses) (loop (cdr addresses))))))))
 
-(define (addresses->string addresses)
-  (and (not (null? addresses))
-       (separated-append addresses ", ")))
+(define (rfc822-addresses->string addresses)
+  (if (null? addresses)
+      ""
+      (separated-append addresses ", ")))
 
 (define (separated-append tokens separator)
   (if (null? (cdr tokens))
@@ -1436,110 +1452,110 @@ If the file does not exist, ask if it should be created.
 If file is being visited, the message is appended to the
 buffer visiting that file."
   (lambda ()
-    (list
-     (->namestring
-      (get-rmail-output-pathname "Output message to Rmail file"
-				 (ref-variable rmail-last-rmail-file)))))
-  (lambda (filename)
-    (let* ((pathname (->pathname filename))
-	   (filename (->namestring pathname)))
-      (set-variable! rmail-last-rmail-file filename)
-      (let* ((memo (current-msg-memo))
-	     (message
-	      (without-clipping (current-buffer)
-		(lambda ()
-		  (extract-string (msg-memo/start memo)
-				  (msg-memo/end memo))))))
-	(cond ((pathname->buffer pathname)
-	       =>
-	       (lambda (buffer)
-		 (if (current-buffer? buffer)
-		     (editor-error
-		      "Can't output message to same file it's already in"))
-		 (with-buffer-open buffer
-		   (lambda ()
-		     (let ((memo (buffer-msg-memo buffer))
-			   (end (buffer-end buffer)))
-		       (let ((start (mark-right-inserting-copy end))
-			     (end (mark-left-inserting-copy end)))
-			 (if memo
-			     (delete-string (skip-chars-backward " \t\n" end)
-					    end))
-			 (insert-string message end)
-			 (if memo
-			     (begin
-			       (memoize-messages buffer start end)
-			       (select-message buffer memo)))
-			 (mark-temporary! start)
-			 (mark-temporary! end)))))))
-	      ((file-exists? pathname)
-	       (let ((port (open-output-file pathname true)))
-		 (write-string message port)
-		 (close-output-port port)))
-	      ((prompt-for-yes-or-no?
-		(string-append "\"" filename "\" does not exist, create it"))
-	       (call-with-output-file pathname
-		 (lambda (port)
-		   (write-string babyl-initial-header port)
-		   (write-string message port))))
-	      (else
-	       (editor-error "Output file does not exist")))
-	(set-attribute! memo 'FILED)
-	(if (ref-variable rmail-delete-after-output)
-	    ((ref-command rmail-delete-forward) false))))))
+    (list (prompt-for-rmail-output-filename
+	   "Output message to Rmail file"
+	   (ref-variable rmail-last-rmail-file))))
+  (lambda (pathname)
+    (set-variable! rmail-last-rmail-file (->namestring pathname))
+    (let ((memo (current-msg-memo)))
+      (rmail-output-to-rmail-file (make-region (msg-memo/start memo)
+					       (msg-memo/end memo))
+				  pathname)
+      (set-attribute! memo 'FILED)
+      (if (ref-variable rmail-delete-after-output)
+	  ((ref-command rmail-delete-forward) #f)))))
+
+(define (rmail-output-to-rmail-file region pathname)
+  ;; REGION is assumed to be in babyl format.
+  (let ((buffer (pathname->buffer pathname)))
+    (if buffer
+	(begin
+	  (if (eq? buffer (mark-buffer (region-start region)))
+	      (editor-error
+	       "Can't output message to same file it's already in"))
+	  (with-buffer-open buffer
+	    (lambda ()
+	      (let ((memo (buffer-msg-memo buffer))
+		    (end (buffer-end buffer)))
+		(let ((start (mark-right-inserting-copy end))
+		      (end (mark-left-inserting-copy end)))
+		  (if memo
+		      (delete-string (skip-chars-backward " \t\n" end)
+				     end))
+		  (insert-region (region-start region)
+				 (region-end region)
+				 end)
+		  (if memo
+		      (begin
+			(memoize-messages buffer start end)
+			(select-message buffer memo)))
+		  (mark-temporary! start)
+		  (mark-temporary! end))))))
+	(begin
+	  (if (not (file-exists? pathname))
+	      (begin
+		(if (not (prompt-for-yes-or-no?
+			  (string-append "\"" (->namestring pathname)
+					 "\" does not exist, create it")))
+		    (editor-error "Output file does not exist."))
+		(call-with-output-file pathname
+		  (lambda (port)
+		    (write-string babyl-initial-header port)))))
+	  (append-to-file region pathname #f)))))
 
 (define-command rmail-output
   "Append this message to Unix mail file named FILE-NAME."
   (lambda ()
-    (list
-     (->namestring
-      (get-rmail-output-pathname "Output message to Unix mail file"
-				 (ref-variable rmail-last-file)))))
+    (list (prompt-for-rmail-output-filename "Output message to Unix mail file"
+					    (ref-variable rmail-last-file))))
   (lambda (filename)
-    (let* ((pathname (->pathname filename)))
-      (set-variable! rmail-last-file (->namestring pathname))
-      (let ((memo (current-msg-memo)))
-	(let ((buffer (temporary-buffer " rmail output")))
-	  (let ((end (mark-left-inserting-copy (buffer-end buffer))))
-	    (let ((buffer (current-buffer)))
-	      (insert-region (buffer-start buffer) (buffer-end buffer) end))
-	    (insert-newline end)
-	    (let loop ((start (buffer-start buffer)))
-	      (if (re-search-forward "^From " start end true)
-		  (loop (replace-match ">\\&"))))
-	    (mark-temporary! end)
-	    (let ((start (buffer-start buffer)))
-	      (insert-string
-	       (string-append
-		"From "
-		(or (first-address
-		     (fetch-first-field "from" start (header-end start end)))
-		    "unknown")
-		" "
-		(file-time->string (current-file-time))
-		"\n")
-	       start)))
-	  (append-to-file (buffer-region buffer) pathname false)
-	  (kill-buffer buffer))
-	(set-attribute! memo 'FILED)
-	(if (ref-variable rmail-delete-after-output)
-	    ((ref-command rmail-delete-forward) false))))))
-
-(define (get-rmail-output-pathname prompt default)
-  (let ((default (->pathname default)))
-    (let ((name (file-pathname default)))
-      (let ((pathname
-	     (prompt-for-pathname
-	      (string-append prompt " (default " (->namestring name) ")")
-	      (directory-pathname default)
-	      false)))
-	(if (file-directory? pathname)
-	    (merge-pathnames name (pathname-as-directory pathname))
-	    pathname)))))
-
-(define (first-address field)
+    (set-variable! rmail-last-file (->namestring filename))
+    (let ((memo (current-msg-memo)))
+      (rmail-output-to-unix-mail-file (buffer-region (current-buffer))
+				      filename)
+      (set-attribute! memo 'FILED)
+      (if (ref-variable rmail-delete-after-output)
+	  ((ref-command rmail-delete-forward) #f)))))
+
+(define (rmail-output-to-unix-mail-file region pathname)
+  ;; REGION is assumed to be in RFC-822 format.
+  (let ((buffer (temporary-buffer " rmail output")))
+    (let ((end (mark-left-inserting-copy (buffer-end buffer))))
+      (insert-region (region-start region) (region-end region) end)
+      (insert-newline end)
+      (let loop ((start (buffer-start buffer)))
+	(if (re-search-forward "^From " start end #t)
+	    (loop (replace-match ">\\&"))))
+      (mark-temporary! end)
+      (let ((start (buffer-start buffer)))
+	(insert-string
+	 (string-append
+	  "From "
+	  (or (rfc822-first-address
+	       (fetch-first-field "from" start (header-end start end)))
+	      "unknown")
+	  " "
+	  (file-time->string (current-file-time))
+	  "\n")
+	 start)))
+    (append-to-file (buffer-region buffer) pathname #f)
+    (kill-buffer buffer)))
+
+(define (prompt-for-rmail-output-filename prompt default)
+  (->namestring
+   (let ((pathname
+	  (prompt-for-pathname
+	   (string-append prompt " (default " (file-namestring default) ")")
+	   (directory-pathname default)
+	   #f)))
+     (if (file-directory? pathname)
+	 (merge-pathnames (file-pathname default)
+			  (pathname-as-directory pathname))
+	 pathname))))
+
+(define (rfc822-first-address field)
   (and field
-       (let ((addresses (strip-quoted-names field)))
+       (let ((addresses (rfc822-strip-quoted-names field)))
 	 (and (not (null? addresses))
 	      (car addresses)))))
 
@@ -1638,7 +1654,7 @@ Leaves original message, deleted, before the undigestified messages."
 	  (delete-string (skip-chars-backward " \t\n" end start) end)
 	  (insert-string "\n\037" end)
 	  (let ((digest-name
-		 (first-address
+		 (rfc822-first-address
 		  (let ((hend (header-end start end)))
 		    (or (fetch-first-field "Reply-To" start hend)
 			(fetch-first-field "To" start hend)
@@ -2032,18 +2048,17 @@ Leaves original message, deleted, before the undigestified messages."
 	     (loop m (+ count 1))))
 	  ((re-match-forward umail-message-start-regexp point end false)
 	   (let ((point (mark-left-inserting-copy point)))
-	     (insert-string babyl-initial-message-start point)
 	     (nuke-pinhead-header point end)
 	     (mark-temporary! point)
-	     (process-message-body
+	     (process-rfc822
 	      point
 	      count
 	      (if (re-search-forward umail-message-end-regexp point end false)
 		  (re-match-start 0)
 		  end))))
 	  ((re-match-forward mmdf-message-start-regexp point end true)
-	   (let ((start (replace-match babyl-initial-message-start)))
-	     (process-message-body
+	   (let ((start (delete-match)))
+	     (process-rfc822
 	      start
 	      count
 	      (if (re-search-forward mmdf-message-end-regexp start end true)
@@ -2053,14 +2068,9 @@ Leaves original message, deleted, before the undigestified messages."
 	   (editor-error "error converting to Babyl format")
 	   true)))
 
-  (define (process-message-body point count mend)
+  (define (process-rfc822 point count mend)
     (let ((mend (mark-left-inserting-copy mend)))
-      (do ((m point (replace-match "\n^_")))
-	  ((not (search-forward "\n\037" m mend false))))
-      (let ((m (match-forward "\037" mend end false)))
-	(if m
-	    (move-mark-to! mend m)
-	    (insert-string "\037" mend)))
+      (rfc822-region->babyl (make-region point mend))
       (mark-temporary! mend)
       (loop mend (+ count 1))))
 
@@ -2072,6 +2082,19 @@ Leaves original message, deleted, before the undigestified messages."
   (with-text-clipped start end
     (lambda ()
       (loop (skip-chars-forward "\n" start end) 0))))
+
+(define (rfc822-region->babyl region)
+  (let ((start (mark-left-inserting-copy (region-start region))))
+    (insert-string babyl-initial-message-start start)
+    (mark-temporary! start)
+    (let ((end (mark-left-inserting-copy (region-end region))))
+      ;; Eliminate babyl message-separation pair from message body.
+      (do ((m start (replace-match "\n^_")))
+	  ((not (search-forward "\n\037" m end #f))))
+      (guarantee-newline end)
+      (if (not (eqv? (integer->char #o37) (extract-right-char end)))
+	  (insert-string "\037" end))
+      (mark-temporary! end))))
 
 (define (convert-buffer-to-babyl-format buffer)
   (with-buffer-open buffer
diff --git a/v7/src/edwin/sendmail.scm b/v7/src/edwin/sendmail.scm
index a4bc0bf43..0248f238b 100644
--- a/v7/src/edwin/sendmail.scm
+++ b/v7/src/edwin/sendmail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: sendmail.scm,v 1.23 1995/04/10 20:21:31 cph Exp $
+;;;	$Id: sendmail.scm,v 1.24 1995/04/30 06:54:22 cph Exp $
 ;;;
 ;;;	Copyright (c) 1991-95 Massachusetts Institute of Technology
 ;;;
@@ -161,61 +161,92 @@ If mail-archive-file-name is non-false, an FCC field with that file name
 is inserted."
   "P"
   (lambda (no-erase?)
-    (make-mail-buffer no-erase? select-buffer false false false false false)))
+    (make-mail-buffer '(("To" "") ("Subject" ""))
+		      #f
+		      select-buffer
+		      (if no-erase?
+			  'KEEP-PREVIOUS-MAIL
+			  'QUERY-DISCARD-PREVIOUS-MAIL))))
 
 (define-command mail-other-window
   "Like `mail' command, but display mail buffer in another window."
   "P"
   (lambda (no-erase?)
-    (make-mail-buffer no-erase? select-buffer-other-window
-		      false false false false false)))
-
-(define (make-mail-buffer no-erase? select-buffer
-			  to subject in-reply-to cc reply-buffer)
-  (let ((buffer (find-or-create-buffer "*mail*")))
-    (select-buffer buffer)
-    (if (and (not no-erase?)
-	     (or (not (buffer-modified? buffer))
-		 (prompt-for-confirmation?
-		  "Unsent message being composed; erase it")))
-	(begin
-	  (set-buffer-default-directory! buffer (default-homedir-pathname))
-	  (setup-buffer-auto-save! buffer)
-	  (region-delete! (buffer-unclipped-region buffer))
-	  (mail-setup buffer to subject in-reply-to cc reply-buffer)))))
+    (make-mail-buffer '(("To" "") ("Subject" ""))
+		      #f
+		      select-buffer-other-window
+		      (if no-erase?
+			  'KEEP-PREVIOUS-MAIL
+			  'QUERY-DISCARD-PREVIOUS-MAIL))))
+
+(define (make-mail-buffer headers reply-buffer select-buffer
+			  #!optional previous-mail-handling buffer-name mode)
+  (let ((buffer-name
+	 (or (and (not (default-object? buffer-name))
+		  buffer-name)
+	     "*mail*")))
+    (let ((buffer (find-buffer buffer-name))
+	  (continue
+	   (lambda (select?)
+	     (let ((buffer (find-or-create-buffer buffer-name)))
+	       (if select? (select-buffer buffer))
+	       (buffer-reset! buffer)
+	       (set-buffer-default-directory! buffer
+					      (default-homedir-pathname))
+	       (setup-buffer-auto-save! buffer)
+	       (mail-setup buffer headers reply-buffer
+			   (and (not (default-object? mode)) mode))))))
+      (if buffer
+	  (case (if (default-object? previous-mail-handling)
+		    'QUERY-DISCARD-PREVIOUS-MAIL
+		    previous-mail-handling)
+	    ((KEEP-PREVIOUS-MAIL)
+	     (select-buffer buffer))
+	    ((DISCARD-PREVIOUS-MAIL)
+	     (continue #t))
+	    ((QUERY-DISCARD-PREVIOUS-MAIL)
+	     (select-buffer buffer)
+	     (if (or (not (buffer-modified? buffer))
+		     (prompt-for-confirmation?
+		      "Unsent message being composed; erase it"))
+		 (continue #f)))
+	    (else
+	     (error:bad-range-argument previous-mail-handling
+				       'MAKE-MAIL-BUFFER)))
+	  (continue #t)))))
 
-(define (mail-setup buffer to subject in-reply-to cc reply-buffer)
+(define (mail-setup buffer headers reply-buffer #!optional mode)
   (guarantee-mail-aliases)
-  (set-buffer-major-mode! buffer (ref-mode-object mail))
+  (set-buffer-major-mode! buffer
+			  (or (and (not (default-object? mode)) mode)
+			      (ref-mode-object mail)))
   (local-set-variable! mail-reply-buffer reply-buffer)
   (let ((point (mark-left-inserting-copy (buffer-start buffer)))
 	(fill
 	 (lambda (start end)
 	   (fill-region-as-paragraph start end
-				     "\t" (ref-variable fill-column)
+				     "\t" (ref-variable fill-column buffer)
 				     false))))
-    (insert-string "To: " point)
-    (if to
-	(begin
-	  (insert-string to point)
-	  (fill (buffer-start buffer) point)))
-    (insert-newline point)
-    (if cc
-	(let ((start (mark-right-inserting point)))
-	  (insert-string "CC: " point)
-	  (insert-string cc point)
-	  (fill start point)
-	  (insert-newline point)))
-    (if in-reply-to
-	(begin
-	  (insert-string "In-reply-to: " point)
-	  (insert-string in-reply-to point)
-	  (insert-newline point)))
-    (insert-string "Subject: " point)
-    (if subject
-	(insert-string subject point))
-    (insert-newline point)
-    (let ((mail-default-reply-to (ref-variable mail-default-reply-to)))
+    (let ((start (mark-right-inserting-copy point)))
+      (for-each (lambda (header)
+		  (let ((key (car header))
+			(value (cadr header)))
+		    (if value
+			(begin
+			  (move-mark-to! start point)
+			  (insert-string key point)
+			  (insert-string ": " point)
+			  (insert-string value point)
+			  (if (and (not (string-null? value))
+				   (if (null? (cddr header))
+				       (or (string-ci=? key "to")
+					   (string-ci=? key "cc"))
+				       (caddr header)))
+			      (fill start point))
+			  (insert-newline point)))))
+		headers)
+      (mark-temporary! start))
+    (let ((mail-default-reply-to (ref-variable mail-default-reply-to buffer)))
       (let ((mail-default-reply-to
 	     (if (procedure? mail-default-reply-to)
 		 (mail-default-reply-to)
@@ -225,33 +256,45 @@ is inserted."
 	      (insert-string "Reply-to: " point)
 	      (insert-string mail-default-reply-to point)
 	      (insert-newline point)))))
-    (let ((mail-header-function (ref-variable mail-header-function)))
+    (let ((mail-header-function (ref-variable mail-header-function buffer)))
       (if mail-header-function
 	  (mail-header-function point)))
-    (if (ref-variable mail-self-blind)
+    (if (ref-variable mail-self-blind buffer)
 	(begin
 	  (insert-string "BCC: " point)
 	  (insert-string (current-user-name) point)
 	  (insert-newline point)))
-    (let ((mail-archive-file-name (ref-variable mail-archive-file-name)))
+    (let ((mail-archive-file-name
+	   (ref-variable mail-archive-file-name buffer)))
       (if mail-archive-file-name
 	  (begin
 	    (insert-string "FCC: " point)
 	    (insert-string mail-archive-file-name point)
 	    (insert-newline point))))
-    (insert-string (ref-variable mail-header-separator) point)
+    (insert-string (ref-variable mail-header-separator buffer) point)
     (insert-newline point)
     (mark-temporary! point))
-  (set-buffer-point! buffer
-		     (if to
-			 (buffer-end buffer)
-			 (mail-position-on-field buffer "To")))
-  (if (not (or to subject in-reply-to))
-      (buffer-not-modified! buffer))
-  (event-distributor/invoke! (ref-variable mail-setup-hook)))
+  (let ((given-header?
+	 (lambda (name)
+	   (let ((header
+		  (list-search-positive headers
+		    (lambda (header)
+		      (string-ci=? (car header) name)))))
+	     (and header
+		  (cadr header)
+		  (not (string-null? (cadr header))))))))
+    (set-buffer-point! buffer
+		       (if (given-header? "to")
+			   (buffer-end buffer)
+			   (mail-position-on-field buffer "to")))
+    (if (not (or (given-header? "to")
+		 (given-header? "subject")
+		 (given-header? "in-reply-to")))
+	(buffer-not-modified! buffer)))
+  (event-distributor/invoke! (ref-variable mail-setup-hook buffer)))
 
 (define-variable mail-setup-hook
-  "An event distributor invoked immediately after a mail buffer initialized."
+  "An event distributor invoked immediately after a mail buffer is initialized."
   (make-event-distributor))
 
 (define-major-mode mail text "Mail"
diff --git a/v7/src/edwin/vc.scm b/v7/src/edwin/vc.scm
index 1ec922b27..17dfeb731 100644
--- a/v7/src/edwin/vc.scm
+++ b/v7/src/edwin/vc.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: vc.scm,v 1.20 1995/04/15 06:14:34 cph Exp $
+;;;	$Id: vc.scm,v 1.21 1995/04/30 06:54:43 cph Exp $
 ;;;
 ;;;	Copyright (c) 1994-95 Massachusetts Institute of Technology
 ;;;
@@ -384,9 +384,11 @@ lock steals will raise an error.
 	(if (not (prompt-for-confirmation?
 		  (string-append "Take the lock on " file:rev " from " owner)))
 	    (editor-error "Steal cancelled."))
-	(let ((mail-buffer (find-or-create-buffer "*VC-mail*")))
-	  (buffer-reset! mail-buffer)
-	  (mail-setup mail-buffer owner file:rev #f #f #f)
+	(make-mail-buffer `(("To" ,owner) ("Subject" ,file:rev))
+			  #f
+			  select-buffer-other-window
+			  'DISCARD-PREVIOUS-MAIL)
+	(let ((mail-buffer (current-buffer)))
 	  (let ((time (get-decoded-time)))
 	    (insert-string (string-append "I stole the lock on "
 					  file:rev
@@ -405,8 +407,7 @@ lock steals will raise an error.
 		(vc-revert-workfile-buffer master #t)
 		;; Send the mail after the steal has completed
 		;; successfully.
-		((variable-default-value variable)))))
-	  (pop-up-buffer mail-buffer #t)))))
+		((variable-default-value variable)))))))))
   (message "Please explain why you are stealing the lock."
 	   "  Type C-c C-c when done."))