From 69ec162a8763576de7efef6885e9fac61d261bc0 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 30 Apr 1995 06:54:43 +0000 Subject: [PATCH] * Generalize and simplify sendmail interface, to give more control over the configuration of a mail buffer by a program. * Restructure parts of the RMAIL code that deal with replies and output to mail files. Export some of this code for use by other programs. --- v7/src/edwin/edwin.pkg | 13 +- v7/src/edwin/rmail.scm | 397 ++++++++++++++++++++------------------ v7/src/edwin/sendmail.scm | 153 +++++++++------ v7/src/edwin/vc.scm | 13 +- 4 files changed, 326 insertions(+), 250 deletions(-) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index bb9fff2dd..aaa15e996 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.169 1995/04/17 21:46:25 cph Exp $ +$Id: edwin.pkg,v 1.170 1995/04/30 06:52:22 cph Exp $ Copyright (c) 1989-95 Massachusetts Institute of Technology @@ -1439,7 +1439,16 @@ MIT in each case. |# edwin-variable$rmail-primary-inbox-list edwin-variable$rmail-primary-pop-server edwin-variable$rmail-reply-with-re - rmail-spool-directory)) + prompt-for-rmail-output-filename + rfc822-addresses->string + rfc822-first-address + rfc822-region->babyl + rfc822-region-reply-headers + rfc822-strip-quoted-names + rmail-output-to-rmail-file + rmail-output-to-unix-mail-file + rmail-spool-directory + with-buffer-open)) (define-package (edwin stepper) (files "eystep") diff --git a/v7/src/edwin/rmail.scm b/v7/src/edwin/rmail.scm index 5ec44bd0f..116ef645a 100644 --- a/v7/src/edwin/rmail.scm +++ b/v7/src/edwin/rmail.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: rmail.scm,v 1.39 1995/04/23 06:08:53 cph Exp $ +;;; $Id: rmail.scm,v 1.40 1995/04/30 06:53:42 cph Exp $ ;;; ;;; Copyright (c) 1991-95 Massachusetts Institute of Technology ;;; @@ -987,8 +987,9 @@ While composing the message, use \\[mail-yank-original] to yank the original message into it." () (lambda () - (make-mail-buffer false select-buffer-other-window - false false false false (current-buffer)))) + (make-mail-buffer '(("To" "") ("Subject" "")) + (current-buffer) + select-buffer-other-window))) (define-command rmail-continue "Continue composing outgoing message previously being composed." @@ -1004,27 +1005,26 @@ original message into it." (memo (current-msg-memo))) (set-attribute! memo 'FORWARDED) (make-mail-buffer - false - (if (window-has-no-neighbors? (current-window)) - select-buffer - select-buffer-other-window) - false (without-clipping buffer (lambda () (with-values (lambda () (original-header-limits memo)) (lambda (start end) - (string-append - "[" - (let ((from (fetch-first-field "from" start end))) - (if from - (addresses->string (strip-quoted-names from)) - "")) - ": " - (or (fetch-first-field "subject" start end) "") - "]"))))) - false - false - false) + `(("To" "") + ("Subject" + ,(string-append + "[" + (let ((from (fetch-first-field "from" start end))) + (if from + (rfc822-addresses->string + (rfc822-strip-quoted-names from)) + "")) + ": " + (or (fetch-first-field "subject" start end) "") + "]"))))))) + #f + (if (window-has-no-neighbors? (current-window)) + select-buffer + select-buffer-other-window)) (insert-region (buffer-start buffer) (buffer-end buffer) (buffer-end (current-buffer)))))) @@ -1040,59 +1040,74 @@ original message into it." (let ((buffer (current-buffer)) (memo (current-msg-memo))) (set-attribute! memo 'ANSWERED) - (without-clipping buffer - (lambda () - (with-values (lambda () (original-header-limits memo)) - (lambda (start end) - (let ((resent-reply-to - (fetch-last-field "resent-reply-to" start end)) - (from (fetch-first-field "from" start end))) - (make-mail-buffer - false - select-buffer-other-window - (addresses->string - (strip-quoted-names - (or resent-reply-to - (fetch-all-fields "reply-to" start end) - from))) - (let ((subject - (or (and resent-reply-to - (fetch-last-field "resent-subject" start end)) - (fetch-first-field "subject" start end)))) - (if (ref-variable rmail-reply-with-re) - (if (and subject - (not (string-prefix-ci? "re: " subject))) - (string-append "Re: " subject) - subject) - (if (and subject (string-prefix-ci? "re: " subject)) - (string-tail subject 4) - subject))) - (if resent-reply-to - (make-in-reply-to-field - from - (fetch-last-field "resent-date" start end) - (fetch-last-field "resent-message-id" start end)) - (make-in-reply-to-field - from - (fetch-first-field "date" start end) - (fetch-first-field "message-id" start end))) - (and (not just-sender?) - (let ((to - (if resent-reply-to - (fetch-last-field "resent-to" start end) - (fetch-all-fields "to" start end))) - (cc - (if resent-reply-to - (fetch-last-field "resent-cc" start end) - (fetch-all-fields "cc" start end)))) - (let ((cc - (if (and to cc) - (string-append to ", " cc) - (or to cc)))) - (and cc - (addresses->string - (dont-reply-to (strip-quoted-names cc))))))) - buffer))))))))) + (make-mail-buffer (without-clipping buffer + (lambda () + (rfc822-region-reply-headers + (call-with-values + (lambda () (original-header-limits memo)) + make-region) + (not just-sender?)))) + buffer + select-buffer-other-window)))) + +(define (rfc822-region-reply-headers region cc?) + (let ((start (region-start region)) + (end (region-end region))) + (let ((resent-reply-to (fetch-last-field "resent-reply-to" start end)) + (from (fetch-first-field "from" start end))) + `(("To" + ,(rfc822-addresses->string + (rfc822-strip-quoted-names + (or resent-reply-to + (fetch-all-fields "reply-to" start end) + from)))) + ("CC" + ,(and cc? + (let ((to + (if resent-reply-to + (fetch-last-field "resent-to" start end) + (fetch-all-fields "to" start end))) + (cc + (if resent-reply-to + (fetch-last-field "resent-cc" start end) + (fetch-all-fields "cc" start end)))) + (let ((cc + (if (and to cc) + (string-append to ", " cc) + (or to cc)))) + (and cc + (let ((addresses + (dont-reply-to + (rfc822-strip-quoted-names cc)))) + (and (not (null? addresses)) + (rfc822-addresses->string addresses)))))))) + ("In-reply-to" + ,(if resent-reply-to + (make-in-reply-to-field + from + (fetch-last-field "resent-date" start end) + (fetch-last-field "resent-message-id" start end)) + (make-in-reply-to-field + from + (fetch-first-field "date" start end) + (fetch-first-field "message-id" start end)))) + ("Subject" + ,(let ((subject + (or (and resent-reply-to + (fetch-last-field "resent-subject" + start end)) + (fetch-first-field "subject" start end)))) + (cond ((not subject) "") + ((ref-variable rmail-reply-with-re) + (if (string-prefix-ci? "re:" subject) + subject + (string-append "Re: " subject))) + (else + (do ((subject + subject + (string-trim-left (string-tail subject 3)))) + ((not (string-prefix-ci? "re:" subject)) + subject)))))))))) (define (original-header-limits memo) (let ((start (msg-memo/start memo)) @@ -1156,7 +1171,7 @@ original message into it." (define (header-end start end) (or (search-forward "\n\n" start end false) end)) -(define (strip-quoted-names string) +(define (rfc822-strip-quoted-names string) (let ((address-list (strip-quoted-names-1 (string->rfc822-tokens string)))) (if (and address-list (null? (cdr address-list))) (car address-list) @@ -1183,9 +1198,10 @@ original message into it." (else (cons (car addresses) (loop (cdr addresses)))))))) -(define (addresses->string addresses) - (and (not (null? addresses)) - (separated-append addresses ", "))) +(define (rfc822-addresses->string addresses) + (if (null? addresses) + "" + (separated-append addresses ", "))) (define (separated-append tokens separator) (if (null? (cdr tokens)) @@ -1436,110 +1452,110 @@ If the file does not exist, ask if it should be created. If file is being visited, the message is appended to the buffer visiting that file." (lambda () - (list - (->namestring - (get-rmail-output-pathname "Output message to Rmail file" - (ref-variable rmail-last-rmail-file))))) - (lambda (filename) - (let* ((pathname (->pathname filename)) - (filename (->namestring pathname))) - (set-variable! rmail-last-rmail-file filename) - (let* ((memo (current-msg-memo)) - (message - (without-clipping (current-buffer) - (lambda () - (extract-string (msg-memo/start memo) - (msg-memo/end memo)))))) - (cond ((pathname->buffer pathname) - => - (lambda (buffer) - (if (current-buffer? buffer) - (editor-error - "Can't output message to same file it's already in")) - (with-buffer-open buffer - (lambda () - (let ((memo (buffer-msg-memo buffer)) - (end (buffer-end buffer))) - (let ((start (mark-right-inserting-copy end)) - (end (mark-left-inserting-copy end))) - (if memo - (delete-string (skip-chars-backward " \t\n" end) - end)) - (insert-string message end) - (if memo - (begin - (memoize-messages buffer start end) - (select-message buffer memo))) - (mark-temporary! start) - (mark-temporary! end))))))) - ((file-exists? pathname) - (let ((port (open-output-file pathname true))) - (write-string message port) - (close-output-port port))) - ((prompt-for-yes-or-no? - (string-append "\"" filename "\" does not exist, create it")) - (call-with-output-file pathname - (lambda (port) - (write-string babyl-initial-header port) - (write-string message port)))) - (else - (editor-error "Output file does not exist"))) - (set-attribute! memo 'FILED) - (if (ref-variable rmail-delete-after-output) - ((ref-command rmail-delete-forward) false)))))) + (list (prompt-for-rmail-output-filename + "Output message to Rmail file" + (ref-variable rmail-last-rmail-file)))) + (lambda (pathname) + (set-variable! rmail-last-rmail-file (->namestring pathname)) + (let ((memo (current-msg-memo))) + (rmail-output-to-rmail-file (make-region (msg-memo/start memo) + (msg-memo/end memo)) + pathname) + (set-attribute! memo 'FILED) + (if (ref-variable rmail-delete-after-output) + ((ref-command rmail-delete-forward) #f))))) + +(define (rmail-output-to-rmail-file region pathname) + ;; REGION is assumed to be in babyl format. + (let ((buffer (pathname->buffer pathname))) + (if buffer + (begin + (if (eq? buffer (mark-buffer (region-start region))) + (editor-error + "Can't output message to same file it's already in")) + (with-buffer-open buffer + (lambda () + (let ((memo (buffer-msg-memo buffer)) + (end (buffer-end buffer))) + (let ((start (mark-right-inserting-copy end)) + (end (mark-left-inserting-copy end))) + (if memo + (delete-string (skip-chars-backward " \t\n" end) + end)) + (insert-region (region-start region) + (region-end region) + end) + (if memo + (begin + (memoize-messages buffer start end) + (select-message buffer memo))) + (mark-temporary! start) + (mark-temporary! end)))))) + (begin + (if (not (file-exists? pathname)) + (begin + (if (not (prompt-for-yes-or-no? + (string-append "\"" (->namestring pathname) + "\" does not exist, create it"))) + (editor-error "Output file does not exist.")) + (call-with-output-file pathname + (lambda (port) + (write-string babyl-initial-header port))))) + (append-to-file region pathname #f))))) (define-command rmail-output "Append this message to Unix mail file named FILE-NAME." (lambda () - (list - (->namestring - (get-rmail-output-pathname "Output message to Unix mail file" - (ref-variable rmail-last-file))))) + (list (prompt-for-rmail-output-filename "Output message to Unix mail file" + (ref-variable rmail-last-file)))) (lambda (filename) - (let* ((pathname (->pathname filename))) - (set-variable! rmail-last-file (->namestring pathname)) - (let ((memo (current-msg-memo))) - (let ((buffer (temporary-buffer " rmail output"))) - (let ((end (mark-left-inserting-copy (buffer-end buffer)))) - (let ((buffer (current-buffer))) - (insert-region (buffer-start buffer) (buffer-end buffer) end)) - (insert-newline end) - (let loop ((start (buffer-start buffer))) - (if (re-search-forward "^From " start end true) - (loop (replace-match ">\\&")))) - (mark-temporary! end) - (let ((start (buffer-start buffer))) - (insert-string - (string-append - "From " - (or (first-address - (fetch-first-field "from" start (header-end start end))) - "unknown") - " " - (file-time->string (current-file-time)) - "\n") - start))) - (append-to-file (buffer-region buffer) pathname false) - (kill-buffer buffer)) - (set-attribute! memo 'FILED) - (if (ref-variable rmail-delete-after-output) - ((ref-command rmail-delete-forward) false)))))) - -(define (get-rmail-output-pathname prompt default) - (let ((default (->pathname default))) - (let ((name (file-pathname default))) - (let ((pathname - (prompt-for-pathname - (string-append prompt " (default " (->namestring name) ")") - (directory-pathname default) - false))) - (if (file-directory? pathname) - (merge-pathnames name (pathname-as-directory pathname)) - pathname))))) - -(define (first-address field) + (set-variable! rmail-last-file (->namestring filename)) + (let ((memo (current-msg-memo))) + (rmail-output-to-unix-mail-file (buffer-region (current-buffer)) + filename) + (set-attribute! memo 'FILED) + (if (ref-variable rmail-delete-after-output) + ((ref-command rmail-delete-forward) #f))))) + +(define (rmail-output-to-unix-mail-file region pathname) + ;; REGION is assumed to be in RFC-822 format. + (let ((buffer (temporary-buffer " rmail output"))) + (let ((end (mark-left-inserting-copy (buffer-end buffer)))) + (insert-region (region-start region) (region-end region) end) + (insert-newline end) + (let loop ((start (buffer-start buffer))) + (if (re-search-forward "^From " start end #t) + (loop (replace-match ">\\&")))) + (mark-temporary! end) + (let ((start (buffer-start buffer))) + (insert-string + (string-append + "From " + (or (rfc822-first-address + (fetch-first-field "from" start (header-end start end))) + "unknown") + " " + (file-time->string (current-file-time)) + "\n") + start))) + (append-to-file (buffer-region buffer) pathname #f) + (kill-buffer buffer))) + +(define (prompt-for-rmail-output-filename prompt default) + (->namestring + (let ((pathname + (prompt-for-pathname + (string-append prompt " (default " (file-namestring default) ")") + (directory-pathname default) + #f))) + (if (file-directory? pathname) + (merge-pathnames (file-pathname default) + (pathname-as-directory pathname)) + pathname)))) + +(define (rfc822-first-address field) (and field - (let ((addresses (strip-quoted-names field))) + (let ((addresses (rfc822-strip-quoted-names field))) (and (not (null? addresses)) (car addresses))))) @@ -1638,7 +1654,7 @@ Leaves original message, deleted, before the undigestified messages." (delete-string (skip-chars-backward " \t\n" end start) end) (insert-string "\n\037" end) (let ((digest-name - (first-address + (rfc822-first-address (let ((hend (header-end start end))) (or (fetch-first-field "Reply-To" start hend) (fetch-first-field "To" start hend) @@ -2032,18 +2048,17 @@ Leaves original message, deleted, before the undigestified messages." (loop m (+ count 1)))) ((re-match-forward umail-message-start-regexp point end false) (let ((point (mark-left-inserting-copy point))) - (insert-string babyl-initial-message-start point) (nuke-pinhead-header point end) (mark-temporary! point) - (process-message-body + (process-rfc822 point count (if (re-search-forward umail-message-end-regexp point end false) (re-match-start 0) end)))) ((re-match-forward mmdf-message-start-regexp point end true) - (let ((start (replace-match babyl-initial-message-start))) - (process-message-body + (let ((start (delete-match))) + (process-rfc822 start count (if (re-search-forward mmdf-message-end-regexp start end true) @@ -2053,14 +2068,9 @@ Leaves original message, deleted, before the undigestified messages." (editor-error "error converting to Babyl format") true))) - (define (process-message-body point count mend) + (define (process-rfc822 point count mend) (let ((mend (mark-left-inserting-copy mend))) - (do ((m point (replace-match "\n^_"))) - ((not (search-forward "\n\037" m mend false)))) - (let ((m (match-forward "\037" mend end false))) - (if m - (move-mark-to! mend m) - (insert-string "\037" mend))) + (rfc822-region->babyl (make-region point mend)) (mark-temporary! mend) (loop mend (+ count 1)))) @@ -2072,6 +2082,19 @@ Leaves original message, deleted, before the undigestified messages." (with-text-clipped start end (lambda () (loop (skip-chars-forward "\n" start end) 0)))) + +(define (rfc822-region->babyl region) + (let ((start (mark-left-inserting-copy (region-start region)))) + (insert-string babyl-initial-message-start start) + (mark-temporary! start) + (let ((end (mark-left-inserting-copy (region-end region)))) + ;; Eliminate babyl message-separation pair from message body. + (do ((m start (replace-match "\n^_"))) + ((not (search-forward "\n\037" m end #f)))) + (guarantee-newline end) + (if (not (eqv? (integer->char #o37) (extract-right-char end))) + (insert-string "\037" end)) + (mark-temporary! end)))) (define (convert-buffer-to-babyl-format buffer) (with-buffer-open buffer diff --git a/v7/src/edwin/sendmail.scm b/v7/src/edwin/sendmail.scm index a4bc0bf43..0248f238b 100644 --- a/v7/src/edwin/sendmail.scm +++ b/v7/src/edwin/sendmail.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: sendmail.scm,v 1.23 1995/04/10 20:21:31 cph Exp $ +;;; $Id: sendmail.scm,v 1.24 1995/04/30 06:54:22 cph Exp $ ;;; ;;; Copyright (c) 1991-95 Massachusetts Institute of Technology ;;; @@ -161,61 +161,92 @@ If mail-archive-file-name is non-false, an FCC field with that file name is inserted." "P" (lambda (no-erase?) - (make-mail-buffer no-erase? select-buffer false false false false false))) + (make-mail-buffer '(("To" "") ("Subject" "")) + #f + select-buffer + (if no-erase? + 'KEEP-PREVIOUS-MAIL + 'QUERY-DISCARD-PREVIOUS-MAIL)))) (define-command mail-other-window "Like `mail' command, but display mail buffer in another window." "P" (lambda (no-erase?) - (make-mail-buffer no-erase? select-buffer-other-window - false false false false false))) - -(define (make-mail-buffer no-erase? select-buffer - to subject in-reply-to cc reply-buffer) - (let ((buffer (find-or-create-buffer "*mail*"))) - (select-buffer buffer) - (if (and (not no-erase?) - (or (not (buffer-modified? buffer)) - (prompt-for-confirmation? - "Unsent message being composed; erase it"))) - (begin - (set-buffer-default-directory! buffer (default-homedir-pathname)) - (setup-buffer-auto-save! buffer) - (region-delete! (buffer-unclipped-region buffer)) - (mail-setup buffer to subject in-reply-to cc reply-buffer))))) + (make-mail-buffer '(("To" "") ("Subject" "")) + #f + select-buffer-other-window + (if no-erase? + 'KEEP-PREVIOUS-MAIL + 'QUERY-DISCARD-PREVIOUS-MAIL)))) + +(define (make-mail-buffer headers reply-buffer select-buffer + #!optional previous-mail-handling buffer-name mode) + (let ((buffer-name + (or (and (not (default-object? buffer-name)) + buffer-name) + "*mail*"))) + (let ((buffer (find-buffer buffer-name)) + (continue + (lambda (select?) + (let ((buffer (find-or-create-buffer buffer-name))) + (if select? (select-buffer buffer)) + (buffer-reset! buffer) + (set-buffer-default-directory! buffer + (default-homedir-pathname)) + (setup-buffer-auto-save! buffer) + (mail-setup buffer headers reply-buffer + (and (not (default-object? mode)) mode)))))) + (if buffer + (case (if (default-object? previous-mail-handling) + 'QUERY-DISCARD-PREVIOUS-MAIL + previous-mail-handling) + ((KEEP-PREVIOUS-MAIL) + (select-buffer buffer)) + ((DISCARD-PREVIOUS-MAIL) + (continue #t)) + ((QUERY-DISCARD-PREVIOUS-MAIL) + (select-buffer buffer) + (if (or (not (buffer-modified? buffer)) + (prompt-for-confirmation? + "Unsent message being composed; erase it")) + (continue #f))) + (else + (error:bad-range-argument previous-mail-handling + 'MAKE-MAIL-BUFFER))) + (continue #t))))) -(define (mail-setup buffer to subject in-reply-to cc reply-buffer) +(define (mail-setup buffer headers reply-buffer #!optional mode) (guarantee-mail-aliases) - (set-buffer-major-mode! buffer (ref-mode-object mail)) + (set-buffer-major-mode! buffer + (or (and (not (default-object? mode)) mode) + (ref-mode-object mail))) (local-set-variable! mail-reply-buffer reply-buffer) (let ((point (mark-left-inserting-copy (buffer-start buffer))) (fill (lambda (start end) (fill-region-as-paragraph start end - "\t" (ref-variable fill-column) + "\t" (ref-variable fill-column buffer) false)))) - (insert-string "To: " point) - (if to - (begin - (insert-string to point) - (fill (buffer-start buffer) point))) - (insert-newline point) - (if cc - (let ((start (mark-right-inserting point))) - (insert-string "CC: " point) - (insert-string cc point) - (fill start point) - (insert-newline point))) - (if in-reply-to - (begin - (insert-string "In-reply-to: " point) - (insert-string in-reply-to point) - (insert-newline point))) - (insert-string "Subject: " point) - (if subject - (insert-string subject point)) - (insert-newline point) - (let ((mail-default-reply-to (ref-variable mail-default-reply-to))) + (let ((start (mark-right-inserting-copy point))) + (for-each (lambda (header) + (let ((key (car header)) + (value (cadr header))) + (if value + (begin + (move-mark-to! start point) + (insert-string key point) + (insert-string ": " point) + (insert-string value point) + (if (and (not (string-null? value)) + (if (null? (cddr header)) + (or (string-ci=? key "to") + (string-ci=? key "cc")) + (caddr header))) + (fill start point)) + (insert-newline point))))) + headers) + (mark-temporary! start)) + (let ((mail-default-reply-to (ref-variable mail-default-reply-to buffer))) (let ((mail-default-reply-to (if (procedure? mail-default-reply-to) (mail-default-reply-to) @@ -225,33 +256,45 @@ is inserted." (insert-string "Reply-to: " point) (insert-string mail-default-reply-to point) (insert-newline point))))) - (let ((mail-header-function (ref-variable mail-header-function))) + (let ((mail-header-function (ref-variable mail-header-function buffer))) (if mail-header-function (mail-header-function point))) - (if (ref-variable mail-self-blind) + (if (ref-variable mail-self-blind buffer) (begin (insert-string "BCC: " point) (insert-string (current-user-name) point) (insert-newline point))) - (let ((mail-archive-file-name (ref-variable mail-archive-file-name))) + (let ((mail-archive-file-name + (ref-variable mail-archive-file-name buffer))) (if mail-archive-file-name (begin (insert-string "FCC: " point) (insert-string mail-archive-file-name point) (insert-newline point)))) - (insert-string (ref-variable mail-header-separator) point) + (insert-string (ref-variable mail-header-separator buffer) point) (insert-newline point) (mark-temporary! point)) - (set-buffer-point! buffer - (if to - (buffer-end buffer) - (mail-position-on-field buffer "To"))) - (if (not (or to subject in-reply-to)) - (buffer-not-modified! buffer)) - (event-distributor/invoke! (ref-variable mail-setup-hook))) + (let ((given-header? + (lambda (name) + (let ((header + (list-search-positive headers + (lambda (header) + (string-ci=? (car header) name))))) + (and header + (cadr header) + (not (string-null? (cadr header)))))))) + (set-buffer-point! buffer + (if (given-header? "to") + (buffer-end buffer) + (mail-position-on-field buffer "to"))) + (if (not (or (given-header? "to") + (given-header? "subject") + (given-header? "in-reply-to"))) + (buffer-not-modified! buffer))) + (event-distributor/invoke! (ref-variable mail-setup-hook buffer))) (define-variable mail-setup-hook - "An event distributor invoked immediately after a mail buffer initialized." + "An event distributor invoked immediately after a mail buffer is initialized." (make-event-distributor)) (define-major-mode mail text "Mail" diff --git a/v7/src/edwin/vc.scm b/v7/src/edwin/vc.scm index 1ec922b27..17dfeb731 100644 --- a/v7/src/edwin/vc.scm +++ b/v7/src/edwin/vc.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: vc.scm,v 1.20 1995/04/15 06:14:34 cph Exp $ +;;; $Id: vc.scm,v 1.21 1995/04/30 06:54:43 cph Exp $ ;;; ;;; Copyright (c) 1994-95 Massachusetts Institute of Technology ;;; @@ -384,9 +384,11 @@ lock steals will raise an error. (if (not (prompt-for-confirmation? (string-append "Take the lock on " file:rev " from " owner))) (editor-error "Steal cancelled.")) - (let ((mail-buffer (find-or-create-buffer "*VC-mail*"))) - (buffer-reset! mail-buffer) - (mail-setup mail-buffer owner file:rev #f #f #f) + (make-mail-buffer `(("To" ,owner) ("Subject" ,file:rev)) + #f + select-buffer-other-window + 'DISCARD-PREVIOUS-MAIL) + (let ((mail-buffer (current-buffer))) (let ((time (get-decoded-time))) (insert-string (string-append "I stole the lock on " file:rev @@ -405,8 +407,7 @@ lock steals will raise an error. (vc-revert-workfile-buffer master #t) ;; Send the mail after the steal has completed ;; successfully. - ((variable-default-value variable))))) - (pop-up-buffer mail-buffer #t))))) + ((variable-default-value variable))))))))) (message "Please explain why you are stealing the lock." " Type C-c C-c when done.")) -- 2.25.1