Retain names with addresses when replying to mail.

diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 538e604f82c6cb70817c28da761e8d0722c5c386..8f7732b269215470157512af91dfa0a6396c66c5 100644 (file)
--- 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 1d5889d123b01e599b0d63150979def891ef72f1..38fdd2a0721b24fef2f9cd39da5123a44d725f32 100644 (file)
--- 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)))
 \f
 ;;;; Parsers
 

diff --git a/v7/src/edwin/sendmail.scm b/v7/src/edwin/sendmail.scm
index a0aa1e288d72407d019655936a15ef0892c5f9b0..3ef0ff49e42250eead319ccd403e92c1640a250c 100644 (file)
--- 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))
 \f
+(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 22677b5bb1a665e43e9b5db32ffa4e9d4f783e5f..b8db22711fc2a651f83bd278d12108ea72cca487 100644 (file)
--- 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))))
          '()))))