From e39eeacc855b38f4ffac6be8802a13cc1a530662 Mon Sep 17 00:00:00 2001 From: "Taylor R. Campbell" Date: Fri, 20 Jun 2008 02:32:11 +0000 Subject: [PATCH] When attaching MIME info records to the buffer, respect nested MIME entities so that for each point in the buffer only the most specific MIME entity is attached. It would be nice if there were a variant of REGION-PUT! that layered text properties `under' existing ones, but since there isn't, we make do by scanning the text for the property changes and associating records for parents wherever their children had not been attached. --- v7/src/imail/imail-top.scm | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index 58c51baf7..9f8e7ca84 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.304 2008/05/18 23:58:37 riastradh Exp $ +$Id: imail-top.scm,v 1.305 2008/06/20 02:32:11 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -2646,11 +2646,25 @@ WARNING: With a prefix argument, this command may take a very long selector)))))))) (define (attach-mime-info start end info) - (region-put! start end 'IMAIL-MIME-INFO info #t)) + ;; Scan forward for each change in the IMAIL-MIME-INFO property, and + ;; for any region in which it is not set (between inferior MIME + ;; entities) we set it. What we really want is some way to layer + ;; text properties `under' existing ones, but the text property + ;; facility doesn't support that. + (define (attach start end) + (if (not (region-get start 'IMAIL-MIME-INFO #f)) + (region-put! start end 'IMAIL-MIME-INFO info #t))) + (let loop ((mark start)) + (cond ((find-next-specific-property-change mark end 'IMAIL-MIME-INFO) + => (lambda (mark*) + (attach mark mark*) + (loop mark*))) + (else + (attach mark end))))) (define (mark-mime-info mark) (region-get mark 'IMAIL-MIME-INFO #f)) - + (define (buffer-mime-info buffer) (let ((end (buffer-end buffer))) (let loop ((start (buffer-start buffer)) (attachments '())) -- 2.25.1