From dff2926fea7846a4e1eec63465f4d64b04c40fa1 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 31 Oct 1997 01:24:24 +0000
Subject: [PATCH] Add generalized mechanism for formation of mail return
 address.  The new mechanism matches that of Emacs.

---
 v7/src/edwin/edwin.pkg    |  5 +++-
 v7/src/edwin/sendmail.scm | 55 ++++++++++++++++++++++++++++++---------
 2 files changed, 47 insertions(+), 13 deletions(-)

diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 0426b4027..1c7ec11d0 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edwin.pkg,v 1.212 1997/10/22 05:10:46 cph Exp $
+$Id: edwin.pkg,v 1.213 1997/10/31 01:24:24 cph Exp $
 
 Copyright (c) 1989-97 Massachusetts Institute of Technology
 
@@ -1452,6 +1452,7 @@ MIT in each case. |#
   (files "sendmail")
   (parent (edwin))
   (export (edwin)
+	  char-set:rfc822-quoted
 	  edwin-command$mail
 	  edwin-command$mail-bcc
 	  edwin-command$mail-cc
@@ -1466,6 +1467,7 @@ MIT in each case. |#
 	  edwin-mode$mail
 	  edwin-variable$mail-archive-file-name
 	  edwin-variable$mail-default-reply-to
+	  edwin-variable$mail-from-style
 	  edwin-variable$mail-full-name
 	  edwin-variable$mail-header-function
 	  edwin-variable$mail-header-separator
@@ -1496,6 +1498,7 @@ MIT in each case. |#
 	  mailer-version-string
 	  make-mail-buffer
 	  prepare-mail-buffer-for-sending
+	  rfc822-quote
 	  send-mail-buffer)
   (import (runtime system)
 	  known-systems))
diff --git a/v7/src/edwin/sendmail.scm b/v7/src/edwin/sendmail.scm
index 7b873a4cb..8251817fe 100644
--- a/v7/src/edwin/sendmail.scm
+++ b/v7/src/edwin/sendmail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: sendmail.scm,v 1.35 1997/01/03 04:07:00 cph Exp $
+;;;	$Id: sendmail.scm,v 1.36 1997/10/31 01:23:02 cph Exp $
 ;;;
 ;;;	Copyright (c) 1991-97 Massachusetts Institute of Technology
 ;;;
@@ -65,6 +65,15 @@ If set to the null string, From: field contains only the email address."
   ""
   string?)
 
+(define-variable mail-from-style
+  "Specifies how \"From:\" fields look.
+One of the following values:
+'PARENS	king@grassland.com (Elvis Parsley)
+'ANGLES	Elvis Parsley <king@grassland.com>
+#F	king@grassland.com"
+  'ANGLES
+  (lambda (object) (memq object '(PARENS ANGLES #F))))
+
 (define-variable mail-organization
   "The name of your organization.
 Appears in the Organization: field of mail and news messages.
@@ -97,7 +106,7 @@ so you can remove or alter the BCC field to override the default."
   "Name of file to write all outgoing messages in, or false for none."
   false
   string-or-false?)
-
+
 (define-variable mail-yank-ignored-headers
   "Delete these headers from old message when it's inserted in a reply."
   (reduce (lambda (x y) (string-append x "\\|" y))
@@ -122,7 +131,7 @@ so you can remove or alter the BCC field to override the default."
 False means let mailer mail back a message to report errors."
   false
   boolean?)
-
+
 (define-variable mail-header-separator
   "Line used to separate headers from text in messages being composed."
   "--text follows this line--"
@@ -325,15 +334,37 @@ is inserted."
 	      (add-unique "X-Mailer" (mailer-version-string buffer))))))
 
 (define (mail-from-string buffer)
-  (string-append (or (ref-variable user-mail-address buffer)
-		     (string-append (current-user-name)
-				   "@"
-				   (or (ref-variable mail-host-address buffer)
-				       (os/hostname))))
-		 (let ((full-name (ref-variable mail-full-name buffer)))
-		   (if (string-null? full-name)
-		       ""
-		       (string-append " (" full-name ")")))))
+  (let ((address
+	 (or (ref-variable user-mail-address buffer)
+	     (string-append (current-user-name)
+			    "@"
+			    (or (ref-variable mail-host-address buffer)
+				(os/hostname)))))
+	(full-name (ref-variable mail-full-name buffer)))
+    (if (string-null? full-name)
+	address
+	(case (ref-variable mail-from-style buffer)
+	  ((PARENS) (string-append address " (" full-name ")"))
+	  ((ANGLES) (string-append (rfc822-quote full-name) " <" address ">"))
+	  (else address)))))
+
+(define (rfc822-quote string)
+  (if (string-find-next-char-in-set string char-set:rfc822-quoted)
+      (let loop ((chars (string->list string)) (result (list #\")))
+	(if (null? chars)
+	    (list->string (reverse! (cons #\" result)))
+	    (loop (cdr chars)
+		  (cons (car chars)
+			(if (or (char=? #\\ (car chars))
+				(char=? #\" (car chars)))
+			    (cons #\\ result)
+			    result)))))
+      string))
+
+(define char-set:rfc822-quoted
+  (char-set-invert
+   (char-set-union char-set:alphanumeric
+		   (apply char-set (string->list " !#$%&'*+-/=?^_`{|}~")))))
 
 (define (mail-organization-string buffer)
   (let ((organization (ref-variable mail-organization buffer)))
-- 
2.25.1