From: Taylor R. Campbell Date: Mon, 11 Aug 2008 22:48:50 +0000 (+0000) Subject: Retain names with addresses when replying to mail. X-Git-Tag: 20090517-FFI~254 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9020626a4053d204e50b69b8119efd182fc03e3e;p=mit-scheme.git Retain names with addresses when replying to mail. --- 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)))) '()))))