Add generalized mechanism for formation of mail return address. The

new mechanism matches that of Emacs.

diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 0426b4027e483a8ca3cdbb5f46e681ecb2665ca7..1c7ec11d0ca7feccebd45ca3cacc4f015f3e248d 100644 (file)
--- 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 7b873a4cb121106d1953c9911e804c8201a0db55..8251817fedc1d2acfb10e288d30ec9d3f095751a 100644 (file)
--- 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?)
-
+\f
 (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?)
-\f
+
 (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)))