From: Chris Hanson Date: Mon, 12 Jun 2000 01:39:09 +0000 (+0000) Subject: Insert X-Mailer and Organization fields after user finished editing X-Git-Tag: 20090517-FFI~3551 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e29d590d110e1e461b2b8d749d542bc85710ee36;p=mit-scheme.git Insert X-Mailer and Organization fields after user finished editing message, rather than cluttering up the user's buffer with them. --- diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 880b7a26f..1b03489d5 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.259 2000/06/09 04:11:55 cph Exp $ +$Id: edwin.pkg,v 1.260 2000/06/12 01:38:24 cph Exp $ Copyright (c) 1989-2000 Massachusetts Institute of Technology @@ -1497,7 +1497,10 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. mail-from-string mail-header-end mail-insert-field + mail-insert-field-value + mail-insert-field-value! mail-match-header-separator + mail-new-field! mail-organization-string mail-position-on-field mail-position-on-cc-field diff --git a/v7/src/edwin/sendmail.scm b/v7/src/edwin/sendmail.scm index dc7262d6a..ce034e2ac 100644 --- a/v7/src/edwin/sendmail.scm +++ b/v7/src/edwin/sendmail.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: sendmail.scm,v 1.53 2000/06/09 04:11:33 cph Exp $ +;;; $Id: sendmail.scm,v 1.54 2000/06/12 01:38:12 cph Exp $ ;;; ;;; Copyright (c) 1991-2000 Massachusetts Institute of Technology ;;; @@ -307,26 +307,17 @@ is inserted." (if (string? value) (list (list key value #f)) '())))) - (let ((add-unique - (lambda (key value) - (add key - (and (not (list-search-positive headers - (lambda (header) - (string-ci=? (car header) key)))) - value))))) - (append headers - (add "Reply-to" - (let ((mail-default-reply-to - (ref-variable mail-default-reply-to buffer))) - (if (procedure? mail-default-reply-to) - (mail-default-reply-to) - mail-default-reply-to))) - (add "BCC" - (and (ref-variable mail-self-blind buffer) - (mail-from-string buffer))) - (add "FCC" (ref-variable mail-archive-file-name buffer)) - (add-unique "Organization" (mail-organization-string buffer)) - (add-unique "X-Mailer" (mailer-version-string buffer)))))) + (append headers + (add "Reply-to" + (let ((mail-default-reply-to + (ref-variable mail-default-reply-to buffer))) + (if (procedure? mail-default-reply-to) + (mail-default-reply-to) + mail-default-reply-to))) + (add "BCC" + (and (ref-variable mail-self-blind buffer) + (mail-from-string buffer))) + (add "FCC" (ref-variable mail-archive-file-name buffer))))) (define (mail-from-string buffer) (let ((address @@ -345,19 +336,6 @@ is inserted." (string-append (rfc822:quote-string full-name) " <" address ">")) (else address))))) - -(define (mail-organization-string buffer) - (let ((organization (ref-variable mail-organization buffer))) - (and (not (string-null? organization)) - organization))) - -(define (mailer-version-string buffer) - (and (ref-variable mail-identify-reader buffer) - (string-append "Edwin [version " - (get-subsystem-version-string "edwin") - ", MIT Scheme Release " - (get-subsystem-version-string "release") - "]"))) (define-variable mail-setup-hook "An event distributor invoked immediately after a mail buffer is initialized. @@ -655,6 +633,12 @@ the user from the mailer." (let ((header-end (copy-message mail-buffer end))) (if (re-search-forward "^FCC:" start header-end #t) (mail-do-fcc temp-buffer header-end)) + (let ((add-field + (lambda (name value) + (if (and value (not (mail-field-start start header-end name))) + (mail-insert-field-value header-end name value))))) + (add-field "Organization" (mail-organization-string mail-buffer)) + (add-field "X-Mailer" (mailer-version-string mail-buffer))) (process-header start header-end) (mark-temporary! header-end)) (mark-temporary! end) @@ -690,6 +674,19 @@ the user from the mailer." (mark-temporary! h-start) h-end))) +(define (mail-organization-string buffer) + (let ((organization (ref-variable mail-organization buffer))) + (and (not (string-null? organization)) + organization))) + +(define (mailer-version-string buffer) + (and (ref-variable mail-identify-reader buffer) + (string-append "Edwin [version " + (get-subsystem-version-string "edwin") + ", MIT Scheme Release " + (get-subsystem-version-string "release") + "]"))) + (define (send-mail-buffer mail-buffer lookup-buffer) (let ((error-buffer (and (ref-variable mail-interactive lookup-buffer) @@ -852,24 +849,6 @@ the user from the mailer." (define regexp:non-us-ascii (char-set->regexp char-set:non-us-ascii)) -(define (delete-mime-headers! h-start h-end) - (let loop ((f-start h-start)) - (if (mark< f-start h-end) - (let ((colon (search-forward ":" f-start (line-end f-start 0)))) - (if (not colon) - (error "Not a header-field line:" f-start)) - (let ((name (string-trim (extract-string f-start (mark-1+ colon)))) - (f-start* - (if (re-search-forward "^[^ \t]" colon h-end #f) - (re-match-start 0) - h-end))) - (if (or (string=? "mime-version" name) - (string-prefix? "content-" name)) - (begin - (delete-string f-start f-start*) - (loop f-start)) - (loop f-start*))))))) - (define (copy-mime-message-body-with-attachments start end attachments h-end output-mark) (let ((boundary (random-mime-boundary-string 32))) @@ -983,6 +962,24 @@ the user from the mailer." (string-append (symbol->string (car disposition)) (mime-parameters->string (cdr disposition)))) +(define (delete-mime-headers! h-start h-end) + (let loop ((f-start h-start)) + (if (mark< f-start h-end) + (let ((colon (search-forward ":" f-start (line-end f-start 0)))) + (if (not colon) + (error "Not a header-field line:" f-start)) + (let ((name (string-trim (extract-string f-start (mark-1+ colon)))) + (f-start* + (if (re-search-forward "^[^ \t]" colon h-end #f) + (re-match-start 0) + h-end))) + (if (or (string=? "mime-version" name) + (string-prefix? "content-" name)) + (begin + (delete-string f-start f-start*) + (loop f-start)) + (loop f-start*))))))) + (define (insert-headers headers mark) (for-each (lambda (nv) (mail-insert-field-value mark (car nv) (cadr nv))) diff --git a/v7/src/edwin/snr.scm b/v7/src/edwin/snr.scm index fdcf994f1..3f5d31962 100644 --- a/v7/src/edwin/snr.scm +++ b/v7/src/edwin/snr.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: snr.scm,v 1.57 2000/06/08 17:58:29 cph Exp $ +;;; $Id: snr.scm,v 1.58 2000/06/12 01:38:17 cph Exp $ ;;; ;;; Copyright (c) 1995-2000 Massachusetts Institute of Technology ;;; @@ -2794,9 +2794,7 @@ Once editing the article, type \\[describe-mode] to get a list of commands." (let ((buffer (make-mail-buffer `(("Newsgroups" ,(if group (news-group:name group) "")) - ("Subject" "") - ,@(x-newsreader-header - (current-news-server-buffer #f))) + ("Subject" "")) #f selector (if no-erase? @@ -2811,10 +2809,6 @@ Once editing the article, type \\[describe-mode] to get a list of commands." (set-buffer-point! buffer (mail-position-on-field buffer "Newsgroups")))))))) - -(define (x-newsreader-header buffer) - `(("X-Newsreader" ,(mailer-version-string buffer)) - ("X-Mailer" #F))) (define-command news-compose-followup-article "Begin editing a follow-up to the current News article. @@ -2879,8 +2873,7 @@ While composing the follow-up, use \\[mail-yank-original] to yank the ("Distribution" ,(let ((distribution (news-header:field-value header "distribution"))) (and (not (string-null? distribution)) - distribution))) - ,@(x-newsreader-header buffer)))) + distribution)))))) (define-major-mode compose-news mail "News" "Major mode for editing news to be posted on USENET. @@ -2946,16 +2939,21 @@ C-c C-q mail-fill-yanked-message (fill what was yanked)." (prepare-mail-buffer-for-sending article-buffer (news-post-process-headers article-buffer)))) - (if (let* ((start (buffer-start temp-buffer)) - (end (mail-header-end start))) - (or (mail-field-start start end "To") + (let* ((start (buffer-start temp-buffer)) + (end (mail-header-end start))) + (if (or (mail-field-start start end "To") (mail-field-start start end "CC") - (mail-field-start start end "BCC"))) - (let ((errors (send-mail-buffer temp-buffer article-buffer))) - (if errors - (begin - (kill-buffer temp-buffer) - (editor-error errors))))) + (mail-field-start start end "BCC")) + (let ((errors (send-mail-buffer temp-buffer article-buffer))) + (if errors + (begin + (kill-buffer temp-buffer) + (editor-error errors))))) + (let ((m (mail-field-start start end "X-Mailer"))) + (if m + (let ((ls (line-start m 0))) + (delete-string ls (mark-1+ (char-search-forward #\: ls m))) + (insert-string "X-Newsreader" ls))))) (let ((errors (post-news-buffer temp-buffer article-buffer))) (kill-buffer temp-buffer) (if errors (editor-error errors)))))) diff --git a/v7/src/imail/todo.txt b/v7/src/imail/todo.txt index 8ca2fe728..7eb7da85a 100644 --- a/v7/src/imail/todo.txt +++ b/v7/src/imail/todo.txt @@ -1,5 +1,5 @@ IMAIL To-Do List -$Id: todo.txt,v 1.75 2000/06/10 20:59:58 cph Exp $ +$Id: todo.txt,v 1.76 2000/06/12 01:39:09 cph Exp $ Bug fixes --------- @@ -23,11 +23,6 @@ New features * Support the "flagged" message flag by highlighting messages with this flag in the summary buffer. -* Change "X-Mailer" and "Organization" headers so that they are - transparently added after the user has finished editing. This will - keep the message composition buffer cleaner. There's no need to be - able to delete these on a per-message basis. - * When yanking formatted MIME messages into a reply buffer, attachments should probably be dropped altogether. Other simplifications might also be desirable, although I can't think of