From: Taylor R. Campbell <net/mumble/campbell>
Date: Mon, 8 Sep 2008 03:55:18 +0000 (+0000)
Subject: Refactor MIME support,
X-Git-Tag: 20090517-FFI~176
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3dbc0c5b34015f06fb1b1a792317b21f49d362eb;p=mit-scheme.git
Refactor MIME support,
- to make sense,
- to be more robust,
- to better reflect the terminology of the RFCs,
- to simplify code that uses MIME bodies,
- to move all generic MIME code into imail-mime.scm, and
- to fix a number of small bugs.
The documentation will need to be updated, since some user-visible
commands are now named with the word `body' rather than `entity'.
Undoubtedly, refactoring added many small bugs, too, still to be
weeded out.
---
diff --git a/v7/src/imail/ed-ffi.scm b/v7/src/imail/ed-ffi.scm
index 16cf958af..82241f47c 100644
--- a/v7/src/imail/ed-ffi.scm
+++ b/v7/src/imail/ed-ffi.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: ed-ffi.scm,v 1.26 2008/01/30 20:02:09 cph Exp $
+$Id: ed-ffi.scm,v 1.27 2008/09/08 03:55:14 riastradh Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -32,7 +32,7 @@ USA.
("imail-core" (edwin imail))
("imail-file" (edwin imail file-folder))
("imail-imap" (edwin imail imap-folder))
- ("imail-mime" (edwin imail mime))
+ ("imail-mime" (edwin imail mime))
("imail-rmail" (edwin imail file-folder rmail-folder))
("imail-summary" (edwin imail front-end summary))
("imail-top" (edwin imail front-end))
diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index 9efeb97ab..280a24309 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.174 2008/08/31 23:02:17 riastradh Exp $
+$Id: imail-core.scm,v 1.175 2008/09/08 03:55:17 riastradh Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -29,82 +29,6 @@ USA.
(declare (usual-integrations))
-;;;; Properties
-
-(define-class <property-mixin> ()
- (alist define (accessor modifier)
- accessor object-properties
- modifier set-object-properties!
- initial-value '()))
-
-(define (get-property object key default)
- (let ((entry (assq key (object-properties object))))
- (if entry
- (cdr entry)
- default)))
-
-(define (store-property! object key datum)
- (let ((alist (object-properties object)))
- (let ((entry (assq key alist)))
- (if entry
- (set-cdr! entry datum)
- (set-object-properties! object (cons (cons key datum) alist))))))
-
-(define (remove-property! object key)
- (set-object-properties! object (del-assq! key (object-properties object))))
-
-;;;; Modification events
-
-(define-class <modification-event-mixin> ()
- (modification-count define (accessor modifier)
- accessor object-modification-count
- modifier set-object-modification-count!
- initial-value 0)
- (modification-event define accessor
- accessor object-modification-event
- initializer make-event-distributor))
-
-(define (receive-modification-events object procedure)
- (add-event-receiver! (object-modification-event object) procedure))
-
-(define (ignore-modification-events object procedure)
- (remove-event-receiver! (object-modification-event object) procedure))
-
-(define (object-modified! object type . arguments)
- (without-interrupts
- (lambda ()
- (set-object-modification-count!
- object
- (+ (object-modification-count object) 1))))
- (apply signal-modification-event object type arguments))
-
-(define (signal-modification-event object type . arguments)
- (if *deferred-modification-events*
- (set-cdr! *deferred-modification-events*
- (cons (cons* object type arguments)
- (cdr *deferred-modification-events*)))
- (begin
- (if imap-trace-port
- (begin
- (write-line (cons* 'OBJECT-EVENT object type arguments)
- imap-trace-port)
- (flush-output imap-trace-port)))
- (event-distributor/invoke! (object-modification-event object)
- object
- type
- arguments))))
-
-(define (with-modification-events-deferred thunk)
- (let ((events (list 'EVENTS)))
- (let ((v
- (fluid-let ((*deferred-modification-events* events))
- (thunk))))
- (for-each (lambda (event) (apply signal-modification-event event))
- (reverse! (cdr events)))
- v)))
-
-(define *deferred-modification-events* #f)
-
;;;; URL type
(define-class <url> (<property-mixin>)
@@ -646,19 +570,24 @@ USA.
(define-generic message-internal-time (message))
(define-generic message-length (message))
-(define-generic message-body (message))
-(define-method message-body ((message <message>))
- (let ((string (call-with-output-string
- (lambda (output-port)
- (write-message-body message output-port)))))
- (values string 0 (string-length string))))
-
(define (message-index message)
(let ((index (%message-index message))
(folder (message-folder message)))
(if folder
(unmap-folder-index folder index)
index)))
+
+;;; Messages are MIME entities.
+
+(define-method mime-entity? ((message <message>))
+ message ;ignore
+ #t)
+
+(define-method mime-entity-header-fields ((message <message>))
+ (message-header-fields message))
+
+(define-method write-mime-entity-body ((message <message>) port)
+ (write-message-body message port))
(define %set-message-flags!
(let ((modifier (slot-modifier <message> 'FLAGS)))
@@ -1204,229 +1133,3 @@ USA.
(define internal-header-field-prefix-length
(string-length internal-header-field-prefix))
-
-;;;; MIME structure
-
-(define-generic mime-message-body-structure (message))
-(define-generic write-mime-message-body-part (message selector cache? port))
-
-(define-class <mime-body> (<property-mixin>)
- (parameters define accessor)
- (disposition define accessor)
- (language define accessor)
- (enclosure define standard initial-value #f))
-
-(define-generic mime-body-type (body))
-(define-generic mime-body-subtype (body))
-
-(define (mime-body-type-string body)
- (string-append (symbol->string (mime-body-type body))
- "/"
- (symbol->string (mime-body-subtype body))))
-
-(define (mime-body-parameter body key default)
- (let ((entry (assq key (mime-body-parameters body))))
- (if entry
- (cdr entry)
- default)))
-
-(define (mime-body-disposition-filename body)
- (let ((disposition (mime-body-disposition body)))
- (and disposition
- (let ((entry (assq 'FILENAME (cdr disposition))))
- (and entry
- (cdr entry))))))
-
-(define-method write-instance ((body <mime-body>) port)
- (write-instance-helper 'MIME-BODY body port
- (lambda ()
- (write-char #\space port)
- (write-string (mime-body-type-string body) port))))
-
-(define (mime-body-enclosed? b1 b2)
- (or (eq? b1 b2)
- (let ((enclosure (mime-body-enclosure b1)))
- (and enclosure
- (mime-body-enclosed? enclosure b2)))))
-
-(define-class <mime-body-one-part> (<mime-body>)
- (id define accessor)
- (description define accessor)
- (encoding define accessor)
- (n-octets define accessor)
- (md5 define accessor))
-
-(define-class (<mime-body-message>
- (constructor (parameters id description encoding n-octets
- envelope body n-lines
- md5 disposition language)))
- (<mime-body-one-part>)
- (envelope define accessor) ;<mime-envelope> instance
- (body define accessor) ;<mime-body> instance
- (n-lines define accessor))
-
-(define-method mime-body-type ((body <mime-body-message>)) body 'MESSAGE)
-(define-method mime-body-subtype ((body <mime-body-message>)) body 'RFC822)
-
-(define-class (<mime-body-text>
- (constructor (subtype parameters id description encoding
- n-octets n-lines
- md5 disposition language)))
- (<mime-body-one-part>)
- (subtype accessor mime-body-subtype)
- (n-lines define accessor))
-
-(define-method mime-body-type ((body <mime-body-text>)) body 'TEXT)
-
-(define-class (<mime-body-basic>
- (constructor (type subtype parameters id description encoding
- n-octets md5 disposition language)))
- (<mime-body-one-part>)
- (type accessor mime-body-type)
- (subtype accessor mime-body-subtype))
-
-(define-class (<mime-body-multipart>
- (constructor (subtype parameters parts disposition language)))
- (<mime-body>)
- (subtype accessor mime-body-subtype)
- (parts define accessor))
-
-(define-method mime-body-type ((body <mime-body-multipart>)) body 'MULTIPART)
-
-(define-class (<mime-envelope>
- (constructor (date subject from sender reply-to to cc bcc
- in-reply-to message-id)))
- ()
- (date define accessor)
- (subject define accessor)
- (from define accessor)
- (sender define accessor)
- (reply-to define accessor)
- (to define accessor)
- (cc define accessor)
- (bcc define accessor)
- (in-reply-to define accessor)
- (message-id define accessor))
-
-(define-class (<mime-address> (constructor (name source-route mailbox host)))
- ()
- (name define accessor)
- (source-route define accessor)
- (mailbox define accessor)
- (host define accessor))
-
-;;;; MIME Encoding Registry
-;;; This should probably be moved to the runtime's MIME codec package.
-
-(define-structure (mime-encoding
- (conc-name mime-encoding/)
- (print-procedure
- (standard-unparser-method 'MIME-ENCODING
- (lambda (encoding output-port)
- (write-char #\space output-port)
- (write (mime-encoding/name encoding) output-port))))
- (constructor %make-mime-encoding))
- (name #f read-only #t)
- (identity? #f read-only #t)
- (encoder-initializer #f read-only #t)
- (encoder-finalizer #f read-only #t)
- (encoder-updater #f read-only #t)
- (decoder-initializer #f read-only #t)
- (decoder-finalizer #f read-only #t)
- (decoder-updater #f read-only #t)
- (decoding-port-maker #f read-only #t)
- (caller-with-decoding-port #f read-only #t))
-
-(define-guarantee mime-encoding "MIME codec")
-
-(define mime-encodings
- (make-eq-hash-table))
-
-(define (define-mime-encoding name
- encode:initialize encode:finalize encode:update
- decode:initialize decode:finalize decode:update
- make-port call-with-port)
- (hash-table/put!
- mime-encodings
- name
- (%make-mime-encoding name #f
- encode:initialize encode:finalize encode:update
- decode:initialize decode:finalize decode:update
- make-port call-with-port))
- name)
-
-(define (define-identity-mime-encoding name)
- (hash-table/put! mime-encodings
- name
- (%make-mime-encoding name #t
-
- (lambda (port text?) text? port)
- output-port/flush-output
- output-port/write-string
-
- (lambda (port text?) text? port)
- output-port/flush-output
- output-port/write-string
-
- (lambda (port text?) text? port)
- (lambda (port text? generator)
- text?
- (generator port)))))
-
-(define (named-mime-encoding name)
- (or (hash-table/get mime-encodings name #f)
- (let ((encoding (make-unknown-mime-encoding name)))
- (hash-table/put! mime-encodings name encoding)
- encoding)))
-
-(define (make-unknown-mime-encoding name)
- (let ((lose (lambda args args (error "Unknown MIME encoding name:" name))))
- (%make-mime-encoding name #f
- lose lose lose
- lose lose lose
- lose lose)))
-
-(define (call-with-mime-decoding-output-port encoding port text? generator)
- ((mime-encoding/caller-with-decoding-port
- (if (symbol? encoding)
- (named-mime-encoding encoding)
- (begin
- (guarantee-mime-encoding encoding
- 'CALL-WITH-MIME-DECODING-OUTPUT-PORT)
- encoding)))
- port text? generator))
-
-(define-identity-mime-encoding '7BIT)
-(define-identity-mime-encoding '8BIT)
-(define-identity-mime-encoding 'BINARY)
-;; Next two are random values sometimes used by Outlook.
-(define-identity-mime-encoding '7-BIT)
-(define-identity-mime-encoding '8-BIT)
-
-(define-mime-encoding 'QUOTED-PRINTABLE
- encode-quoted-printable:initialize
- encode-quoted-printable:finalize
- encode-quoted-printable:update
- decode-quoted-printable:initialize
- decode-quoted-printable:finalize
- decode-quoted-printable:update
- make-decode-quoted-printable-port
- call-with-decode-quoted-printable-output-port)
-
-(define-mime-encoding 'BASE64
- encode-base64:initialize
- encode-base64:finalize
- encode-base64:update
- decode-base64:initialize
- decode-base64:finalize
- decode-base64:update
- make-decode-base64-port
- call-with-decode-base64-output-port)
-
-(define-mime-encoding 'BINHEX40
- #f #f #f ;No BinHex encoder.
- decode-binhex40:initialize
- decode-binhex40:finalize
- decode-binhex40:update
- make-decode-binhex40-port
- call-with-decode-binhex40-output-port)
diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index c92e97777..cc6588d67 100644
--- a/v7/src/imail/imail-imap.scm
+++ b/v7/src/imail/imail-imap.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: imail-imap.scm,v 1.232 2008/09/02 17:19:10 riastradh Exp $
+$Id: imail-imap.scm,v 1.233 2008/09/08 03:55:18 riastradh Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -357,7 +357,7 @@ USA.
url
;; Some IMAP servers don't like a mailbox of `/%' in LIST
;; commands, and others simply returna uselessly empty
- ;; result, so we have a special case for the root mailbox.
+ ;; result, so we have a special case for the root mailbox.
(if (string=? prefix "/")
"%"
(string-append (imap-mailbox/url->server url prefix) "%"))))
@@ -372,7 +372,7 @@ USA.
;; container URL as an answer to the LIST
;; command, but it is uninteresting here, so
;; we filter it out. (Should this filtering
- ;; be done by RUN-LIST-COMMAND?)
+ ;; be done by RUN-LIST-COMMAND?)
(if (eq? container-url url)
results
(cons container-url results))))
@@ -1123,13 +1123,11 @@ USA.
(length)
(envelope)
(bodystructure)
- (body-parts define standard initial-value '())
+ (body-parts define standard initializer (lambda () (weak-cons #f '())))
(cached-keywords define standard initial-value '()))
(define-generic imap-message-uid (message))
-(define-generic imap-message-length (message))
(define-generic imap-message-envelope (message))
-(define-generic imap-message-bodystructure (message))
(define-method set-message-flags! ((message <imap-message>) flags)
(with-imap-message-open message
@@ -1178,12 +1176,6 @@ USA.
(define-method message-internal-time ((message <imap-message>))
(fetch-one-message-item message 'INTERNALDATE "internal date"))
-(define-method message-length ((message <imap-message>))
- (with-imap-message-open message
- (lambda (connection)
- connection
- (imap-message-length message))))
-
(define (with-imap-message-open message receiver)
(let ((folder (message-folder message)))
(if folder
@@ -1237,8 +1229,8 @@ USA.
(guarantee-slot-initialized message initpred noun keywords)
(accessor message))))))
(reflector message-flags 'FLAGS "flags" '(FLAGS))
- (reflector imap-message-length 'LENGTH "length" '(RFC822.SIZE))
- (reflector imap-message-bodystructure 'BODYSTRUCTURE "MIME structure"
+ (reflector message-length 'LENGTH "length" '(RFC822.SIZE))
+ (reflector mime-entity-body-structure 'BODYSTRUCTURE "MIME structure"
'(BODYSTRUCTURE)))
;;; Some hair to keep weak references to header fields and envelopes,
@@ -1310,13 +1302,13 @@ USA.
(lambda (index message)
(if (zero? (remainder index 10))
(imail-ui:progress-meter index length))
- (cond ((imap-message-bodystructure message)
+ (cond ((mime-entity-body-structure message)
=> (lambda (body-structure)
(walk-mime-body message body-structure
- (lambda (selector)
+ (lambda (body-part)
(fetch-message-body-part-to-cache
message
- (mime-selector->imap-section selector))))))
+ (imap-mime-body-section-text body-part))))))
(else
(fetch-message-body-part-to-cache message '(TEXT))))))))))
@@ -1400,59 +1392,184 @@ USA.
;;;; MIME support
-(define-method mime-message-body-structure ((message <imap-message>))
- (imap-message-bodystructure message))
-
+(define-class <imap-mime-body> ()
+ (message define accessor)
+ (section define accessor)
+ (header-fields))
+
+(let ((accessor (slot-accessor <imap-mime-body> 'HEADER-FIELDS))
+ (modifier (slot-modifier <imap-mime-body> 'HEADER-FIELDS))
+ (initpred (slot-initpred <imap-mime-body> 'HEADER-FIELDS)))
+ (define (fetch body store)
+ (let ((value
+ (lines->header-fields
+ (string->lines
+ (fetch-message-body-part
+ (imap-mime-body-message body)
+ `(,@(imap-mime-body-section body) MIME))))))
+ (store value)
+ value))
+ (define-method mime-body-header-fields ((body <imap-mime-body>))
+ (if (initpred body)
+ (let* ((pair (accessor body))
+ (header-fields (weak-car pair)))
+ (if (weak-pair/car? pair)
+ header-fields
+ (fetch body
+ (lambda (header-fields)
+ (weak-set-car! pair header-fields)))))
+ (fetch body
+ (lambda (header-fields)
+ (modifier body (weak-cons header-fields '())))))))
+
+(define-class (<imap-mime-body-basic>
+ (constructor (message
+ section
+ type subtype parameters id description encoding
+ n-octets
+ md5 disposition language)))
+ (<mime-body-basic> <imap-mime-body>))
+
+(define-class (<imap-mime-body-text>
+ (constructor (message
+ section
+ subtype parameters id description encoding
+ n-octets n-lines md5 disposition language)))
+ (<mime-body-text> <imap-mime-body>))
+
+(define-class (<imap-mime-body-message>
+ (constructor (message
+ section
+ parameters id description encoding n-octets
+ envelope body n-lines md5 disposition language)))
+ (<mime-body-message> <imap-mime-body>))
+
+(define-class (<imap-mime-body-multipart>
+ (constructor (message
+ section
+ subtype parameters parts disposition language)))
+ (<mime-body-multipart> <imap-mime-body>))
+
(define-method write-message-body ((message <imap-message>) port)
- (write-mime-message-body-part
- message '(TEXT) (imap-message-length message) port))
-
-(define (mime-selector->imap-section selector)
- (if (pair? selector)
- (map (lambda (x)
- (if (exact-nonnegative-integer? x)
- (+ x 1)
- x))
- selector)
- '(TEXT)))
-
-(define-method write-mime-message-body-part
- ((message <imap-message>) selector cache? port)
- (let ((section (mime-selector->imap-section selector)))
- (let ((entry
- (list-search-positive (imap-message-body-parts message)
- (lambda (entry)
- (equal? (car entry) section)))))
- (cond (entry
- (write-string (cdr entry) port))
- ((and cache?
- (let ((limit (imail-ui:body-cache-limit message)))
- (and limit
- (if (and (exact-nonnegative-integer? cache?)
- (exact-nonnegative-integer? limit))
- (< cache? limit)
- #t))))
- (let ((part (fetch-message-body-part message section)))
- (set-imap-message-body-parts!
- message
- (cons (cons section part)
- (imap-message-body-parts message)))
- (write-string part port)))
- (else
- (fetch-message-body-part-to-port message section port))))))
+ (write-imap-message-section message '(TEXT) (message-length message) port))
+
+(define-method write-mime-body ((body <imap-mime-body>) port)
+ (write-imap-message-section
+ (imap-mime-body-message body)
+ (imap-mime-body-section-text body)
+ ;++ Kludge. The IMAP includes the length in octets only for
+ ;++ one-part bodies.
+ (and (mime-body-one-part? body)
+ (mime-body-one-part-n-octets body))
+ port))
+
+(define (imap-mime-body-section-text body)
+ `(,@(imap-mime-body-section body)
+ ,@(if (let ((enclosure (mime-body-enclosure body)))
+ (or (not enclosure)
+ (mime-body-message? enclosure)))
+ '(TEXT)
+ '())))
+
+(define-method mime-body-message-header-fields ((body <mime-body-message>))
+ (lines->header-fields
+ (string->lines
+ (call-with-output-string
+ (lambda (port)
+ (write-imap-message-section (imap-mime-body-message body)
+ `(,@(imap-mime-body-section body) HEADER)
+ #f
+ port))))))
+
+(define (write-imap-message-section message section length port)
+ (cond ((search-imap-message-body-parts message section)
+ => (lambda (entry)
+ (write-string (cdr entry) port)))
+ ((and length
+ (let ((limit (imail-ui:body-cache-limit message)))
+ (and limit
+ (if (and (exact-nonnegative-integer? length)
+ (exact-nonnegative-integer? limit))
+ (< length limit)
+ #t))))
+ (let ((part (fetch-message-body-part message section)))
+ (cache-imap-message-body-part message section part)
+ (write-string part port)))
+ (else
+ (fetch-message-body-part-to-port message section port))))
+
+(define (search-imap-message-body-parts message section)
+ (define (scan-positive body-parts previous)
+ (and (weak-pair? body-parts)
+ (let ((entry (weak-car body-parts)))
+ (if entry
+ (if (equal? section (car entry))
+ entry
+ (scan-positive (weak-cdr body-parts) body-parts))
+ (scan-negative (weak-cdr body-parts) previous)))))
+ (define (scan-negative body-parts previous)
+ (if (weak-pair? body-parts)
+ (let ((entry (weak-car body-parts)))
+ (if entry
+ (begin
+ (weak-set-cdr! previous body-parts)
+ (if (equal? section (car entry))
+ entry
+ (scan-positive (weak-cdr body-parts) body-parts)))
+ (scan-negative (weak-cdr body-parts) previous)))
+ (begin
+ (weak-set-cdr! previous '())
+ #f)))
+ (let ((initial (imap-message-body-parts message)))
+ (scan-positive (weak-cdr initial) initial)))
+
+(define (cache-imap-message-body-part message section part)
+ (let ((pair (imap-message-body-parts message)))
+ (weak-set-cdr! pair (weak-cons (cons section part) (weak-cdr pair)))))
-(define (parse-mime-body body)
- (cond ((not (and (pair? body) (list? body))) (parse-mime-body:lose body))
- ((string? (car body)) (parse-mime-body:one-part body))
- ((pair? (car body)) (parse-mime-body:multi-part body))
- (else (parse-mime-body:lose body))))
+(define (parse-mime-body body message section)
+ (cond ((not (and (pair? body) (list? body)))
+ (parse-mime-body:lose body message section))
+ ((string? (car body))
+ (parse-mime-body:one-part body message section))
+ ((pair? (car body))
+ (parse-mime-body:multi-part body message section))
+ (else
+ (parse-mime-body:lose body message section))))
-(define (parse-mime-body:one-part body)
+(define (parse-mime-body:multi-part body message section)
+ (let loop ((tail body) (index 0))
+ (if (not (pair? tail))
+ (parse-mime-body:lose body))
+ (if (string? (car tail))
+ (let ((enclosed
+ (map (lambda (body index)
+ (parse-mime-body body message `(,@section ,index)))
+ (sublist body 0 index)
+ (iota index 1)))
+ (extensions
+ (parse-mime-body:extensions (cdr tail))))
+ (let ((enclosure
+ (make-imap-mime-body-multipart message
+ section
+ (intern (car tail))
+ (parse-mime-parameters
+ (car extensions))
+ enclosed
+ (cadr extensions)
+ (caddr extensions))))
+ (for-each (lambda (enclosed)
+ (set-mime-body-enclosure! enclosed enclosure))
+ enclosed)
+ enclosure))
+ (loop (cdr tail) (fix:+ index 1)))))
+
+(define (parse-mime-body:one-part body message section)
(let ((n (length body)))
(cond ((string-ci=? "text" (car body))
(if (not (fix:>= n 8))
- (parse-mime-body:lose body))
- (apply make-mime-body-text
+ (parse-mime-body:lose body message section))
+ (apply make-imap-mime-body-text message section
(intern (list-ref body 1))
(parse-mime-parameters (list-ref body 2))
(list-ref body 3)
@@ -1464,10 +1581,11 @@ USA.
((and (string-ci=? "message" (car body))
(string-ci=? "rfc822" (cadr body)))
(if (not (fix:>= n 10))
- (parse-mime-body:lose body))
- (let* ((enclosed (parse-mime-body (list-ref body 8)))
+ (parse-mime-body:lose body message section))
+ (let* ((enclosed
+ (parse-mime-body (list-ref body 8) message section))
(enclosure
- (apply make-mime-body-message
+ (apply make-imap-mime-body-message message section
(parse-mime-parameters (list-ref body 2))
(list-ref body 3)
(list-ref body 4)
@@ -1481,8 +1599,8 @@ USA.
enclosure))
(else
(if (not (fix:>= n 7))
- (parse-mime-body:lose body))
- (apply make-mime-body-basic
+ (parse-mime-body:lose body message section))
+ (apply make-imap-mime-body-basic message section
(intern (list-ref body 0))
(intern (list-ref body 1))
(parse-mime-parameters (list-ref body 2))
@@ -1491,26 +1609,6 @@ USA.
(intern (list-ref body 5))
(list-ref body 6)
(parse-mime-body:extensions (list-tail body 7)))))))
-
-(define (parse-mime-body:multi-part body)
- (let loop ((tail body) (index 0))
- (if (not (pair? tail))
- (parse-mime-body:lose body))
- (if (string? (car tail))
- (let ((enclosed (map parse-mime-body (sublist body 0 index)))
- (extensions (parse-mime-body:extensions (cdr tail))))
- (let ((enclosure
- (make-mime-body-multipart (intern (car tail))
- (parse-mime-parameters
- (car extensions))
- enclosed
- (cadr extensions)
- (caddr extensions))))
- (for-each (lambda (enclosed)
- (set-mime-body-enclosure! enclosed enclosure))
- enclosed)
- enclosure))
- (loop (cdr tail) (fix:+ index 1)))))
(define (parse-mime-body:extensions tail)
(if (pair? tail)
@@ -1522,8 +1620,8 @@ USA.
(list (car tail) #f #f))
(list #f #f #f)))
-(define (parse-mime-body:lose body)
- (error "Unrecognized MIME bodystructure:" body))
+(define (parse-mime-body:lose body message section)
+ (error "Unrecognized MIME bodystructure:" body message section))
(define (parse-mime-parameters parameters)
(if parameters
@@ -1719,15 +1817,15 @@ USA.
(cons keyword
(if (memq keyword imap-dynamic-keywords)
'()
- (let ((pathname
- (message-item-pathname message
+ (let ((pathname
+ (message-item-pathname message
keyword)))
- (if (file-exists? pathname)
- (list
- (read-cached-message-item message
- keyword
- pathname))
- '())))))
+ (if (file-exists? pathname)
+ (list
+ (read-cached-message-item message
+ keyword
+ pathname))
+ '())))))
keywords)))
(let ((uncached
(list-transform-positive alist
@@ -1784,7 +1882,7 @@ USA.
(define (fetch-message-body-part-to-cache message section)
(let ((cache-keyword (imap-body-section->keyword section))
- (imap-keyword (imap-body-section->keyword/peek section)))
+ (imap-keyword (imap-body-section->keyword/peek section)))
(with-folder-locked (message-folder message)
(lambda ()
(let ((pathname (message-item-pathname message cache-keyword)))
@@ -1866,7 +1964,7 @@ USA.
(define (%imap-body-section->keyword section prefix)
(string-append prefix
- "["
+ "["
(decorated-string-append
"" "." ""
(map (lambda (x)
@@ -2704,7 +2802,8 @@ USA.
(define (process-fetch-attribute message keyword datum)
(case keyword
((BODYSTRUCTURE)
- (%set-imap-message-bodystructure! message (parse-mime-body datum)))
+ (%set-imap-message-bodystructure! message
+ (parse-mime-body datum message '())))
((FLAGS)
(%set-message-flags! message (map imap-flag->imail-flag datum)))
((RFC822.SIZE)
diff --git a/v7/src/imail/imail-mime.scm b/v7/src/imail/imail-mime.scm
index 2438c64c8..6ea4081e1 100644
--- a/v7/src/imail/imail-mime.scm
+++ b/v7/src/imail/imail-mime.scm
@@ -1,8 +1,11 @@
#| -*-Scheme-*-
-$Id: imail-mime.scm,v 1.11 2008/08/15 15:44:37 riastradh Exp $
+$Id: imail-mime.scm,v 1.12 2008/09/08 03:55:18 riastradh Exp $
-Copyright 2005 Taylor Campbell
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008 Massachusetts Institute of Technology
+Copyright (C) 2005, 2006, 2007, 2008 Taylor R. Campbell
This file is part of MIT/GNU Scheme.
@@ -27,121 +30,282 @@ USA.
(declare (usual-integrations))
-(define-method mime-message-body-structure ((message <message>))
- (or (get-property message 'MIME-MESSAGE-BODY-STRUCTURE #f)
- (cond ((mime:get-version-header message)
- => (lambda (version-string)
- (if (mime:version-1.0? version-string)
- (let ((body-structure
- (mime:parse-body-structure message)))
- (store-property! message
- 'MIME-MESSAGE-BODY-STRUCTURE
- body-structure)
- body-structure)
- (error "MIME version not 1.0:"
- version-string
- message))))
- (else #f))))
-
-(define (mime:parse-body-structure message)
- (let ((content-type (mime:get-content-type message))
- (encoding (mime:get-content-transfer-encoding message)))
+;;;; MIME Entities
+
+;;; Any kind of object can be a MIME entity, provided that it
+;;; implements MIME-ENTITY-BODY-STRUCTURE. A default method is
+;;; provided if it instead implements MIME-ENTITY-HEADER-FIELDS and
+;;; either MIME-ENTITY-BODY-SUBSTRING or WRITE-ENTITY-MIME-BODY, which
+;;; yield the literal text of the entity's body without decoding or
+;;; interpretation. MIME-ENTITY-BODY-STRUCTURE should return a
+;;; <MIME-BODY> instance.
+;;;
+;;; The reason that we do not have a specific class for MIME entities
+;;; is that many objects are implicitly MIME entities, such as RFC
+;;; (2)822 messages, whose header may contain MIME header fields and
+;;; whose body may be a MIME body, but which may otherwise have other
+;;; structure unrelated to MIME.
+
+(define-generic mime-entity? (object))
+(define-generic mime-entity-header-fields (mime-entity))
+(define-generic mime-entity-body-structure (mime-entity))
+(define-generic mime-entity-body-substring (mime-entity))
+(define-generic write-mime-entity-body (mime-entity port))
+
+(define-method mime-entity? (object) object #f)
+
+(define-guarantee mime-entity "MIME entity")
+
+(define-method mime-entity-body-substring (mime-entity)
+ (guarantee-mime-entity mime-entity 'MIME-ENTITY-BODY-SUBSTRING)
+ (let ((string
+ (call-with-output-string
+ (lambda (output-port)
+ (write-mime-entity-body mime-entity output-port)))))
+ (values string 0 (string-length string))))
+
+(define-method write-mime-entity-body (mime-entity port)
+ (guarantee-mime-entity mime-entity 'WRITE-MIME-ENTITY-BODY)
+ (receive (string start end) (mime-entity-body-substring mime-entity)
+ (write-substring string start end port)))
+
+;;;; MIME Bodies
+
+;;; A MIME body is an instance of a subclass of <MIME-BODY>. It must
+;;; implement MIME-BODY-TYPE, MIME-BODY-SUBTYPE,
+;;; MIME-BODY-HEADER-FIELDS, and either MIME-BODY-SUBSTRING or
+;;; WRITE-MIME-BODY.
+
+(define-class <mime-body> (<property-mixin>)
+ (parameters define accessor)
+ (disposition define accessor)
+ (language define accessor)
+ (enclosure define standard initial-value #f))
+
+(define-generic mime-body-type (body))
+(define-generic mime-body-subtype (body))
+(define-generic mime-body-header-fields (body))
+(define-generic mime-body-substring (mime-body))
+(define-generic write-mime-body (mime-body port))
+
+(define-method mime-body-substring ((body <mime-body>))
+ (let ((string
+ (call-with-output-string
+ (lambda (output-port)
+ (write-mime-body body output-port)))))
+ (values string 0 (string-length string))))
+
+(define-method write-mime-body ((body <mime-body>) port)
+ (receive (string start end) (mime-body-substring body)
+ (write-substring string start end port)))
+
+(define (mime-body-type-string body)
+ (string-append (symbol->string (mime-body-type body))
+ "/"
+ (symbol->string (mime-body-subtype body))))
+
+(define (mime-body-parameter body key default)
+ (let ((entry (assq key (mime-body-parameters body))))
+ (if entry
+ (cdr entry)
+ default)))
+
+(define (mime-body-disposition-filename body)
+ (let ((disposition (mime-body-disposition body)))
+ (and disposition
+ (let ((entry (assq 'FILENAME (cdr disposition))))
+ (and entry
+ (cdr entry))))))
+
+(define-method write-instance ((body <mime-body>) port)
+ (write-instance-helper 'MIME-BODY body port
+ (lambda ()
+ (write-char #\space port)
+ (write-string (mime-body-type-string body) port))))
+
+(define (mime-body-enclosed? b1 b2)
+ (or (eq? b1 b2)
+ (let ((enclosure (mime-body-enclosure b1)))
+ (and enclosure
+ (mime-body-enclosed? enclosure b2)))))
+
+(define-class <mime-body-substring> ()
+ (header-fields accessor mime-body-header-fields)
+ (string define accessor)
+ (start define accessor)
+ (end define accessor))
+
+(define-method mime-body-substring ((body <mime-body-substring>))
+ (values (mime-body-substring-string body)
+ (mime-body-substring-start body)
+ (mime-body-substring-end body)))
+
+(define-class <mime-body-one-part> (<mime-body>)
+ (id define accessor)
+ (description define accessor)
+ (encoding define accessor)
+ (n-octets define accessor)
+ ;++ This is a random artefact of the IMAP. We don't use it.
+ (md5 define accessor))
+
+(define-class <mime-body-basic> (<mime-body-one-part>)
+ (type accessor mime-body-type)
+ (subtype accessor mime-body-subtype))
+
+(define-class (<mime-body-basic-substring>
+ (constructor (header-fields
+ string start end type subtype parameters id
+ description encoding n-octets md5 disposition
+ language)))
+ (<mime-body-basic> <mime-body-substring>))
+
+(define-class <mime-body-text> (<mime-body-one-part>)
+ (subtype accessor mime-body-subtype)
+ (n-lines define accessor))
+
+(define-method mime-body-type ((body <mime-body-text>)) body 'TEXT)
+
+(define-class (<mime-body-text-substring>
+ (constructor (header-fields
+ string start end subtype parameters id description
+ encoding n-octets n-lines md5 disposition
+ language)))
+ (<mime-body-text> <mime-body-substring>))
+
+(define-class <mime-body-message> (<mime-body-one-part>)
+ (envelope define accessor) ;<mime-envelope> instance
+ (body define accessor) ;<mime-body> instance
+ (n-lines define accessor))
+
+(define-method mime-body-type ((body <mime-body-message>)) body 'MESSAGE)
+(define-method mime-body-subtype ((body <mime-body-message>)) body 'RFC822)
+
+(define-generic mime-body-message-header-fields (mime-body-message))
+
+;;; In a <MIME-BODY-MESSAGE-SUBSTRING> instance, the HEADER-FIELDS
+;;; slot contains the MIME header fields for the enclosure, and the
+;;; substring contains the complete RFC 822 message, including header
+;;; and body.
+
+(define-class (<mime-body-message-substring>
+ (constructor (header-fields
+ message-header-fields
+ string start end parameters id description
+ encoding envelope body n-octets n-lines md5
+ disposition language)))
+ (<mime-body-message> <mime-body-substring>)
+ (message-header-fields accessor mime-body-message-header-fields))
+
+(define-class (<mime-envelope>
+ (constructor (date subject from sender reply-to to cc bcc
+ in-reply-to message-id)))
+ ()
+ (date define accessor)
+ (subject define accessor)
+ (from define accessor)
+ (sender define accessor)
+ (reply-to define accessor)
+ (to define accessor)
+ (cc define accessor)
+ (bcc define accessor)
+ (in-reply-to define accessor)
+ (message-id define accessor))
+
+(define-class (<mime-address> (constructor (name source-route mailbox host)))
+ ()
+ (name define accessor)
+ (source-route define accessor)
+ (mailbox define accessor)
+ (host define accessor))
+
+(define-class <mime-body-multipart> (<mime-body>)
+ (subtype accessor mime-body-subtype)
+ (parts define accessor))
+
+(define-method mime-body-type ((body <mime-body-multipart>)) body 'MULTIPART)
+
+(define-class (<mime-body-multipart-substring>
+ (constructor (header-fields
+ string start end
+ subtype parameters parts disposition language)))
+ (<mime-body-multipart> <mime-body-substring>))
+
+;;;; MIME Parser
+
+(define-method mime-entity-body-structure (entity)
+ (and (mime-entity? entity)
+ (let ((header-fields (mime-entity-header-fields entity)))
+ (and header-fields
+ (let ((version (mime:get-version-string header-fields)))
+ (and version
+ (mime:version-1.0? version)
+ (receive (string start end)
+ (mime-entity-body-substring entity)
+ (mime:parse-body-structure header-fields
+ string
+ start
+ end))))))))
+
+;;; In MIME entities that have properties, we cache the body
+;;; structures, but weakly, because they may involve very large
+;;; strings not already stored in the entity, if parts of the body
+;;; require decoding. This should almost be an around method (if SOS
+;;; supported such things), but in some cases, such as IMAP messages,
+;;; caching is already handled by another mechanism. So this is
+;;; really useful only for use with the default MIME parser.
+
+(define-method mime-entity-body-structure ((entity <property-mixin>))
+ (define (next store)
+ (let ((body-structure (call-next-method entity)))
+ (store body-structure)
+ body-structure))
+ (let ((cache (get-property entity 'MIME-ENTITY-BODY-STRUCTURE #f)))
+ (if cache
+ (let ((body-structure (weak-car cache)))
+ (if (weak-pair/car? cache)
+ body-structure
+ (next (lambda (value) (weak-set-car! cache value)))))
+ (next (lambda (value)
+ (store-property! entity
+ 'MIME-ENTITY-BODY-STRUCTURE
+ (weak-cons value '())))))))
+
+(define (mime:parse-body-structure header-fields string start end)
+ (let ((content-type (mime:get-content-type header-fields)))
(let ((type (car content-type))
(subtype (cadr content-type))
(parameters (cddr content-type)))
((let ((top-level (assq type mime:media-parsers))
- (default mime:basic-media-parser))
- (cond ((not top-level) default)
- ((assq subtype (cddr top-level)) => cdr)
- ((cadr top-level))
- (else default)))
- message type subtype parameters encoding))))
-
-(define (mime:get-content-type message)
- (parse-first-named-header message
- "Content-Type"
- mime:default-content-type
- mime:parse-content-type))
-
-(define (mime:get-content-transfer-encoding message)
- (named-mime-encoding
- (or (parse-first-named-header message
- "Content-Transfer-Encoding"
- mime:default-encoding
- mime:parse-encoding)
- '7BIT)))
-
-(define-method write-mime-message-body-part
- ((message <message>) selector cache? port)
- cache?
- (if (not (pair? selector))
- (write-message-body message port)
- (let ((lose
- (lambda ()
- (error "Invalid message MIME body selector:"
- selector
- message))))
- (let loop ((selector selector)
- (part (mime-message-body-structure message)))
- (let ((item (car selector))
- (selector (cdr selector)))
- (cond ((exact-nonnegative-integer? item)
- (if (not (mime-body-multipart? part))
- (error "Selecting part of non-multipart:"
- part
- selector))
- (let ((subpart
- (list-ref (mime-body-multipart-parts part)
- item)))
- (if (pair? selector)
- (loop selector subpart)
- (begin
- (if (message? subpart)
- (begin
- (write-header-fields
- (message-header-fields subpart)
- port)
- (newline port)))
- (write-message-body subpart port)))))
- ((not (pair? selector))
- (case item
- ((TEXT)
- (write-message-body part port))
- ((HEADER)
- (write-header-fields (message-header-fields part)
- port))
- (else (lose))))
- (else (lose))))))))
-
-;;;; MIME-Version Header Field
+ (default mime:basic-media-parser))
+ (cond ((not top-level) default)
+ ((assq subtype (cddr top-level)) => cdr)
+ ((cadr top-level))
+ (else default)))
+ header-fields string start end type subtype parameters))))
-(define (mime:get-version-header message)
- (get-first-header-field-value (message-header-fields message)
- "MIME-Version"
- ;; No error if not found.
- #f))
+(define (mime:get-version-string header-fields)
+ (get-first-header-field-value header-fields "MIME-Version" #f))
(define (mime:version-1.0? string)
(let ((tokens (mime:string->non-ignored-tokens string)))
- (let loop ((in tokens)
- (out '()))
+ (let loop ((in tokens) (out '()))
(if (pair? in)
- (let ((token (car in))
- (in (cdr in)))
- (cond ((string? token)
- (loop in (cons token out)))
- ((char? token)
- (loop in (cons (string token) out)))
+ (let ((token (car in)) (in (cdr in)))
+ (cond ((string? token) (loop in (cons token out)))
+ ((char? token) (loop in (cons (string token) out)))
(else #f)))
- (string=? (apply string-append (reverse! out))
- "1.0")))))
-
+ (string=? "1.0" (apply string-append (reverse! out)))))))
+
(define mime:media-parsers '())
-;++ What about top-level media types whose subtypes are mandated to
-;++ have common syntax?
-
(define (define-mime-media-parser type subtype parser)
+ (guarantee-interned-symbol type 'DEFINE-MIME-MEDIA-PARSER)
+ (if subtype
+ (guarantee-interned-symbol subtype 'DEFINE-MIME-MEDIA-PARSER))
+ (guarantee-procedure-of-arity
+ parser
+ (length '(HEADER-FIELDS STRING START END TYPE SUBTYPE PARAMETERS))
+ 'DEFINE-MIME-MEDIA-PARSER)
(cond ((assq type mime:media-parsers)
=> (lambda (top-level)
(if subtype
@@ -173,140 +337,238 @@ USA.
(list #f (cons subtype parser))
(list parser)))
mime:media-parsers))
- unspecific)))
+ unspecific)))
-(define-class <message-part> ()
- (string define accessor)
- (start define accessor)
- (end define accessor))
-
-(define-method message-body ((message <message-part>))
- (values (message-part-string message)
- (message-part-start message)
- (message-part-end message)))
-
-(define-method write-message-body ((message <message-part>) port)
- (write-substring (message-part-string message)
- (message-part-start message)
- (message-part-end message)
- port))
-
-(define-class (<mime-body-basic-part>
- (constructor make-mime-body-basic-part
- (string
- start end
- type subtype parameters
- id description
- encoding
- n-octets
- md5
- disposition language)))
- (<mime-body-basic> <message-part>))
+(define (substring-header&body-bounds string start end)
+ (cond ((= start end)
+ (values start start start start))
+ ((char=? #\newline (string-ref string start))
+ (values start start (+ start 1) end))
+ (else
+ (let ((index (substring-search-forward "\n\n" string start end)))
+ (if index
+ (values start (+ index 1) (+ index 2) end)
+ (values start end end end))))))
+
+(define (mime:parse-entity string start end)
+ (receive (header-start header-end body-start body-end)
+ (substring-header&body-bounds string start end)
+ (mime:parse-body-structure
+ (lines->header-fields (substring->lines string header-start header-end))
+ string
+ body-start
+ body-end)))
;;; This is the default media parser, equivalent to a Content-Type of
;;; APPLICATION/OCTET-STREAM.
(define mime:basic-media-parser
- (lambda (message type subtype parameters encoding)
- (receive (string start end) (message-body message)
- (make-mime-body-basic-part
- string start end
- type subtype parameters
- (mime:get-content-id message)
- (mime:get-content-description message)
- (mime-encoding/name encoding)
- (message-length message)
- (ignore-errors (lambda () (md5-substring string start end))
- (lambda (condition) condition #f))
- (mime:get-content-disposition message)
- (mime:get-content-language message)))))
+ (lambda (header-fields string start end type subtype parameters)
+ (make-mime-body-basic-substring
+ header-fields string start end
+ type subtype parameters
+ (mime:get-content-id header-fields)
+ (mime:get-content-description header-fields)
+ (mime:get-content-transfer-encoding header-fields)
+ (- end start)
+ (ignore-errors (lambda () (md5-substring string start end))
+ (lambda (condition) condition #f))
+ (mime:get-content-disposition header-fields)
+ (mime:get-content-language header-fields))))
;;; This is unnecessary, but it's nice to make things explicit.
(define-mime-media-parser 'APPLICATION 'OCTET-STREAM
mime:basic-media-parser)
-(define-class (<mime-body-text-part>
- (constructor make-mime-body-text-part
- (string
- start end
- subtype parameters
- id description
- encoding
- n-octets n-lines
- md5
- disposition language)))
- (<mime-body-text> <message-part>))
-
(define-mime-media-parser 'TEXT #f
- (lambda (message type subtype parameters encoding)
+ (lambda (header-fields string start end type subtype parameters)
type ;ignore
- (receive (string start end) (message-body message)
- (make-mime-body-text-part
- string start end
- subtype parameters
- (mime:get-content-id message)
- (mime:get-content-description message)
- (mime-encoding/name encoding)
- (- end start) ;Octets
- (substring-n-newlines string start end) ;Lines
- (ignore-errors (lambda () (md5-substring string start end))
- (lambda (condition) condition #f))
- (mime:get-content-disposition message)
- (mime:get-content-language message)))))
+ (make-mime-body-text-substring
+ header-fields string start end
+ subtype parameters
+ (mime:get-content-id header-fields)
+ (mime:get-content-description header-fields)
+ (mime:get-content-transfer-encoding header-fields)
+ (- end start)
+ (substring-n-newlines string start end)
+ (ignore-errors (lambda () (md5-substring string start end))
+ (lambda (condition) condition #f))
+ (mime:get-content-disposition header-fields)
+ (mime:get-content-language header-fields))))
+
+(define-mime-media-parser 'MESSAGE 'RFC822
+ (lambda (header-fields string start end type subtype parameters)
+ type subtype ;ignore
+ (let ((body (mime:parse-entity string start end)))
+ ((lambda (enclosure)
+ (set-mime-body-enclosure! body enclosure)
+ enclosure)
+ (make-mime-body-message-substring
+ header-fields (mime-body-header-fields body) string start end
+ parameters
+ (mime:get-content-id header-fields)
+ (mime:get-content-description header-fields)
+ (mime:get-content-transfer-encoding header-fields)
+ (mime:parse-envelope
+ (receive (header-start header-end body-start body-end)
+ (substring-header&body-bounds string start end)
+ body-start body-end ;ignore
+ (lines->header-fields
+ (substring->lines string header-start header-end))))
+ body
+ (- end start)
+ (substring-n-newlines string start end)
+ (ignore-errors (lambda () (md5-substring string start end))
+ (lambda (condition) condition #f))
+ (mime:get-content-disposition header-fields)
+ (mime:get-content-language header-fields))))))
+
+(define (mime:parse-envelope header-fields)
+ (make-mime-envelope
+ (get-first-header-field-value header-fields "date" #f)
+ (get-first-header-field-value header-fields "subject" #f)
+ (parse-first-named-header header-fields "from" #f mime:parse-addresses)
+ (parse-first-named-header header-fields "sender" #f mime:parse-addresses)
+ (parse-first-named-header header-fields "reply-to" #f mime:parse-addresses)
+ (parse-first-named-header header-fields "to" #f mime:parse-addresses)
+ (parse-first-named-header header-fields "cc" #f mime:parse-addresses)
+ (parse-first-named-header header-fields "bcc" #f mime:parse-addresses)
+ (get-first-header-field-value header-fields "in-reply-to" #f)
+ (get-first-header-field-value header-fields "message-id" #f)))
+
+;++ Provisional crock. No group address or source route syntax.
+
+(define (mime:parse-addresses string)
+ (let* ((tokens (rfc822:string->tokens string))
+ (result (rfc822:parse-list tokens #\, rfc822:parse-address)))
+ (and result
+ (let ((addresses (car result)) (tokens (cdr result)))
+ (and (not (pair? tokens)) addresses)))))
+
+(define (rfc822:parse-address tokens)
+ (or (rfc822:parse-name-addr tokens)
+ (rfc822:parse-addr-spec tokens)))
+
+(define (rfc822:parse-name-addr tokens)
+ (define (finish name mailbox host tokens)
+ (cons (make-mime-address name #f mailbox host) tokens))
+ (let loop ((tokens tokens) (name-tokens '()))
+ (and (pair? tokens)
+ (cond ((eqv? (car tokens) #\<)
+ (let ((name (rfc822:tokens->string (reverse name-tokens)))
+ (result (rfc822:parse-angle-addr tokens)))
+ (and result
+ (let ((local-part (caar result))
+ (domain (cadar result))
+ (tokens (cdr result)))
+ (let ((result
+ (rfc822:parse-comment-names name tokens)))
+ (and (pair? result)
+ (let ((name (car result))
+ (tokens (cdr result)))
+ (finish name local-part domain tokens))))))))
+ (else
+ (and (or (eqv? (car tokens) #\space)
+ (and (string? (car tokens))
+ (not (char=? #\[ (string-ref (car tokens) 0)))))
+ (loop (cdr tokens)
+ (cons (car tokens) name-tokens))))))))
+
+(define (rfc822:parse-comment-names name tokens)
+ (define (finish names tokens)
+ (cons (rfc822:tokens->string (reverse (map string-trim names))) tokens))
+ (let loop ((tokens tokens)
+ (names (if (string-null? name) '() (list name))))
+ (if (not (pair? tokens))
+ (finish names tokens)
+ (let ((token (car tokens)))
+ (if (and (string? token) (char=? #\( (string-ref token 0)))
+ (loop (cdr tokens)
+ (cons (if (pair? names)
+ (substring token 1 (- (string-length token) 1))
+ token)
+ names))
+ (finish names tokens))))))
+
+(define (rfc822:parse-angle-addr tokens)
+ (and (pair? tokens)
+ (eqv? #\< (car tokens))
+ (let ((result (rfc822:parse-addr-spec (cdr tokens))))
+ (and (pair? result)
+ (let ((addr-spec (car result)) (tokens (cdr result)))
+ (and (pair? tokens)
+ (eqv? #\> (car tokens))
+ (cons addr-spec (cdr tokens))))))))
+
+(define (rfc822:parse-addr-spec tokens)
+ (let ((result (rfc822:parse-list tokens #\. rfc822:parse-word)))
+ (and (pair? result)
+ (let ((local-part (decorated-string-append "" "." "" (car result)))
+ (tokens (cdr result)))
+ (and (pair? tokens)
+ (eqv? #\@ (car tokens))
+ (let ((result (rfc822:parse-domain (cdr tokens))))
+ (and (pair? result)
+ (let ((domain
+ (decorated-string-append "" "." "" (car result)))
+ (tokens
+ (cdr result)))
+ (cons (list local-part domain) tokens)))))))))
;;;; Multipart Media
(define-mime-media-parser 'MULTIPART #f
- (lambda (message type subtype parameters encoding)
+ (lambda (header-fields string start end type subtype parameters)
type ;ignore
- (mime:parse-multipart message subtype parameters encoding)))
+ (mime:parse-multipart header-fields string start end subtype parameters)))
(define-mime-media-parser 'MULTIPART 'DIGEST
- (lambda (message type subtype parameters encoding)
+ (lambda (header-fields string start end type subtype parameters)
type ;ignore
(fluid-let ((mime:default-content-type '(MESSAGE RFC822)))
- (mime:parse-multipart message subtype parameters encoding))))
-
-(define (mime:parse-multipart message subtype parameters encoding)
- (let* ((parts
- (mime:parse-multipart-subparts message parameters encoding))
- (enclosure
- (make-mime-body-multipart subtype parameters parts
- (mime:get-content-disposition message)
- (mime:get-content-language message))))
- (for-each (lambda (part)
- (set-mime-body-enclosure! part enclosure))
- parts)
- enclosure))
-
-(define (mime:parse-multipart-subparts message parameters encoding)
- (let ((boundary (mime:get-boundary parameters message)))
- (define (parse-body body start end)
- (mime:parse-parts
- body
- (mime:multipart-message-parts body start end boundary)))
- (if (mime-encoding/identity? message)
- (call-with-values (lambda () (message-body message))
- parse-body)
+ (mime:parse-multipart header-fields string start end
+ subtype parameters))))
+
+(define (mime:parse-multipart header-fields string start end
+ subtype parameters)
+ (let ((boundary (mime:get-boundary parameters)))
+ (and boundary
+ (let ((parts
+ (mime:parse-multipart-parts header-fields string start end
+ boundary)))
+ (and parts
+ (let* ((enclosure
+ (make-mime-body-multipart-substring
+ header-fields string start end
+ subtype parameters parts
+ (mime:get-content-disposition header-fields)
+ (mime:get-content-language header-fields))))
+ (for-each (lambda (part)
+ (set-mime-body-enclosure! part enclosure))
+ parts)
+ enclosure))))))
+
+(define (mime:parse-multipart-parts header-fields string start end boundary)
+ (let ((encoding
+ (named-mime-encoding
+ (mime:get-content-transfer-encoding header-fields))))
+ (if (mime-encoding/identity? encoding)
+ (mime:parse-multipart-parts-1 string start end boundary)
((lambda (body)
- (parse-body body 0 (string-length body)))
+ (mime:parse-multipart-parts-1 body 0 (string-length body) boundary))
(call-with-output-string
(lambda (output-port)
- (call-with-mime-decoding-output-port
- encoding output-port #t
+ (call-with-mime-decoding-output-port encoding output-port #t
(lambda (output-port)
- (write-message-body message output-port)))))))))
+ (write-substring string start end output-port)))))))))
-(define (mime:get-boundary parameters message)
- (cond ((assq 'BOUNDARY parameters)
- => (lambda (probe)
- (string-append "--" (cdr probe))))
- (else
- (error "MIME multipart message has no boundary:"
- message))))
+(define (mime:get-boundary parameters)
+ (let ((parameter (assq 'BOUNDARY parameters)))
+ (and parameter
+ (string-append "--" (cdr parameter)))))
-(define (mime:multipart-message-parts string start end boundary)
+(define (mime:parse-multipart-parts-1 string start end boundary)
(let ((boundary-length (string-length boundary)))
(define (loop part-start search-start parts)
@@ -346,88 +608,59 @@ USA.
(char=? #\- (string-ref string (+ boundary-end 1)))))
(define (win parts)
- (cdr (reverse! parts)))
+ (map (lambda (start.end)
+ (mime:parse-entity string (car start.end) (cdr start.end)))
+ ;; Strip the leading text, which is not a proper part --
+ ;; usually it is just a message to the effect that this is
+ ;; a MIME-formatted message which your mail reader can't
+ ;; read.
+ (cdr (reverse! parts))))
(define (lose parts)
- ;; (error "Malformed MIME multipart:" ...)
- (if (pair? parts)
- (cdr (reverse! parts))
- '()))
+ ;; If we got at least one part and the leading text, then win
+ ;; with that much -- at least we sha'n't be discarding any
+ ;; information, since the last part will include the rest of the
+ ;; message that we weren't able to parse.
+ (if (and (pair? parts)
+ (pair? (cdr parts)))
+ (win parts)
+ #f))
(loop start start '())))
-;;;;; MIME Part Messages
-
-(define-class (<message-part-message>
- (constructor make-message-part-message
- (header-fields length string start end)))
- ;** Do not rearrange this! The MESSAGE-BODY method on
- ;** <MESSAGE-PART> must be given precedence over that on
- ;** <MESSAGE>!
- (<message-part> <message>)
- (length accessor message-length))
-
-(define (mime:parse-part body start end)
- (cond ((char=? #\newline (string-ref body start))
- ;; If the body begins with a newline, then there are
- ;; no header fields, so the header end is the same
- ;; as the content start.
- (mime:parse-part/no-header body start (+ start 1) end))
- ((substring-search-forward "\n\n" body start end)
- => (lambda (header-end)
- ;; End the header between the two newlines.
- (mime:parse-part/header body start (+ header-end 1) end)))
- (else
- ;; Assume that the absence of a blank line means no
- ;; header fields at all.
- (mime:parse-part/no-header body start start end))))
-
-(define (mime:parse-part/header string start header-end end)
- (mime:parse-body-structure
- (make-message-part-message
- (lines->header-fields (substring->lines string start header-end))
- (- end start)
- string
- (+ header-end 1) ;Exclude the blank line.
- end)))
-
-(define (mime:parse-part/no-header string start content-start end)
- (mime:parse-body-structure
- (make-message-part-message '() (- end start) string content-start end)))
-
-(define (mime:parse-parts body parts)
- (map (lambda (part)
- (mime:parse-part body (car part) (cdr part)))
- parts))
-
-;;;; Content-Type Header Fields
+;;;; MIME Header Fields
+
+(define (mime:get-content-type header-fields)
+ (parse-first-named-header header-fields
+ "Content-Type"
+ mime:default-content-type
+ mime:parse-content-type))
(define mime:default-content-type '(TEXT PLAIN (CHARSET . "us-ascii")))
(define (mime:parse-content-type string)
(let ((tokens (mime:string->non-ignored-tokens string)))
(if (pair? tokens)
- (let ((type (car tokens))
- (tokens (cdr tokens)))
- (if (and (string? type)
- (pair? tokens))
- (let ((slash (car tokens))
- (tokens (cdr tokens)))
- (if (and (eqv? slash #\/)
- (pair? tokens))
- (let ((subtype (car tokens))
- (tokens (cdr tokens)))
+ (let ((type (car tokens)) (tokens (cdr tokens)))
+ (if (and (string? type) (pair? tokens))
+ (let ((slash (car tokens)) (tokens (cdr tokens)))
+ (if (and (eqv? slash #\/) (pair? tokens))
+ (let ((subtype (car tokens)) (tokens (cdr tokens)))
(if (string? subtype)
(cons* (intern type)
(intern subtype)
- (mime:parse-parameters tokens
- "Content-Type"))
+ (mime:parse-parameters tokens))
#f))
#f))
#f))
#f)))
-;;;; Other Content-... Fields
+(define (mime:get-content-transfer-encoding header-fields)
+ (or (parse-first-named-header header-fields
+ "Content-Transfer-Encoding"
+ mime:default-encoding
+ mime:parse-encoding)
+ mime:default-encoding))
(define mime:default-encoding '7BIT)
@@ -438,35 +671,37 @@ USA.
(null? (cdr tokens)))
(intern (car tokens))
#f)))
+
+(define (mime:get-content-id header-fields)
+ (parse-first-named-header header-fields "Content-ID" #f rfc822:parse-msg-id))
-(define (mime:get-content-id message)
- (parse-first-named-header message "Content-ID" #f rfc822:parse-msg-id))
-
-(define (mime:get-content-description message)
- (parse-first-named-header message "Content-Description" #f
+(define (mime:get-content-description header-fields)
+ (parse-first-named-header header-fields
+ "Content-Description"
+ #f
mime:parse-encoded-header-value))
(define (mime:parse-encoded-header-value value)
;++ implement
value)
-(define (mime:get-content-disposition message)
- (parse-first-named-header message "Content-Disposition" #f
+(define (mime:get-content-disposition header-fields)
+ (parse-first-named-header header-fields
+ "Content-Disposition"
+ #f
mime:parse-disposition))
(define (mime:parse-disposition disposition)
(let ((tokens (mime:string->non-ignored-tokens disposition)))
(if (pair? tokens)
- (let ((type (car tokens))
- (tokens (cdr tokens)))
+ (let ((type (car tokens)) (tokens (cdr tokens)))
(if (string? type)
(cons (intern type)
- (mime:parse-parameters tokens
- "Content-Disposition"))
+ (mime:parse-parameters tokens))
#f))
#f)))
-(define (mime:get-content-language message)
+(define (mime:get-content-language header-fields)
;++ implement
#f)
@@ -474,8 +709,8 @@ USA.
(define mime:special-chars
(char-set #\( #\) #\< #\> #\@
- #\, #\; #\: #\\ #\"
- #\/ #\[ #\] #\? #\=))
+ #\, #\; #\: #\\ #\"
+ #\/ #\[ #\] #\? #\=))
;;; STRING->TOKENS includes whitespace & parenthesis comments;
;;; STRING->NON-IGNORED-TOKENS omits them.
@@ -489,31 +724,133 @@ USA.
;;; Too bad the parser language works only on strings; it would be
;;; nice to be able to use it for general tokens, like RFC822 tokens.
-(define (mime:parse-parameters tokens header-name)
- (let ((lose (lambda (tokens)
- (warn (string-append "Malformed " header-name
- " parameter tokens:")
- tokens)
- '())))
- (let recur ((tokens tokens))
- (if (pair? tokens)
- (let ((lose (lambda () (lose tokens))))
- (let ((semi (car tokens))
- (tokens (cdr tokens)))
- (if (and (eqv? semi #\;)
- (pair? tokens))
- (let ((attribute (car tokens))
- (tokens (cdr tokens)))
- (if (pair? tokens)
- (let ((equals (car tokens))
- (tokens (cdr tokens)))
- (if (and (eqv? equals #\=)
- (pair? tokens))
- (cons (cons (intern attribute)
- (rfc822:unquote-string
- (car tokens)))
- (recur (cdr tokens)))
- (lose)))
- (lose)))
- (lose))))
- '()))))
+(define (mime:parse-parameters tokens)
+ (let recur ((tokens tokens))
+ (if (pair? tokens)
+ (let ((semi (car tokens)) (tokens (cdr tokens)))
+ (if (and (eqv? semi #\;) (pair? tokens))
+ (let ((attribute (car tokens)) (tokens (cdr tokens)))
+ (if (pair? tokens)
+ (let ((equals (car tokens)) (tokens (cdr tokens)))
+ (if (and (eqv? equals #\=) (pair? tokens))
+ (cons (cons (intern attribute)
+ (rfc822:unquote-string (car tokens)))
+ (recur (cdr tokens)))
+ '()))
+ '()))
+ '()))
+ '())))
+
+;;;; MIME Encoding Registry
+
+(define-structure (mime-encoding
+ (conc-name mime-encoding/)
+ (print-procedure
+ (standard-unparser-method 'MIME-ENCODING
+ (lambda (encoding output-port)
+ (write-char #\space output-port)
+ (write (mime-encoding/name encoding) output-port))))
+ (constructor %make-mime-encoding))
+ (name #f read-only #t)
+ (identity? #f read-only #t)
+ (encoder-initializer #f read-only #t)
+ (encoder-finalizer #f read-only #t)
+ (encoder-updater #f read-only #t)
+ (decoder-initializer #f read-only #t)
+ (decoder-finalizer #f read-only #t)
+ (decoder-updater #f read-only #t)
+ (decoding-port-maker #f read-only #t)
+ (caller-with-decoding-port #f read-only #t))
+
+(define-guarantee mime-encoding "MIME codec")
+
+(define mime-encodings
+ (make-eq-hash-table))
+
+(define (define-mime-encoding name
+ encode:initialize encode:finalize encode:update
+ decode:initialize decode:finalize decode:update
+ make-port call-with-port)
+ (hash-table/put!
+ mime-encodings
+ name
+ (%make-mime-encoding name #f
+ encode:initialize encode:finalize encode:update
+ decode:initialize decode:finalize decode:update
+ make-port call-with-port))
+ name)
+
+(define (define-identity-mime-encoding name)
+ (hash-table/put! mime-encodings
+ name
+ (%make-mime-encoding name #t
+ (lambda (port text?) text? port)
+ output-port/flush-output
+ output-port/write-string
+ (lambda (port text?) text? port)
+ output-port/flush-output
+ output-port/write-string
+ (lambda (port text?) text? port)
+ (lambda (port text? generator)
+ text?
+ (generator port)))))
+
+(define (known-mime-encoding? name)
+ (and (hash-table/get mime-encodings name #f)
+ #t))
+
+(define (named-mime-encoding name)
+ (or (hash-table/get mime-encodings name #f)
+ (let ((encoding (make-unknown-mime-encoding name)))
+ (hash-table/put! mime-encodings name encoding)
+ encoding)))
+
+(define (make-unknown-mime-encoding name)
+ (let ((lose (lambda args args (error "Unknown MIME encoding name:" name))))
+ (%make-mime-encoding name #f lose lose lose lose lose lose lose lose)))
+
+(define (call-with-mime-decoding-output-port encoding port text? generator)
+ ((mime-encoding/caller-with-decoding-port
+ (if (symbol? encoding)
+ (named-mime-encoding encoding)
+ (begin
+ (guarantee-mime-encoding encoding
+ 'CALL-WITH-MIME-DECODING-OUTPUT-PORT)
+ encoding)))
+ port text? generator))
+
+(define-identity-mime-encoding '7BIT)
+(define-identity-mime-encoding '8BIT)
+(define-identity-mime-encoding 'BINARY)
+
+;; Next two are random values sometimes used by Outlook.
+(define-identity-mime-encoding '7-BIT)
+(define-identity-mime-encoding '8-BIT)
+
+(define-mime-encoding 'QUOTED-PRINTABLE
+ encode-quoted-printable:initialize
+ encode-quoted-printable:finalize
+ encode-quoted-printable:update
+ decode-quoted-printable:initialize
+ decode-quoted-printable:finalize
+ decode-quoted-printable:update
+ make-decode-quoted-printable-port
+ call-with-decode-quoted-printable-output-port)
+
+(define-mime-encoding 'BASE64
+ encode-base64:initialize
+ encode-base64:finalize
+ encode-base64:update
+ decode-base64:initialize
+ decode-base64:finalize
+ decode-base64:update
+ make-decode-base64-port
+ call-with-decode-base64-output-port)
+
+(define-mime-encoding 'BINHEX40
+ #f #f #f ;No BinHex encoder.
+ decode-binhex40:initialize
+ decode-binhex40:finalize
+ decode-binhex40:update
+ make-decode-binhex40-port
+ call-with-decode-binhex40-output-port)
diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index e0ad9bdf9..3499c3721 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.311 2008/08/15 22:46:42 riastradh Exp $
+$Id: imail-top.scm,v 1.312 2008/09/08 03:55:18 riastradh Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -167,17 +167,17 @@ Text messages using these character sets are displayed inline;
(define-variable imail-inline-mime-text-subtypes
"List of MIME text subtypes that should be shown inline.
The value of this variable is a list of symbols.
-A text entity that appears at the top level of a message
+A text body that appears at the top level of a message
is always shown inline, regardless of its subtype.
-Likewise, a text/plain entity is always shown inline.
+Likewise, a text/plain body is always shown inline.
Note that this variable does not affect subparts of multipart/alternative."
'(HTML ENRICHED)
list-of-strings?)
(define-variable imail-inline-mime-text-limit
- "Size limit in octets for showing MIME text message parts in-line.
+ "Size limit in octets for showing MIME text message parts inline.
MIME text message parts less than this size are shown in-line by default.
-This variable can also be #F; then all parts will be shown in-line."
+This variable can also be #F; then all parts will be shown inline."
65536
(lambda (x) (or (boolean? x) (exact-nonnegative-integer? x))))
@@ -207,6 +207,13 @@ Otherwise, only one of the parts is shown."
'SIMPLE
(lambda (x) (memq x '(SIMPLE SGML ORIGINAL))))
+(define-variable imail-mime-show-headers
+ "If true, show MIME headers in expanded body parts.
+Headers are shown only for parts that are displayed out-of-line by
+ default."
+ #f
+ boolean?)
+
(define-variable imail-global-mail-notification
"If true, all buffer modelines say if there is unseen mail.
(This checks only for unseen mail in the primary folder.)
@@ -397,7 +404,7 @@ Instead, these commands are available:
\\[imail-file-message] Append this message to a specified file.
(The message is written in a human-readable format.)
\\[imail-save-attachment] Save a MIME attachment to a file.
-\\[imail-save-mime-entity] Save an arbitrary MIME entity to a file.
+\\[imail-save-mime-body] Save an arbitrary MIME body to a file.
\\[imail-add-flag] Add flag to message. It will be displayed in the mode line.
\\[imail-kill-flag] Remove flag from message.
@@ -415,7 +422,7 @@ Instead, these commands are available:
\\[imail-summary-by-regexp] Like \\[imail-summary] only just messages matching regular expression.
\\[imail-toggle-header] Toggle between full headers and reduced headers.
-\\[imail-toggle-mime-entity] Toggle MIME entity between expanded and collapsed formats.
+\\[imail-toggle-mime-body] Toggle MIME body between expanded and collapsed formats.
\\[imail-toggle-message] Toggle between standard and raw message formats.
\\[imail-create-folder] Create a new folder. (Normally not needed as output commands
@@ -447,6 +454,7 @@ Instead, these commands are available:
(error "Unknown folder-sync status:" status))))
(begin
(discard-folder-cache folder)
+ (buffer-remove! buffer 'IMAIL-MIME-EXPANSIONS)
(select-message
folder
(or (selected-message #f buffer)
@@ -487,7 +495,7 @@ Instead, these commands are available:
(define-key 'imail #\m-s 'imail-search)
(define-key 'imail #\u 'imail-undelete-previous-message)
(define-key 'imail #\m-u 'imail-first-unseen-message)
-(define-key 'imail #\w 'imail-save-mime-entity)
+(define-key 'imail #\w 'imail-save-mime-body)
(define-key 'imail #\x 'imail-expunge)
(define-key 'imail #\. 'beginning-of-buffer)
(define-key 'imail #\< 'imail-first-message)
@@ -504,10 +512,10 @@ Instead, these commands are available:
(define-key 'imail '(#\c-c #\c-s #\c-r) 'imail-sort-by-recipient)
(define-key 'imail '(#\c-c #\c-s #\c-s) 'imail-sort-by-subject)
(define-key 'imail '(#\c-c #\c-s #\c-v) 'imail-sort-by-arrival)
-(define-key 'imail '(#\c-c #\c-t #\c-e) 'imail-toggle-mime-entity)
+(define-key 'imail '(#\c-c #\c-t #\c-e) 'imail-toggle-mime-body)
(define-key 'imail '(#\c-c #\c-t #\c-h) 'imail-toggle-header)
(define-key 'imail '(#\c-c #\c-t #\c-m) 'imail-toggle-message)
-(define-key 'imail '(#\c-c #\c-t #\c-w) 'imail-toggle-wrap-entity)
+(define-key 'imail '(#\c-c #\c-t #\c-w) 'imail-toggle-wrap-body)
(define-key 'imail #\M-o 'imail-file-message)
;; Putting these after the group above exploits behavior in the comtab
@@ -525,7 +533,7 @@ Instead, these commands are available:
(define-key 'imail #\D 'imail-delete-folder)
(define-key 'imail #\R 'imail-rename-folder)
(define-key 'imail #\+ 'imail-create-folder)
-(define-key 'imail button3-down 'imail-mouse-save-mime-entity)
+(define-key 'imail button3-down 'imail-mouse-save-mime-body)
;; These commands not yet implemented.
;;(define-key 'imail #\m-m 'imail-retry-failure)
@@ -917,20 +925,20 @@ With prefix argument, prompt even when point is on an attachment."
"P"
(lambda (always-prompt?)
(let ((buffer (imail-folder->buffer (selected-folder) #t)))
- (save-mime-entity (car (maybe-prompt-for-mime-info "Save attachment"
- (buffer-point buffer)
- always-prompt?
- mime-attachment?))
- buffer))))
-
-(define-command imail-mouse-save-mime-entity
- "Save the MIME entity that mouse is on."
+ (save-mime-body (car (maybe-prompt-for-mime-info "Save attachment"
+ (buffer-point buffer)
+ always-prompt?
+ mime-attachment?))
+ buffer))))
+
+(define-command imail-mouse-save-mime-body
+ "Save the MIME body that mouse is on."
()
(lambda ()
(let ((button-event (current-button-event)))
(let ((window (button-event/window button-event)))
(let ((buffer (window-buffer window)))
- (save-mime-entity
+ (save-mime-body
(let ((info
(mark-mime-info
(or (window-coordinates->mark
@@ -939,40 +947,38 @@ With prefix argument, prompt even when point is on an attachment."
(button-event/y button-event))
(buffer-end buffer)))))
(if (not info)
- (editor-error "Mouse not on a MIME entity."))
+ (editor-error "Mouse not on a MIME body."))
info)
buffer))))))
-(define-command imail-save-mime-entity
- "Save the MIME entity at point."
+(define-command imail-save-mime-body
+ "Save the MIME body at point."
()
(lambda ()
- (save-mime-entity (car (current-mime-entity)) (selected-buffer))))
+ (save-mime-body (car (current-mime-body)) (selected-buffer))))
-(define-command imail-toggle-mime-entity
- "Expand or collapse the MIME entity at point."
+(define-command imail-toggle-mime-body
+ "Expand or collapse the MIME body at point."
()
(lambda ()
- (let ((i.m (current-mime-entity))
- (message (selected-message)))
+ (let ((i.m (current-mime-body)))
(let ((info (car i.m))
(mark (cdr i.m)))
- (set-mime-info-expanded?!
- info mark message
- (not (mime-info-expanded? info mark message)))
- (re-render-mime-entity info mark message)))))
+ (set-mime-info-expanded?! info
+ mark
+ (not (mime-info-expanded? info mark)))
+ (re-render-mime-body info mark)))))
-(define-command imail-toggle-wrap-entity
- "Toggle auto-wrap on or off for the MIME entity at point."
+(define-command imail-toggle-wrap-body
+ "Toggle auto-wrap on or off for the MIME body at point."
()
(lambda ()
- (let ((i.m (current-mime-entity))
- (message (selected-message)))
+ (let ((i.m (current-mime-body)))
(let ((info (car i.m))
(mark (cdr i.m)))
(mime-body-wrapped! (mime-info-body info)
(not (mime-body-wrapped? (mime-info-body info))))
- (re-render-mime-entity info mark message)))))
+ (re-render-mime-body info mark)))))
(define (mime-body-wrapped? body)
(get-property body 'WRAP? #t))
@@ -982,17 +988,17 @@ With prefix argument, prompt even when point is on an attachment."
(remove-property! body 'WRAP?)
(store-property! body 'WRAP? value)))
-(define (re-render-mime-entity info mark message)
- (let ((region (mime-entity-region mark))
+(define (re-render-mime-body info mark)
+ (let ((region (mime-body-region mark))
(buffer (mark-buffer mark)))
(if (not region)
- (error "No MIME entity at mark:" mark))
+ (error "No MIME body at mark:" mark))
(let ((point (mark-right-inserting-copy (buffer-point buffer))))
(with-read-only-defeated mark
(lambda ()
(region-delete! region)
(let ((mark (mark-left-inserting-copy (region-start region))))
- (insert-mime-info info message mark)
+ (insert-mime-info info mark)
(mark-temporary! mark))))
(mark-temporary! point)
(set-buffer-point! buffer point))
@@ -1043,24 +1049,22 @@ With prefix argument, prompt even when point is on an attachment."
converted))
(reverse! converted))))
-(define (current-mime-entity)
+(define (current-mime-body)
(let ((point (current-point)))
(let ((info (mark-mime-info point)))
(if (not info)
- (editor-error "Point not on a MIME entity."))
+ (editor-error "Point not on a MIME body."))
(cons info point))))
-(define (save-mime-entity info buffer)
- (let ((body (mime-info-body info))
- (selector (mime-info-selector info))
- (message (selected-message #t buffer)))
+(define (save-mime-body info buffer)
+ (let ((body (mime-info-body info)))
(let ((filename
(let ((history 'IMAIL-SAVE-ATTACHMENT))
(prompt-for-file
(string-append "Save "
(if (mime-attachment? info)
"attachment"
- "MIME entity")
+ "MIME body")
" as")
(let ((filename
(let ((filename (mime-body-disposition-filename body)))
@@ -1099,7 +1103,7 @@ With prefix argument, prompt even when point is on an attachment."
port
text?
(lambda (port)
- (write-mime-message-body-part message selector #f port)))))))))
+ (write-mime-body body port)))))))))
(define (filter-mime-attachment-filename filename)
(let ((filename
@@ -1763,20 +1767,19 @@ WARNING: With a prefix argument, this command may take a very long
(selected-folder)
(let ((buffer (selected-buffer)))
(lambda (message body-structure cache-procedure)
- (define (cache message body selector context buffer)
- message body context buffer
- (cache-procedure selector))
- (define (ignore message body selector context buffer)
- message body selector context buffer
- unspecific)
- (walk-mime-message-part
- message
- body-structure
- '()
- (make-walk-mime-context #f 0 #f '())
- buffer
- cache
- (if argument cache ignore)))))))
+ (define (cache entity body selector context buffer)
+ entity selector context buffer
+ (cache-procedure body))
+ (define (ignore entity body selector context buffer)
+ entity body selector context buffer
+ unspecific)
+ (walk-mime-body message
+ body-structure
+ '()
+ (make-walk-mime-context #f 0 #f '())
+ buffer
+ cache
+ (if argument cache ignore)))))))
;;;; URLs
@@ -2210,10 +2213,11 @@ WARNING: With a prefix argument, this command may take a very long
(if (and count (= (cdr count) mod-count))
(car count)
(let ((n (folder-length folder)))
- (do ((i 0 (+ i 1))
+ (do ((i (first-unseen-message-index folder) (+ i 1))
(unseen 0
(if (let loop
- ((flags (message-flags (get-message folder i))))
+ ((flags
+ (message-flags (%get-message folder i))))
(and (pair? flags)
(or (string-ci=? "seen" (car flags))
(string-ci=? "deleted" (car flags))
@@ -2271,10 +2275,10 @@ WARNING: With a prefix argument, this command may take a very long
(insert-header-fields message (and raw? (not (eq? raw? 'BODY-ONLY))) mark)
(cond ((and raw? (not (eq? raw? 'HEADERS-ONLY)))
(insert-message-body message mark))
- ((mime-message-body-structure message)
+ ((mime-entity-body-structure message)
=> (lambda (body-structure)
- (insert-mime-message-body message body-structure
- mark inline-only? left-margin)))
+ (insert-mime-body message body-structure
+ mark inline-only? left-margin)))
(else
(call-with-auto-wrapped-output-mark mark left-margin message
(lambda (port)
@@ -2346,16 +2350,15 @@ WARNING: With a prefix argument, this command may take a very long
;;;; MIME message formatting
-(define (insert-mime-message-body message body-structure
- mark inline-only? left-margin)
- (walk-mime-message-part
+(define (insert-mime-body message body-structure mark inline-only? left-margin)
+ (walk-mime-body
message
body-structure
'()
(make-walk-mime-context inline-only? left-margin #f '())
mark
- insert-mime-message-inline
- insert-mime-message-outline))
+ insert-mime-body-inline
+ insert-mime-body-outline))
(define-structure walk-mime-context
(inline-only? #f read-only #t)
@@ -2370,16 +2373,18 @@ WARNING: With a prefix argument, this command may take a very long
(cons (cons boundary (not boundary))
(walk-mime-context-boundaries context))))
-(define (mime-enclosure-type? context type subtype)
+(define (mime-enclosure-type? context type #!optional subtype)
(let ((enclosure (walk-mime-context-enclosure context)))
(and enclosure
(mime-type? enclosure type subtype))))
-(define (mime-type? body type subtype)
+(define (mime-type? body type #!optional subtype)
(and (eq? (mime-body-type body) type)
- (eq? (mime-body-subtype body) subtype)))
+ (or (default-object? subtype)
+ (not subtype)
+ (eq? (mime-body-subtype body) subtype))))
-(define (maybe-insert-mime-boundary context mark)
+(define (maybe-insert-mime-boundary context selector mark)
(let ((boundary
(let loop ((boundaries (walk-mime-context-boundaries context)))
(and (pair? boundaries)
@@ -2394,7 +2399,11 @@ WARNING: With a prefix argument, this command may take a very long
(loop (cdr boundaries)))))
(if boundary
(begin
- (insert-newline mark)
+ (if (not (and (mime-enclosure-type? context 'MULTIPART)
+ (mime-type? (walk-mime-context-enclosure context)
+ 'MULTIPART)
+ (zero? (last selector))))
+ (insert-newline mark))
(cond ((string? boundary)
(insert-string "--" mark)
(insert-string boundary mark))
@@ -2417,25 +2426,25 @@ WARNING: With a prefix argument, this command may take a very long
encoding
(mime-body-one-part-encoding body))))
-(define-generic walk-mime-message-part
- (message body selector context mark if-inline if-outline))
-(define-generic inline-message-part? (body context mark))
+(define-generic walk-mime-body
+ (entity body selector context mark if-inline if-outline))
+(define-generic inline-mime-part? (body context mark))
-(define-method walk-mime-message-part
- (message (body <mime-body>) selector context mark if-inline if-outline)
- ((if (inline-message-part? body context mark) if-inline if-outline)
- message body selector context mark))
+(define-method walk-mime-body
+ (entity (body <mime-body>) selector context mark if-inline if-outline)
+ ((if (inline-mime-part? body context mark) if-inline if-outline)
+ entity body selector context mark))
-(define-method inline-message-part? ((body <mime-body>) context mark)
+(define-method inline-mime-part? ((body <mime-body>) context mark)
context mark
(mime-type? body 'MESSAGE 'DELIVERY-STATUS))
-(define-method inline-message-part? ((body <mime-body-message>) context mark)
+(define-method inline-mime-part? ((body <mime-body-message>) context mark)
body
(not (and (mime-enclosure-type? context 'MULTIPART 'DIGEST)
(ref-variable imail-mime-collapse-digest mark))))
-(define-method inline-message-part? ((body <mime-body-text>) context mark)
+(define-method inline-mime-part? ((body <mime-body-text>) context mark)
(and (let ((disposition (mime-body-disposition body)))
(if disposition
(eq? (car disposition) 'INLINE)
@@ -2455,12 +2464,12 @@ WARNING: With a prefix argument, this command may take a very long
(mime-body-parameter body 'CHARSET "us-ascii")
#t)
(let ((limit (ref-variable imail-inline-mime-text-limit mark)))
- (or (not limit)
- (< (mime-body-one-part-n-octets body) limit)))))
+ (or (not limit)
+ (< (mime-body-one-part-n-octets body) limit)))))
-(define-method walk-mime-message-part
- (message (body <mime-body-multipart>) selector context
- mark if-inline if-outline)
+(define-method walk-mime-body
+ (entity (body <mime-body-multipart>) selector context mark
+ if-inline if-outline)
(let ((context
(make-walk-mime-subcontext
context
@@ -2473,58 +2482,50 @@ WARNING: With a prefix argument, this command may take a very long
(if (eq? (mime-body-subtype body) 'ALTERNATIVE)
(if (pair? parts)
(begin
- (walk-mime-message-part message
- (car parts)
- `(,@selector 0)
- context
- mark if-inline if-outline)
+ (walk-mime-body entity (car parts) `(,@selector 0)
+ context mark if-inline if-outline)
(if (ref-variable imail-mime-show-alternatives mark)
(do ((parts (cdr parts) (cdr parts))
(i 1 (fix:+ i 1)))
((null? parts))
- (if-outline message
- (car parts)
- `(,@selector ,i)
- context
- mark)))))
+ (if-outline entity (car parts) `(,@selector ,i) context
+ mark)))))
(do ((parts parts (cdr parts))
(i 0 (fix:+ i 1)))
((null? parts))
- (walk-mime-message-part message
- (car parts)
- `(,@selector ,i)
- context
- mark if-inline if-outline)))))
+ (walk-mime-body entity (car parts) `(,@selector ,i)
+ context mark if-inline if-outline)))))
-(define (insert-mime-message-inline message body selector context mark)
- (maybe-insert-mime-boundary context mark)
- (insert-mime-info (make-mime-info #t body selector context)
- message
- mark))
+(define (insert-mime-body-inline entity body selector context mark)
+ (maybe-insert-mime-boundary context selector mark)
+ (insert-mime-info (make-mime-info #t entity body selector context) mark))
-(define (insert-mime-message-outline message body selector context mark)
+(define (insert-mime-body-outline entity body selector context mark)
(if (not (walk-mime-context-inline-only? context))
(begin
- (maybe-insert-mime-boundary context mark)
- (insert-mime-info (make-mime-info #f body selector context)
- message
+ (maybe-insert-mime-boundary context selector mark)
+ (insert-mime-info (make-mime-info #f entity body selector context)
mark))))
-(define (insert-mime-info info message mark)
+(define (insert-mime-info info mark)
(let ((start (mark-right-inserting-copy mark))
+ (entity (mime-info-entity info))
(body (mime-info-body info))
+ (selector (mime-info-selector info))
(context (mime-info-context info)))
- (if (mime-info-expanded? info mark message)
- (insert-mime-message-inline* message
- body
- (mime-info-selector info)
- context
- mark)
+ (if (mime-info-expanded? info mark)
+ (begin
+ (if (and (ref-variable imail-mime-show-headers mark)
+ (not (inline-mime-part? body context mark))
+ (mime-enclosure-type? context 'MULTIPART))
+ (insert-header-fields (mime-body-header-fields body) #t mark))
+ (insert-mime-body-inline* entity body selector context mark))
(insert-mime-outline
- (compute-mime-message-outline body
- (mime-attachment-name info #f)
- context)
+ (compute-mime-body-outline body
+ (mime-attachment-name info #f)
+ context)
mark))
+ (insert-newline mark)
(attach-mime-info start mark info)
(mark-temporary! start)))
@@ -2546,13 +2547,23 @@ WARNING: With a prefix argument, this command may take a very long
(insert-newline mark))))
parameters)
(insert-string indentation mark)
- (insert-string "/>" mark)
- (insert-newline mark)))
+ (insert-string "/>" mark)))
-(define-generic insert-mime-message-inline* (msg body selector context mark))
+(define-generic insert-mime-body-inline* (entity body selector context mark))
-(define-method insert-mime-message-inline*
- (message (body <mime-body>) selector context mark)
+(define-method insert-mime-body-inline*
+ (entity (body <mime-body>) selector context mark)
+ entity body selector context ;ignore
+ (call-with-auto-wrapped-output-mark
+ mark
+ (walk-mime-context-left-margin context)
+ body
+ (lambda (port)
+ (write-mime-body body port))))
+
+(define-method insert-mime-body-inline*
+ (entity (body <mime-body-one-part>) selector context mark)
+ entity selector ;ignore
(call-with-auto-wrapped-output-mark
mark
(walk-mime-context-left-margin context)
@@ -2563,43 +2574,35 @@ WARNING: With a prefix argument, this command may take a very long
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 <mime-body-message>) selector context mark)
- (insert-header-fields (call-with-output-string
- (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
- insert-mime-message-inline
- insert-mime-message-outline))
-
-(define-generic compute-mime-message-outline (body name context))
-
-(define-method compute-mime-message-outline ((body <mime-body>) name context)
+ (write-mime-body body port))))))
+
+(define-method insert-mime-body-inline*
+ (entity (body <mime-body-message>) selector context mark)
+ (insert-header-fields (mime-body-message-header-fields body) #f mark)
+ (walk-mime-body entity
+ (mime-body-message-body body)
+ selector
+ (make-walk-mime-subcontext context body #f)
+ mark
+ insert-mime-body-inline
+ insert-mime-body-outline))
+
+(define-method insert-mime-body-inline*
+ (entity (body <mime-body-multipart>) selector context mark)
+ (walk-mime-body entity body selector context mark
+ insert-mime-body-inline
+ insert-mime-body-outline))
+
+(define-generic compute-mime-body-outline (body name context))
+
+(define-method compute-mime-body-outline ((body <mime-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")))))
-(define-method compute-mime-message-outline
+(define-method compute-mime-body-outline
((body <mime-body-one-part>) name context)
context
(append (call-next-method body name context)
@@ -2608,7 +2611,7 @@ WARNING: With a prefix argument, this command may take a very long
(cons "encoding" encoding)))
(cons "length" (mime-body-one-part-n-octets body)))))
-(define-method compute-mime-message-outline
+(define-method compute-mime-body-outline
((body <mime-body-message>) name context)
name
(let ((envelope (mime-body-message-envelope body)))
@@ -2626,15 +2629,10 @@ WARNING: With a prefix argument, this command may take a very long
(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
- ;; Microsoft sometimes uses these non-standard values:
- 7-BIT 8-BIT)))
(define (mime-attachment-name info provide-default?)
(or (mime-body-parameter (mime-info-body info) 'NAME #f)
+ (mime-body-disposition-filename (mime-info-body info))
(and provide-default?
(string-append (if (mime-info-inline? info)
"inline-"
@@ -2681,7 +2679,7 @@ WARNING: With a prefix argument, this command may take a very long
(loop mark attachments)
(reverse! attachments))))))
-(define (mime-entity-region mark)
+(define (mime-body-region mark)
(specific-property-region mark 'IMAIL-MIME-INFO
(lambda (i1 i2)
(mime-body-enclosed? (mime-info-body i1) (mime-info-body i2)))))
@@ -2691,21 +2689,22 @@ WARNING: With a prefix argument, this command may take a very long
(define-structure mime-info
(inline? #f)
+ (entity #f read-only #t)
(body #f read-only #t)
(selector #f read-only #t)
(context #f read-only #t))
-(define (mime-info-expanded? info mark message)
+(define (mime-info-expanded? info mark)
(let ((expansions (buffer-get (->buffer mark) 'IMAIL-MIME-EXPANSIONS #f))
- (key (cons message (mime-info-selector info)))
+ (key (cons (mime-info-entity info) (mime-info-selector info)))
(inline? (mime-info-inline? info)))
(if expansions
(hash-table/get expansions key inline?)
inline?)))
-(define (set-mime-info-expanded?! info mark message expanded?)
+(define (set-mime-info-expanded?! info mark expanded?)
(let ((buffer (->buffer mark))
- (key (cons message (mime-info-selector info))))
+ (key (cons (mime-info-entity info) (mime-info-selector info))))
(if (if (mime-info-inline? info) expanded? (not expanded?))
(cond ((buffer-get buffer 'IMAIL-MIME-EXPANSIONS #f)
=> (lambda (expansions)
@@ -2718,7 +2717,7 @@ WARNING: With a prefix argument, this command may take a very long
(buffer-put! buffer 'IMAIL-MIME-EXPANSIONS expansions)
expansions))
key
- expanded?))))
+ expanded?))))
;;;; Automatic wrap/fill
diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm
index 4647e070f..9557bb9ce 100644
--- a/v7/src/imail/imail-util.scm
+++ b/v7/src/imail/imail-util.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: imail-util.scm,v 1.52 2008/07/11 05:26:42 cph Exp $
+$Id: imail-util.scm,v 1.53 2008/09/08 03:55:18 riastradh Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -572,4 +572,80 @@ USA.
(set-istate-position! state 0)
(set-istate-buffer-start! state 0)
(set-istate-buffer-end! state 0)))))))
- #f))
\ No newline at end of file
+ #f))
+
+;;;; Properties
+
+(define-class <property-mixin> ()
+ (alist define (accessor modifier)
+ accessor object-properties
+ modifier set-object-properties!
+ initial-value '()))
+
+(define (get-property object key default)
+ (let ((entry (assq key (object-properties object))))
+ (if entry
+ (cdr entry)
+ default)))
+
+(define (store-property! object key datum)
+ (let ((alist (object-properties object)))
+ (let ((entry (assq key alist)))
+ (if entry
+ (set-cdr! entry datum)
+ (set-object-properties! object (cons (cons key datum) alist))))))
+
+(define (remove-property! object key)
+ (set-object-properties! object (del-assq! key (object-properties object))))
+
+;;;; Modification events
+
+(define-class <modification-event-mixin> ()
+ (modification-count define (accessor modifier)
+ accessor object-modification-count
+ modifier set-object-modification-count!
+ initial-value 0)
+ (modification-event define accessor
+ accessor object-modification-event
+ initializer make-event-distributor))
+
+(define (receive-modification-events object procedure)
+ (add-event-receiver! (object-modification-event object) procedure))
+
+(define (ignore-modification-events object procedure)
+ (remove-event-receiver! (object-modification-event object) procedure))
+
+(define (object-modified! object type . arguments)
+ (without-interrupts
+ (lambda ()
+ (set-object-modification-count!
+ object
+ (+ (object-modification-count object) 1))))
+ (apply signal-modification-event object type arguments))
+
+(define (signal-modification-event object type . arguments)
+ (if *deferred-modification-events*
+ (set-cdr! *deferred-modification-events*
+ (cons (cons* object type arguments)
+ (cdr *deferred-modification-events*)))
+ (begin
+ (if imap-trace-port
+ (begin
+ (write-line (cons* 'OBJECT-EVENT object type arguments)
+ imap-trace-port)
+ (flush-output imap-trace-port)))
+ (event-distributor/invoke! (object-modification-event object)
+ object
+ type
+ arguments))))
+
+(define (with-modification-events-deferred thunk)
+ (let ((events (list 'EVENTS)))
+ (let ((v
+ (fluid-let ((*deferred-modification-events* events))
+ (thunk))))
+ (for-each (lambda (event) (apply signal-modification-event event))
+ (reverse! (cdr events)))
+ v)))
+
+(define *deferred-modification-events* #f)
diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index 0e269ac77..41a5b231e 100644
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: imail.pkg,v 1.106 2008/07/07 01:36:24 riastradh Exp $
+$Id: imail.pkg,v 1.107 2008/09/08 03:55:18 riastradh Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -34,22 +34,10 @@ USA.
(define-package (edwin imail)
(files "imail-util"
+ "imail-mime"
"imail-core")
(parent (edwin)))
-(define-package (edwin imail mime)
- (files "imail-mime")
- (parent (edwin imail))
- (export (edwin imail)
- define-mime-media-parser
- mime:basic-media-parser
- mime:parse-multipart
- mime:default-content-type
- <message-part>
- message-part-string
- message-part-start
- message-part-end))
-
(define-package (edwin imail file-folder)
(files "imail-file")
(parent (edwin imail))
@@ -203,7 +191,7 @@ USA.
edwin-command$imail-kill-flag
edwin-command$imail-last-message
edwin-command$imail-mail
- edwin-command$imail-mouse-save-mime-entity
+ edwin-command$imail-mouse-save-mime-body
edwin-command$imail-next-flagged-message
edwin-command$imail-next-message
edwin-command$imail-next-same-subject
@@ -219,12 +207,12 @@ USA.
edwin-command$imail-resend
edwin-command$imail-save-attachment
edwin-command$imail-save-folder
- edwin-command$imail-save-mime-entity
+ edwin-command$imail-save-mime-body
edwin-command$imail-search
edwin-command$imail-select-message
edwin-command$imail-toggle-header
edwin-command$imail-toggle-message
- edwin-command$imail-toggle-mime-entity
+ edwin-command$imail-toggle-mime-body
edwin-command$imail-undelete-backward
edwin-command$imail-undelete-forward
edwin-command$imail-undelete-previous-message
@@ -250,6 +238,7 @@ USA.
edwin-variable$imail-mime-boundary-style
edwin-variable$imail-mime-collapse-digest
edwin-variable$imail-mime-show-alternatives
+ edwin-variable$imail-mime-show-headers
edwin-variable$imail-mode-hook
edwin-variable$imail-output-default
edwin-variable$imail-primary-folder