From 9020626a4053d204e50b69b8119efd182fc03e3e Mon Sep 17 00:00:00 2001
From: "Taylor R. Campbell" <net/mumble/campbell>
Date: Mon, 11 Aug 2008 22:48:50 +0000
Subject: [PATCH] Retain names with addresses when replying to mail.

---
 v7/src/edwin/edwin.pkg     |  8 +++++---
 v7/src/edwin/rfc822.scm    | 38 +++++++++++++++++++-------------------
 v7/src/edwin/sendmail.scm  | 32 ++++++++++++++++++++++++--------
 v7/src/imail/imail-top.scm | 10 ++++++----
 4 files changed, 54 insertions(+), 34 deletions(-)

diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 538e604f8..8f7732b26 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edwin.pkg,v 1.308 2008/07/19 00:56:19 cph Exp $
+$Id: edwin.pkg,v 1.309 2008/08/11 22:48:50 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -1681,6 +1681,7 @@ USA.
   (export (edwin)
 	  rfc822:addresses->string
 	  rfc822:canonicalize-address-string
+	  rfc822:canonicalize-named-address-string
 	  rfc822:first-address
 	  rfc822:header-field-name?
 	  rfc822:parse-addr-spec
@@ -1689,11 +1690,12 @@ USA.
 	  rfc822:parse-msg-id
 	  rfc822:parse-word
 	  rfc822:quote-string
-          rfc822:unquote-string
+	  rfc822:unquote-string
 	  rfc822:received-header-components
 	  rfc822:string->addresses
+	  rfc822:string->named-addresses
 	  rfc822:string->tokens
-          rfc822:string-tokenizer
+	  rfc822:string-tokenizer
 	  rfc822:strip-comments
 	  rfc822:strip-quoted-names
 	  rfc822:tokens->string))
