From 6879c0605cbdf7a01339fd4534cf6e64b8fc7176 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 27 Apr 2000 02:16:47 +0000 Subject: [PATCH] Eliminate ability to edit the contents of a message. IMAP doesn't permit this, so we won't either. RMAIL is unusual among mail clients in permitting this. Additionally, eliminate generic procedure HEADER-FIELDS, and stop treating the "summary-line" header specially. --- v7/src/imail/imail-core.scm | 35 ++++++----------- v7/src/imail/imail-rmail.scm | 48 +++++++---------------- v7/src/imail/imail-top.scm | 76 ++---------------------------------- v7/src/imail/imail-umail.scm | 4 +- 4 files changed, 34 insertions(+), 129 deletions(-) diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index 7afd929ea..17d29884e 100644 --- a/v7/src/imail/imail-core.scm +++ b/v7/src/imail/imail-core.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-core.scm,v 1.30 2000/04/23 04:02:38 cph Exp $ +;;; $Id: imail-core.scm,v 1.31 2000/04/27 02:16:37 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -345,10 +345,8 @@ (define-class ( (constructor (header-fields body flags properties))) () - (header-fields define standard - accessor header-fields - modifier set-header-fields!) - (body define standard) + (header-fields define accessor) + (body define accessor) (flags define standard) (modified? define standard initial-value #t) @@ -397,7 +395,7 @@ (define (attach-message message folder) (guarantee-folder folder 'ATTACH-MESSAGE) (let ((message - (make-message (map copy-header-field (header-fields message)) + (make-message (map copy-header-field (message-header-fields message)) (message-body message) (list-copy (message-flags message)) (alist-copy (message-properties message))))) @@ -428,7 +426,7 @@ headers)) (define (message->string message) - (string-append (header-fields->string (header-fields message)) + (string-append (header-fields->string (message-header-fields message)) "\n" (message-body message))) @@ -671,12 +669,13 @@ (define (copy-header-field header) (record-copy header)) +(define (->header-fields object) + (cond ((or (pair? object) (null? object)) object) + ((message? object) (message-header-fields object)) + (else (error:wrong-type-argument object "header fields" #f)))) + (define (get-first-header-field headers name error?) - (let loop - ((headers - (if (or (pair? headers) (null? headers)) - headers - (header-fields headers)))) + (let loop ((headers (->header-fields headers))) (cond ((pair? headers) (if (string-ci=? name (header-field-name (car headers))) (car headers) @@ -685,12 +684,7 @@ (else #f)))) (define (get-last-header-field headers name error?) - (let loop - ((headers - (if (or (pair? headers) (null? headers)) - headers - (header-fields headers))) - (winner #f)) + (let loop ((headers (->header-fields headers)) (winner #f)) (cond ((pair? headers) (loop (cdr headers) (if (string-ci=? name (header-field-name (car headers))) @@ -701,10 +695,7 @@ (else winner)))) (define (get-all-header-fields headers name) - (list-transform-positive - (if (or (pair? headers) (null? headers)) - headers - (header-fields headers)) + (list-transform-positive (->header-fields headers) (lambda (header) (string-ci=? name (header-field-name header))))) diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm index 6c7352c3e..6fb28bad8 100644 --- a/v7/src/imail/imail-rmail.scm +++ b/v7/src/imail/imail-rmail.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-rmail.scm,v 1.18 2000/04/14 01:45:37 cph Exp $ +;;; $Id: imail-rmail.scm,v 1.19 2000/04/27 02:16:41 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -42,19 +42,19 @@ (define-method %new-folder ((url )) (let ((folder (make-rmail-folder url))) - (set-header-fields! folder (compute-rmail-folder-header-fields folder)) + (set-rmail-folder-header-fields! + folder + (compute-rmail-folder-header-fields folder)) (save-folder folder) folder)) ;;;; Folder -(define-class ( (constructor (url))) ()) +(define-class ( (constructor (url))) () + (header-fields define standard)) -(define-method header-fields ((folder )) - (folder-get folder 'RMAIL-HEADER-FIELDS '())) - -(define-method set-header-fields! ((folder ) headers) - (folder-put! folder 'RMAIL-HEADER-FIELDS headers)) +(define-method rmail-folder-header-fields ((folder )) + (compute-rmail-folder-header-fields folder)) (define-method %write-folder ((folder ) (url )) (write-rmail-file folder (file-url-pathname url)) @@ -64,9 +64,6 @@ (define-method poll-folder ((folder )) (rmail-get-new-mail folder)) -(define-method header-fields ((folder )) - (compute-rmail-folder-header-fields folder)) - (define (compute-rmail-folder-header-fields folder) (list (make-header-field "Version" " 5") (make-header-field "Labels" @@ -88,7 +85,7 @@ (define-method %revert-folder ((folder )) (call-with-binary-input-file (file-folder-pathname folder) (lambda (port) - (set-header-fields! folder (read-rmail-prolog port)) + (set-rmail-folder-header-fields! folder (read-rmail-prolog port)) (let loop () (let ((message (read-rmail-message port))) (if message @@ -128,16 +125,6 @@ (for-each (lambda (flag) (set-message-flag message flag)) flags) - (let ((headers (header-fields message))) - (if (and (pair? headers) - (string-ci=? "summary-line" - (header-field-name (car headers)))) - (begin - (set-message-property - message - (header-field-name (car headers)) - (header-field-value (car headers))) - (set-header-fields! message (cdr headers))))) message)))) (if formatted? (let ((message (finish headers))) @@ -186,7 +173,7 @@ (lambda (port) (write-string "BABYL OPTIONS: -*- rmail -*-" port) (newline port) - (write-header-fields (header-fields folder) port) + (write-header-fields (rmail-folder-header-fields folder) port) (write-char rmail-message:end-char port) (for-each (lambda (message) (write-rmail-message message port)) (file-folder-messages folder))))) @@ -194,7 +181,7 @@ (define (write-rmail-message message port) (write-char rmail-message:start-char port) (newline port) - (let ((headers (header-fields message)) + (let ((headers (message-header-fields message)) (displayed-headers (get-message-property message "displayed-header-fields" 'NONE))) (write-rmail-attributes-line message displayed-headers port) @@ -234,16 +221,9 @@ (define (write-rmail-properties message port) (let ((alist (message-properties message))) - (let ((summary-line - (list-search-positive alist - (lambda (n.v) - (string-ci=? "summary-line" (car n.v)))))) - (if summary-line - (%write-header-field (car summary-line) (cdr summary-line) port))) (for-each (lambda (n.v) - (if (not (or (string-ci=? "summary-line" (car n.v)) - (string-ci=? "displayed-header-fields" (car n.v)))) + (if (not (string-ci=? "displayed-header-fields" (car n.v))) (write-header-field (message-property->header-field (car n.v) (cdr n.v)) port))) @@ -275,7 +255,9 @@ (- (folder-length folder) initial-count))))) (define (rmail-folder-inbox-list folder) - (let ((inboxes (get-first-header-field-value folder "mail" #f))) + (let ((inboxes + (get-first-header-field-value (rmail-folder-header-fields folder) + "mail" #f))) (cond (inboxes (map (let ((directory (directory-pathname (file-folder-pathname folder)))) diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index 279189857..11e6c980d 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.23 2000/04/27 00:28:09 cph Exp $ +;;; $Id: imail-top.scm,v 1.24 2000/04/27 02:16:43 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -228,8 +228,7 @@ DEL Scroll to previous screen of this message. \\[imail-summary-by-recipients] Like \\[imail-summary] only just messages with particular recipient(s) are summarized. \\[imail-toggle-header] Toggle between full headers and reduced headers. - Normally only reduced headers are shown. -\\[imail-edit-current-message] Edit the current message. C-c C-c to return to IMAIL." + Normally only reduced headers are shown." (lambda (buffer) (buffer-put! buffer 'REVERT-BUFFER-METHOD imail-revert-buffer) (local-set-variable! mode-line-modified "--- " buffer) @@ -279,7 +278,6 @@ DEL Scroll to previous screen of this message. (define-key 'imail #\i 'imail-input) (define-key 'imail #\q 'imail-quit) (define-key 'imail #\? 'describe-mode) -(define-key 'imail #\w 'imail-edit-current-message) (define (imail-revert-buffer buffer dont-use-auto-save? dont-confirm?) dont-use-auto-save? @@ -458,7 +456,7 @@ With prefix argument N moves backward N messages with these flags." (insert-string (header-fields->string (if full-headers? - (header-fields message) + (message-header-fields message) (maybe-reformat-headers message buffer))) mark) (insert-newline mark) @@ -515,7 +513,7 @@ With prefix argument N moves backward N messages with these flags." (if (eq? 'NONE displayed) (let ((trimmed (let ((headers - (let ((headers (header-fields message)) + (let ((headers (message-header-fields message)) (regexp (ref-variable imail-ignored-headers buffer))) (if regexp @@ -812,72 +810,6 @@ While composing the reply, use \\[mail-yank-original] to yank the (strip-subject-re (string-trim-left (string-tail subject 3))) subject)) -;;;; Message editing - -(define-command imail-edit-current-message - "Edit the current IMAIL message." - () - (lambda () - ;; Guarantee that this buffer has both folder and message bindings. - (selected-folder) - (selected-message) - (let ((buffer (selected-buffer))) - (set-buffer-major-mode! buffer (ref-mode-object imail-edit)) - (set-buffer-writeable! buffer) - (message - (substitute-command-keys - "Editing: Type \\[imail-cease-edit] to return to Imail, \\[imail-abort-edit] to abort." - buffer))))) - -(define-major-mode imail-edit text "IMAIL Edit" - "Major mode for editing the contents of an IMAIL message. -The editing commands are the same as in Text mode, -together with two commands to return to regular IMAIL: - \\[imail-abort-edit] cancels the changes you have made and returns to IMAIL; - \\[imail-cease-edit] makes them permanent." - (lambda (buffer) - (enable-group-undo! (buffer-group buffer)))) - -(define-key 'imail-edit '(#\c-c #\c-c) 'imail-cease-edit) -(define-key 'imail-edit '(#\c-c #\c-\]) 'imail-abort-edit) - -(define-command imail-cease-edit - "Finish editing message; switch back to IMAIL proper." - () - (lambda () - (call-with-values - (lambda () - (let ((buffer (selected-buffer))) - (set-buffer-writeable! buffer) - (buffer-widen! buffer) - (guarantee-newline (buffer-end buffer)) - (let ((body-start - (search-forward "\n\n" - (buffer-start buffer) - (buffer-end buffer) - #f))) - (if body-start - (values (extract-string (buffer-start buffer) - (mark-1+ body-start)) - (extract-string body-start - (buffer-end buffer))) - (values (extract-string (buffer-start buffer) - (buffer-end buffer)) - ""))))) - (lambda (headers-string body) - (let ((message (selected-message))) - ;; **** The next line could generate an error. We need to - ;; figure out what to do if that happens. - (set-header-fields! message (string->header-fields headers-string)) - (set-message-body! message body) - (select-message (selected-folder) message #t)))))) - -(define-command imail-abort-edit - "Abort edit of current message; restore original contents." - () - (lambda () - (select-message (selected-folder) (selected-message) #t))) - ;;;; Miscellany (define-command imail-toggle-header diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm index 24f5721c5..82aac4840 100644 --- a/v7/src/imail/imail-umail.scm +++ b/v7/src/imail/imail-umail.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-umail.scm,v 1.11 2000/04/06 03:26:41 cph Exp $ +;;; $Id: imail-umail.scm,v 1.12 2000/04/27 02:16:47 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -162,7 +162,7 @@ (message-property->header-field (car n.v) (cdr n.v)) port))) (message-properties message)) - (write-header-fields (header-fields message) port) + (write-header-fields (message-header-fields message) port) (newline port) (for-each (lambda (line) (if (string-prefix-ci? "From " line) -- 2.25.1