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.

diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index 58c51baf7312f2fc29e248e7c8d4eec297511432..9f8e7ca840e3ec3d11c42a45feba5b6b9a061e19 100644 (file)
--- 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))
-
+\f
 (define (buffer-mime-info buffer)
   (let ((end (buffer-end buffer)))
     (let loop ((start (buffer-start buffer)) (attachments '()))