From e0305fe90fe672f44449eb6bbe91836fb1c1b92d Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 24 Jan 2001 22:51:35 +0000 Subject: [PATCH] Modify mime-body datatypes to have a pointer to the enclosing entity. --- v7/src/imail/imail-core.scm | 13 +++-- v7/src/imail/imail-imap.scm | 98 ++++++++++++++++++++----------------- 2 files changed, 64 insertions(+), 47 deletions(-) diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index 35c8544b6..bc6e78496 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.115 2000/12/28 05:45:12 cph Exp $ +;;; $Id: imail-core.scm,v 1.116 2001/01/24 22:51:22 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -822,7 +822,8 @@ (define-class () (parameters define accessor) (disposition define accessor) - (language define accessor)) + (language define accessor) + (enclosure define standard initial-value #f)) (define-generic mime-body-type (body)) (define-generic mime-body-subtype (body)) @@ -851,6 +852,12 @@ (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) @@ -894,7 +901,7 @@ (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))) diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index 80718c6a8..b02df7d9d 100644 --- a/v7/src/imail/imail-imap.scm +++ b/v7/src/imail/imail-imap.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-imap.scm,v 1.146 2001/01/23 05:15:41 cph Exp $ +;;; $Id: imail-imap.scm,v 1.147 2001/01/24 22:51:35 cph Exp $ ;;; -;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology +;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as @@ -1074,16 +1074,20 @@ (string-ci=? "rfc822" (cadr body))) (if (not (fix:>= n 10)) (parse-mime-body:lose body)) - (apply make-mime-body-message - (parse-mime-parameters (list-ref body 2)) - (list-ref body 3) - (list-ref body 4) - (intern (list-ref body 5)) - (list-ref body 6) - (parse-mime-envelope (list-ref body 7)) - (parse-mime-body (list-ref body 8)) - (list-ref body 9) - (parse-mime-body:extensions (list-tail body 10)))) + (let* ((enclosed (parse-mime-body (list-ref body 8))) + (enclosure + (apply make-mime-body-message + (parse-mime-parameters (list-ref body 2)) + (list-ref body 3) + (list-ref body 4) + (intern (list-ref body 5)) + (list-ref body 6) + (parse-mime-envelope (list-ref body 7)) + enclosed + (list-ref body 9) + (parse-mime-body:extensions (list-tail body 10))))) + (set-mime-body-enclosure! enclosed enclosure) + enclosure)) (else (if (not (fix:>= n 7)) (parse-mime-body:lose body)) @@ -1102,15 +1106,21 @@ (if (not (pair? tail)) (parse-mime-body:lose body)) (if (string? (car tail)) - (let ((extensions (parse-mime-body:extensions (cdr tail)))) - (make-mime-body-multipart (intern (car tail)) - (parse-mime-parameters (car extensions)) - (map parse-mime-body - (sublist body 0 index)) - (cadr extensions) - (caddr extensions))) + (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) (if (pair? (cdr tail)) @@ -1123,6 +1133,30 @@ (define (parse-mime-body:lose body) (error "Unrecognized MIME bodystructure:" body)) + +(define (parse-mime-parameters parameters) + (let ((lose (lambda () (error "Malformed MIME parameters:" parameters)))) + (let loop ((parameters parameters) (alist '())) + (if (pair? parameters) + (if (pair? (cdr parameters)) + (loop (cddr parameters) + (cons (cons (intern (car parameters)) (cadr parameters)) + alist)) + (lose)) + (if (null? parameters) + (reverse! alist) + (lose)))))) + +(define (parse-mime-disposition disposition) + (and disposition + (begin + (if (not (and (pair? disposition) + (string? (car disposition)) + (pair? (cdr disposition)) + (null? (cddr disposition)))) + (error "Malformed MIME disposition:" disposition)) + (cons (intern (car disposition)) + (parse-mime-parameters (cadr disposition)))))) (define (parse-mime-envelope envelope) (make-mime-envelope (list-ref envelope 0) @@ -1179,30 +1213,6 @@ (else (lose)))) (loop addr-list '() '())) '())) - -(define (parse-mime-parameters parameters) - (let ((lose (lambda () (error "Malformed MIME parameters:" parameters)))) - (let loop ((parameters parameters) (alist '())) - (if (pair? parameters) - (if (pair? (cdr parameters)) - (loop (cddr parameters) - (cons (cons (intern (car parameters)) (cadr parameters)) - alist)) - (lose)) - (if (null? parameters) - (reverse! alist) - (lose)))))) - -(define (parse-mime-disposition disposition) - (and disposition - (begin - (if (not (and (pair? disposition) - (string? (car disposition)) - (pair? (cdr disposition)) - (null? (cddr disposition)))) - (error "Malformed MIME disposition:" disposition)) - (cons (intern (car disposition)) - (parse-mime-parameters (cadr disposition)))))) ;;;; Server operations -- 2.25.1