From: Chris Hanson Date: Fri, 22 Feb 2002 16:07:34 +0000 (+0000) Subject: Show MIME message/delivery-status parts inline. Simplify the MIME X-Git-Tag: 20090517-FFI~2216 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=533a8f93f9071af477b94d8f61d9fde9f3d7cfa4;p=mit-scheme.git Show MIME message/delivery-status parts inline. Simplify the MIME inline/outline decision logic. --- diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index a1f48b2df..a09d048f8 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.281 2002/02/22 15:39:02 cph Exp $ +;;; $Id: imail-top.scm,v 1.282 2002/02/22 16:07:34 cph Exp $ ;;; ;;; Copyright (c) 1999-2002 Massachusetts Institute of Technology ;;; @@ -160,8 +160,9 @@ Otherwise, they are inserted into the message body." "List of regular expressions matching character-set names. Text messages using these character sets are displayed inline; when other character sets are used, the text is treated as an attachment." - (list "us-ascii" "iso-8859-[0-9]+" "windows-[0-9]+" "unknown-8bit" - "utf-[78]" "unicode-[0-9]+-[0-9]+-utf-[78]") + (list "us-ascii" "iso-8859-[0-9]+" "utf-[78]" + "unicode-[0-9]+-[0-9]+-utf-[78]" ; RFC 1641 + "windows-[0-9]+" "unknown-8bit") list-of-strings?) (define-variable imail-inline-mime-text-subtypes @@ -1074,8 +1075,7 @@ With prefix argument, prompt even when point is on an attachment." (lambda (port) (call-with-mime-decoding-output-port (let ((encoding (mime-body-one-part-encoding body))) - (if (and (eq? (mime-body-type body) 'APPLICATION) - (eq? (mime-body-subtype body) 'MAC-BINHEX40) + (if (and (mime-type? body 'APPLICATION 'MAC-BINHEX40) (eq? encoding '7BIT)) 'BINHEX40 encoding)) @@ -2391,8 +2391,11 @@ Negative argument means search in reverse." (define (mime-enclosure-type? context type subtype) (let ((enclosure (walk-mime-context-enclosure context))) (and enclosure - (eq? (mime-body-type enclosure) type) - (eq? (mime-body-subtype enclosure) subtype)))) + (mime-type? enclosure type subtype)))) + +(define (mime-type? body type subtype) + (and (eq? (mime-body-type body) type) + (eq? (mime-body-subtype body) subtype))) (define (maybe-insert-mime-boundary context mark) (let ((boundary @@ -2433,45 +2436,43 @@ Negative argument means search in reverse." (mime-body-one-part-encoding body)))) (define-generic walk-mime-message-part (message body selector context mark)) -(define-generic insert-mime-message-inline* - (message body selector context mark)) -(define-generic compute-mime-message-outline (body name context)) +(define-generic inline-message-part? (body context mark)) (define-method walk-mime-message-part (message (body ) selector context mark) - (insert-mime-message-outline message body selector context mark)) - -(define-method insert-mime-message-inline* - (message (body ) selector context mark) - (call-with-auto-wrapped-output-mark - mark - (walk-mime-context-left-margin context) - body - (lambda (port) - (call-with-mime-decoding-output-port - (mime-part-encoding context body) - port - #t - (lambda (port) - (write-mime-message-body-part - message - (if (or (not (walk-mime-context-enclosure context)) - (mime-enclosure-type? context 'MESSAGE 'RFC822)) - `(,@selector TEXT) - selector) - (mime-body-one-part-n-octets body) - port)))))) + ((if (inline-message-part? body context mark) + insert-mime-message-inline + insert-mime-message-outline) + message body selector context mark)) -(define-method compute-mime-message-outline ((body ) name context) - context - (list (and name (cons "name" name)) - (cons "type" (mime-body-type-string body)) - (and (eq? (mime-body-type body) 'TEXT) - (cons "charset" (mime-body-parameter body 'CHARSET "us-ascii"))) - (let ((encoding (mime-body-one-part-encoding body))) - (and (not (known-mime-encoding? encoding)) - (cons "encoding" encoding))) - (cons "length" (mime-body-one-part-n-octets body)))) +(define-method inline-message-part? ((body ) context mark) + context mark + (mime-type? body 'MESSAGE 'DELIVERY-STATUS)) + +(define-method inline-message-part? ((body ) context mark) + body + (not (and (mime-enclosure-type? context 'MULTIPART 'DIGEST) + (ref-variable imail-mime-collapse-digest mark)))) + +(define-method inline-message-part? ((body ) context mark) + (and (let ((disposition (mime-body-disposition body))) + (if disposition + (eq? (car disposition) 'INLINE) + (or (not (walk-mime-context-enclosure context)) + (let ((subtype (mime-body-subtype body))) + (or (eq? subtype 'PLAIN) + (memq subtype + (ref-variable imail-inline-mime-text-subtypes + mark))))))) + (known-mime-encoding? (mime-part-encoding context body)) + (re-string-match + (string-append "\\`" + (apply regexp-group + (ref-variable imail-known-mime-charsets + mark)) + "\\'") + (mime-body-parameter body 'CHARSET "us-ascii") + #t))) (define-method walk-mime-message-part (message (body ) selector context mark) @@ -2510,73 +2511,6 @@ Negative argument means search in reverse." context mark))))) -(define-method walk-mime-message-part - (message (body ) selector context mark) - ((if (and (mime-enclosure-type? context 'MULTIPART 'DIGEST) - (ref-variable imail-mime-collapse-digest mark)) - insert-mime-message-outline - insert-mime-message-inline) - message body selector context mark)) - -(define-method insert-mime-message-inline* - (message (body ) selector context mark) - (insert-header-fields (with-string-output-port - (lambda (port) - (write-mime-message-body-part message - `(,@selector HEADER) - #t - port))) - #f - mark) - (walk-mime-message-part message - (mime-body-message-body body) - selector - (make-walk-mime-subcontext context body #f) - mark)) - -(define-method compute-mime-message-outline - ((body ) name context) - name - (let ((envelope (mime-body-message-envelope body))) - (list (and (not (mime-enclosure-type? context 'MULTIPART 'DIGEST)) - (cons "type" (mime-body-type-string body))) - (let ((from (mime-envelope-from envelope))) - (and (pair? from) - (cons - "from" - (or (mime-address-name (car from)) - (string-append (mime-address-mailbox (car from)) - "@" - (mime-address-host (car from))))))) - (let ((subject (mime-envelope-subject envelope))) - (and subject - (cons "subject" subject))) - (cons "length" (mime-body-one-part-n-octets body))))) - -(define-method walk-mime-message-part - (message (body ) selector context mark) - ((if (and (let ((disposition (mime-body-disposition body))) - (if disposition - (eq? (car disposition) 'INLINE) - (or (not (walk-mime-context-enclosure context)) - (let ((subtype (mime-body-subtype body))) - (or (eq? subtype 'PLAIN) - (memq subtype - (ref-variable imail-inline-mime-text-subtypes - mark))))))) - (known-mime-encoding? (mime-part-encoding context body)) - (re-string-match - (string-append "\\`" - (apply regexp-group - (ref-variable imail-known-mime-charsets - mark)) - "\\'") - (mime-body-parameter body 'CHARSET "us-ascii") - #t)) - insert-mime-message-inline - insert-mime-message-outline) - message body selector context mark)) - (define (insert-mime-message-inline message body selector context mark) (maybe-insert-mime-boundary context mark) (insert-mime-info (make-mime-info #t #t body selector context) @@ -2630,6 +2564,77 @@ Negative argument means search in reverse." (insert-string "/>" mark) (insert-newline mark))) +(define-generic insert-mime-message-inline* (msg body selector context mark)) + +(define-method insert-mime-message-inline* + (message (body ) selector context mark) + (call-with-auto-wrapped-output-mark + mark + (walk-mime-context-left-margin context) + body + (lambda (port) + (call-with-mime-decoding-output-port + (mime-part-encoding context body) + port + #t + (lambda (port) + (write-mime-message-body-part + message + (if (or (not (walk-mime-context-enclosure context)) + (mime-enclosure-type? context 'MESSAGE 'RFC822)) + `(,@selector TEXT) + selector) + (mime-body-one-part-n-octets body) + port)))))) + +(define-method insert-mime-message-inline* + (message (body ) selector context mark) + (insert-header-fields (with-string-output-port + (lambda (port) + (write-mime-message-body-part message + `(,@selector HEADER) + #t + port))) + #f + mark) + (walk-mime-message-part message + (mime-body-message-body body) + selector + (make-walk-mime-subcontext context body #f) + mark)) + +(define-generic compute-mime-message-outline (body name context)) + +(define-method compute-mime-message-outline ((body ) name context) + context + (list (and name (cons "name" name)) + (cons "type" (mime-body-type-string body)) + (and (eq? (mime-body-type body) 'TEXT) + (cons "charset" (mime-body-parameter body 'CHARSET "us-ascii"))) + (let ((encoding (mime-body-one-part-encoding body))) + (and (not (known-mime-encoding? encoding)) + (cons "encoding" encoding))) + (cons "length" (mime-body-one-part-n-octets body)))) + +(define-method compute-mime-message-outline + ((body ) name context) + name + (let ((envelope (mime-body-message-envelope body))) + (list (and (not (mime-enclosure-type? context 'MULTIPART 'DIGEST)) + (cons "type" (mime-body-type-string body))) + (let ((from (mime-envelope-from envelope))) + (and (pair? from) + (cons + "from" + (or (mime-address-name (car from)) + (string-append (mime-address-mailbox (car from)) + "@" + (mime-address-host (car from))))))) + (let ((subject (mime-envelope-subject envelope))) + (and subject + (cons "subject" subject))) + (cons "length" (mime-body-one-part-n-octets body))))) + (define (known-mime-encoding? encoding) (memq encoding '(7BIT 8BIT BINARY QUOTED-PRINTABLE BASE64