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 880b7a26f034cde038d5110342cda8cad8869372..1b03489d54082ef027b9970021584f94be70e939 100644 (file)
--- 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 dc7262d6aaa5e73465293e9226a2974d5dea7b76..ce034e2ac41d18d94dbe1d352c68201c5fe984a8 100644 (file)
--- 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")
-                     "]")))
 \f
 (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")
+                     "]")))
+\f
 (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))
 \f
-(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 fdcf994f1fdb75fe625adec9a508a5bc925e3b7f..3f5d319623ea5247c12db68f151687b14070c879 100644 (file)
--- 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)))
 \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))))))
 \f
 (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 8ca2fe728f9de12ca9d69d7161a8a8837c9ed926..7eb7da85a43af860590cbe513d015973dc70cbf3 100644 (file)
--- 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