From 3dbc0c5b34015f06fb1b1a792317b21f49d362eb Mon Sep 17 00:00:00 2001 From: "Taylor R. Campbell" Date: Mon, 8 Sep 2008 03:55:18 +0000 Subject: [PATCH] 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. --- v7/src/imail/ed-ffi.scm | 4 +- v7/src/imail/imail-core.scm | 323 +----------- v7/src/imail/imail-imap.scm | 303 +++++++---- v7/src/imail/imail-mime.scm | 965 ++++++++++++++++++++++++------------ v7/src/imail/imail-top.scm | 351 +++++++------ v7/src/imail/imail-util.scm | 80 ++- v7/src/imail/imail.pkg | 23 +- 7 files changed, 1126 insertions(+), 923 deletions(-) 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 () - (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-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 () @@ -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 )) - (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 ;ignore + #t) + +(define-method mime-entity-header-fields ((message )) + (message-header-fields message)) + +(define-method write-mime-entity-body ((message ) port) + (write-message-body message port)) (define %set-message-flags! (let ((modifier (slot-modifier '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 () - (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 ) 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 () - (id define accessor) - (description define accessor) - (encoding define accessor) - (n-octets define accessor) - (md5 define accessor)) - -(define-class ( - (constructor (parameters id description encoding n-octets - envelope body n-lines - md5 disposition language))) - () - (envelope define accessor) ; instance - (body define accessor) ; instance - (n-lines define accessor)) - -(define-method mime-body-type ((body )) body 'MESSAGE) -(define-method mime-body-subtype ((body )) body 'RFC822) - -(define-class ( - (constructor (subtype parameters id description encoding - n-octets n-lines - md5 disposition language))) - () - (subtype accessor mime-body-subtype) - (n-lines define accessor)) - -(define-method mime-body-type ((body )) body 'TEXT) - -(define-class ( - (constructor (type subtype parameters id description encoding - n-octets md5 disposition language))) - () - (type accessor mime-body-type) - (subtype accessor mime-body-subtype)) - -(define-class ( - (constructor (subtype parameters parts disposition language))) - () - (subtype accessor mime-body-subtype) - (parts define accessor)) - -(define-method mime-body-type ((body )) body 'MULTIPART) - -(define-class ( - (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 ( (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 ) flags) (with-imap-message-open message @@ -1178,12 +1176,6 @@ USA. (define-method message-internal-time ((message )) (fetch-one-message-item message 'INTERNALDATE "internal date")) -(define-method message-length ((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-bodystructure message)) - +(define-class () + (message define accessor) + (section define accessor) + (header-fields)) + +(let ((accessor (slot-accessor 'HEADER-FIELDS)) + (modifier (slot-modifier 'HEADER-FIELDS)) + (initpred (slot-initpred '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 )) + (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 ( + (constructor (message + section + type subtype parameters id description encoding + n-octets + md5 disposition language))) + ( )) + +(define-class ( + (constructor (message + section + subtype parameters id description encoding + n-octets n-lines md5 disposition language))) + ( )) + +(define-class ( + (constructor (message + section + parameters id description encoding n-octets + envelope body n-lines md5 disposition language))) + ( )) + +(define-class ( + (constructor (message + section + subtype parameters parts disposition language))) + ( )) + (define-method write-message-body ((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 ) 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 ) 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 )) + (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 )) - (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 +;;; 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 . It must +;;; implement MIME-BODY-TYPE, MIME-BODY-SUBTYPE, +;;; MIME-BODY-HEADER-FIELDS, and either MIME-BODY-SUBSTRING or +;;; WRITE-MIME-BODY. + +(define-class () + (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 )) + (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 ) 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 ) 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 () + (header-fields accessor mime-body-header-fields) + (string define accessor) + (start define accessor) + (end define accessor)) + +(define-method mime-body-substring ((body )) + (values (mime-body-substring-string body) + (mime-body-substring-start body) + (mime-body-substring-end body))) + +(define-class () + (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 () + (type accessor mime-body-type) + (subtype accessor mime-body-subtype)) + +(define-class ( + (constructor (header-fields + string start end type subtype parameters id + description encoding n-octets md5 disposition + language))) + ( )) + +(define-class () + (subtype accessor mime-body-subtype) + (n-lines define accessor)) + +(define-method mime-body-type ((body )) body 'TEXT) + +(define-class ( + (constructor (header-fields + string start end subtype parameters id description + encoding n-octets n-lines md5 disposition + language))) + ( )) + +(define-class () + (envelope define accessor) ; instance + (body define accessor) ; instance + (n-lines define accessor)) + +(define-method mime-body-type ((body )) body 'MESSAGE) +(define-method mime-body-subtype ((body )) body 'RFC822) + +(define-generic mime-body-message-header-fields (mime-body-message)) + +;;; In a 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 ( + (constructor (header-fields + message-header-fields + string start end parameters id description + encoding envelope body n-octets n-lines md5 + disposition language))) + ( ) + (message-header-fields accessor mime-body-message-header-fields)) + +(define-class ( + (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 ( (constructor (name source-route mailbox host))) + () + (name define accessor) + (source-route define accessor) + (mailbox define accessor) + (host define accessor)) + +(define-class () + (subtype accessor mime-body-subtype) + (parts define accessor)) + +(define-method mime-body-type ((body )) body 'MULTIPART) + +(define-class ( + (constructor (header-fields + string start end + subtype parameters parts disposition language))) + ( )) + +;;;; 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 )) + (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 ) 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 () - (string define accessor) - (start define accessor) - (end define accessor)) - -(define-method message-body ((message )) - (values (message-part-string message) - (message-part-start message) - (message-part-end message))) - -(define-method write-message-body ((message ) port) - (write-substring (message-part-string message) - (message-part-start message) - (message-part-end message) - port)) - -(define-class ( - (constructor make-mime-body-basic-part - (string - start end - type subtype parameters - id description - encoding - n-octets - md5 - disposition language))) - ( )) +(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 ( - (constructor make-mime-body-text-part - (string - start end - subtype parameters - id description - encoding - n-octets n-lines - md5 - disposition language))) - ( )) - (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 ( - (constructor make-message-part-message - (header-fields length string start end))) - ;** Do not rearrange this! The MESSAGE-BODY method on - ;** must be given precedence over that on - ;** ! - ( ) - (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 ) 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 ) 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 ) context mark) +(define-method inline-mime-part? ((body ) context mark) context mark (mime-type? body 'MESSAGE 'DELIVERY-STATUS)) -(define-method inline-message-part? ((body ) context mark) +(define-method inline-mime-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) +(define-method inline-mime-part? ((body ) 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 ) selector context - mark if-inline if-outline) +(define-method walk-mime-body + (entity (body ) 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 ) selector context mark) +(define-method insert-mime-body-inline* + (entity (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 ) 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 ) 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 ) name context) + (write-mime-body body port)))))) + +(define-method insert-mime-body-inline* + (entity (body ) 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 ) 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 ) 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 ) 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 ) 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 () + (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-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-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 -- 2.25.1