diff --git a/v7/src/edwin/rfc822.scm b/v7/src/edwin/rfc822.scm
index 1d5889d12..38fdd2a07 100644
--- a/v7/src/edwin/rfc822.scm
+++ b/v7/src/edwin/rfc822.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: rfc822.scm,v 3.10 2008/01/30 20:02:05 cph Exp $
+$Id: rfc822.scm,v 3.11 2008/08/11 22:48:50 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -76,27 +76,27 @@ USA.
   (decorated-string-append "" ", " "" addresses))
 
 (define (rfc822:string->addresses string)
-  (let ((address-list
-	 (rfc822:strip-quoted-names
-          (rfc822:string->non-ignored-tokens string))))
-    (if (and address-list (null? (cdr address-list)))
-	(car address-list)
-	(map (lambda (string)
-	       (let ((string (string-trim string)))
-		 (let ((end (string-length string)))
-		   (let loop ((start 0))
-		     (let ((index
-			    (substring-find-next-char-in-set
-			     string start end char-set:whitespace)))
-		       (if index
-			   (begin
-			     (string-set! string index #\space)
-			     (loop (fix:+ index 1)))))))
-		 string))
-	     (burst-string string #\, #f)))))
+  (let ((tokens (rfc822:string->non-ignored-tokens string)))
+    (let ((address-list (rfc822:strip-quoted-names tokens)))
+      (if (and address-list (null? (cdr address-list)))
+	  (car address-list)
+	  (rfc822:split-address-tokens tokens)))))
+
+(define (rfc822:string->named-addresses string)
+  (rfc822:split-address-tokens (rfc822:string->tokens string)))
+
+(define (rfc822:split-address-tokens tokens)
+  (let recur ((tokens tokens))
+    (receive (tokens tokens*)
+	(span (lambda (token) (not (eqv? token #\,))) tokens)
+      (cons (rfc822:tokens->string tokens)
+	    (if (pair? tokens*) (recur (cdr tokens*)) '())))))
 
 (define (rfc822:canonicalize-address-string string)
   (rfc822:addresses->string (rfc822:string->addresses string)))
+
+(define (rfc822:canonicalize-named-address-string string)
+  (rfc822:addresses->string (rfc822:string->named-addresses string)))
 
 ;;;; Parsers
 
diff --git a/v7/src/edwin/sendmail.scm b/v7/src/edwin/sendmail.scm
index a0aa1e288..3ef0ff49e 100644
--- a/v7/src/edwin/sendmail.scm
+++ b/v7/src/edwin/sendmail.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: sendmail.scm,v 1.97 2008/06/20 06:10:13 riastradh Exp $
+$Id: sendmail.scm,v 1.98 2008/08/11 22:48:50 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -306,12 +306,7 @@ is inserted."
 			      (ref-mode-object mail)))
   (local-set-variable! mail-reply-buffer reply-buffer buffer)
   (let ((headers (add-standard-headers headers buffer))
-	(point (mark-left-inserting-copy (buffer-start buffer)))
-	(fill
-	 (lambda (start end)
-	   (fill-region-as-paragraph start end
-				     "\t" (ref-variable fill-column buffer)
-				     #f))))
+	(point (mark-left-inserting-copy (buffer-start buffer))))
     (let ((start (mark-right-inserting-copy point)))
       (for-each
        (lambda (header)
@@ -343,7 +338,7 @@ is inserted."
 			      (or (string-ci=? key "to")
 				  (string-ci=? key "cc"))
 			      (caddr header)))
-		     (fill start point))
+		     (fill-mail-addresses start point))
 		 (insert-newline point)))))
        headers)
       (mark-temporary! start))
@@ -374,6 +369,27 @@ is inserted."
 	  (buffer-not-modified! buffer))))
   (event-distributor/invoke! (ref-variable mail-setup-hook buffer) buffer))
 
+(define (fill-mail-addresses start end)
+  ;; This totally loses on quoted or commented names, which it
+  ;; probably shouldn't split up.
+  (let ((column (ref-variable fill-column start))
+	(mark (char-search-forward #\, start end)))
+    (if mark
+	(let loop ((start start) (mark mark))
+	  (let ((mark* (char-search-forward #\, mark end)))
+	    (if mark*
+		(if (< (mark-column mark*) column)
+		    (loop start mark*)
+		    (let ((mark
+			   (mark-permanent-copy
+			    ;; Skip addresses that are too long.
+			    (if (mark= mark start) mark* mark))))
+		      (delete-horizontal-space mark)
+		      (insert-newline mark)
+		      (insert-char #\tab mark)
+		      (mark-temporary! mark)
+		      (loop mark mark)))))))))
+
 (define (add-standard-headers headers buffer)
   (let ((add
 	 (lambda (key value)
diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index 22677b5bb..b8db22711 100644
--- a/v7/src/imail/imail-top.scm
+++ b/v7/src/imail/imail-top.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: imail-top.scm,v 1.308 2008/08/11 17:53:51 riastradh Exp $
+$Id: imail-top.scm,v 1.309 2008/08/11 22:48:50 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -1278,7 +1278,7 @@ ADDRESSES is a string consisting of several addresses separated by commas."
 	   (and (pair? strings)
 		(decorated-string-append "" ", " "" strings)))))
     `(("To"
-       ,(rfc822:canonicalize-address-string
+       ,(rfc822:canonicalize-named-address-string
 	 (or resent-reply-to
 	     (concat (get-all-header-field-values message "reply-to"))
 	     from)))
@@ -1299,7 +1299,7 @@ ADDRESSES is a string consisting of several addresses separated by commas."
 		 (and cc
 		      (let ((addresses
 			     (imail-dont-reply-to
-			      (rfc822:string->addresses cc))))
+			      (rfc822:string->named-addresses cc))))
 			(and (pair? addresses)
 			     (rfc822:addresses->string addresses))))))))
       ("In-reply-to"
@@ -1334,7 +1334,9 @@ ADDRESSES is a string consisting of several addresses separated by commas."
 	  #t)))
     (let loop ((addresses addresses))
       (if (pair? addresses)
-	  (if (re-string-match pattern (car addresses))
+	  (if (re-string-match pattern
+			       (rfc822:canonicalize-address-string
+				(car addresses)))
 	      (loop (cdr addresses))
 	      (cons (car addresses) (loop (cdr addresses))))
 	  '()))))
-- 
2.25.1