From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 26 Jun 2000 19:02:39 +0000 (+0000)
Subject: Implement M-x imail-toggle-attachment, which allows any part of a
X-Git-Tag: 20090517-FFI~3445
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=398e22ff81a772efe90fb795c5556c1089ffbaac;p=mit-scheme.git

Implement M-x imail-toggle-attachment, which allows any part of a
MIME-encoded message to be toggled between "in-line" and "out-of-line"
format.  This is most useful for expanding small text attachments
without writing them to a file first.
---

diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index 6e4a032f0..53d1d9621 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.189 2000/06/26 15:28:25 cph Exp $
+;;; $Id: imail-top.scm,v 1.190 2000/06/26 19:02:23 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -417,7 +417,8 @@ Instead, these commands are available:
 (define-key 'imail #\s		'imail-save-folder)
 (define-key 'imail #\m-s	'imail-search)
 (define-key 'imail #\t		'imail-toggle-header)
-(define-key 'imail #\c-t	'imail-toggle-message)
+(define-key 'imail #\c-t	'imail-toggle-attachment)
+(define-key 'imail #\c-m-t	'imail-toggle-message)
 (define-key 'imail #\u		'imail-undelete-previous-message)
 (define-key 'imail #\m-u	'imail-first-unseen-message)
 (define-key 'imail #\x		'imail-expunge)
@@ -795,37 +796,48 @@ If point is not on an attachment, prompts for the attachment to save.
 With prefix argument, prompt even when point is on an attachment."
   "P"
   (lambda (always-prompt?)
-    (let ((attachment
-	   (maybe-prompt-for-mime-attachment (current-point) always-prompt?)))
-      (save-mime-attachment (car attachment)
-			    (cdr attachment)
-			    (selected-message)
-			    (selected-buffer)))))
-
-(define (maybe-prompt-for-mime-attachment mark always-prompt?)
-  (let ((attachment (mark-mime-attachment mark)))
-    (if (and attachment (not always-prompt?))
-	attachment
-	(let ((attachments (buffer-mime-attachments (mark-buffer mark))))
-	  (if (null? attachments)
+    (let ((i.m
+	   (maybe-prompt-for-mime-info "Save attachment"
+				       (current-point)
+				       always-prompt?)))
+      (save-mime-part (mime-info-body (car i.m))
+		      (mime-info-selector (car i.m))
+		      (selected-message)
+		      (selected-buffer)))))
+
+(define-command imail-toggle-attachment
+  "Expand or collapse the attachment at point.
+If point is not on an attachment, prompts for the attachment to save.
+With prefix argument, prompt even when point is on an attachment."
+  "P"
+  (lambda (always-prompt?)
+    (let ((i.m
+	   (maybe-prompt-for-mime-info "Toggle attachment"
+				       (current-point)
+				       always-prompt?)))
+      (toggle-mime-part (car i.m) (cdr i.m) (selected-message)))))
+
+(define (maybe-prompt-for-mime-info prompt mark always-prompt?)
+  (let ((info (mark-mime-info mark)))
+    (if (and info (not always-prompt?))
+	(cons info mark)
+	(let ((alist
+	       (uniquify-mime-attachment-names
+		(map (lambda (i.m)
+		       (cons (mime-attachment-name (car i.m) #t)
+			     i.m))
+		     (buffer-mime-info (mark-buffer mark))))))
+	  (if (null? alist)
 	      (editor-error "This message has no attachments."))
-	  (let ((alist
-		 (uniquify-mime-attachment-names
-		  (map (lambda (b.s)
-			 (cons (mime-attachment-name (car b.s) (cdr b.s) #t)
-			       b.s))
-		       attachments))))
-	    (prompt-for-alist-value "Save attachment"
-				    alist
-				    (and attachment
-					 (let ((entry
-						(list-search-positive alist
-						  (lambda (entry)
-						    (eq? (cdr entry)
-							 attachment)))))
-					   (and entry
-						(car entry))))
-				    #f))))))
+	  (prompt-for-alist-value prompt
+				  alist
+				  (and info
+				       (let loop ((alist alist))
+					 (if (pair? alist)
+					     (if (eq? (cadar alist) info)
+						 (caar alist)
+						 (loop (cdr alist))))))
+				  #f)))))
 
 (define (uniquify-mime-attachment-names alist)
   (let loop ((alist alist) (converted '()))
@@ -844,7 +856,7 @@ With prefix argument, prompt even when point is on an attachment."
 		    converted))
 	(reverse! converted))))
 
-(define (save-mime-attachment body selector message buffer)
+(define (save-mime-part body selector message buffer)
   (let ((filename
 	 (let ((history 'IMAIL-SAVE-ATTACHMENT))
 	   (prompt-for-file
@@ -906,6 +918,21 @@ With prefix argument, prompt even when point is on an attachment."
   (char-set-invert
    (char-set-difference char-set:graphic
 			char-set:mime-attachment-filename-delimiters)))
+
+(define (toggle-mime-part info mark message)
+  (set-mime-info-expanded?! info (not (mime-info-expanded? info)))
+  (let ((region (specific-property-region mark 'IMAIL-MIME-INFO))
+	(buffer (mark-buffer 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)
+	    (mark-temporary! mark))))
+      (mark-temporary! point)
+      (set-buffer-point! buffer point))
+    (buffer-not-modified! buffer)))
 
 ;;;; Sending mail
 
@@ -1989,13 +2016,25 @@ Negative argument means search in reverse."
 		(insert-string boundary mark)))
 	  (insert-newline mark)
 	  (insert-newline mark)))))
+
+(define (mime-part-encoding context body)
+  (let ((encoding
+	 (let ((enclosure (insert-mime-context-enclosure context)))
+	   (and enclosure
+		(eq? (mime-body-type enclosure) 'MESSAGE)
+		(eq? (mime-body-subtype enclosure) 'RFC822)
+		(mime-body-one-part-encoding enclosure)))))
+    (if (and encoding (not (memq encoding '(7BIT 8BIT BINARY))))
+	;; This is illegal, but Netscape does it.
+	encoding
+	(mime-body-one-part-encoding body))))
 
 (define-generic insert-mime-message-part (message body selector context mark))
 
 (define-method insert-mime-message-part
     (message (body <mime-body>) selector context mark)
-  message
-  (insert-mime-message-attachment 'ATTACHMENT body selector context mark))
+  (insert-mime-message-attachment 'ATTACHMENT message body selector context
+				  mark))
 
 (define-method insert-mime-message-part
     (message (body <mime-body-multipart>) selector context mark)
@@ -2006,8 +2045,7 @@ Negative argument means search in reverse."
 	  (if (ref-variable imail-use-original-mime-boundaries mark)
 	      (mime-body-parameter body 'BOUNDARY "----------")
 	      'SIMPLE)))
-	(show-alternatives?
-	 (ref-variable imail-mime-show-alternatives mark)))
+	(show-alternatives? (ref-variable imail-mime-show-alternatives mark)))
     (do ((parts (mime-body-multipart-parts body) (cdr parts))
 	 (i 0 (fix:+ i 1)))
 	((null? parts))
@@ -2016,8 +2054,8 @@ Negative argument means search in reverse."
 	(if (and (fix:> i 0)
 		 (eq? (mime-body-subtype body) 'ALTERNATIVE))
 	    (if show-alternatives?
-		(insert-mime-message-attachment 'ALTERNATIVE part selector
-						context mark))
+		(insert-mime-message-attachment 'ALTERNATIVE message part
+						selector context mark))
 	    (insert-mime-message-part message part selector context mark))))))
 
 (define-method insert-mime-message-part
@@ -2039,130 +2077,153 @@ Negative argument means search in reverse."
 
 (define-method insert-mime-message-part
     (message (body <mime-body-text>) selector context mark)
-  (let* ((enclosure (insert-mime-context-enclosure context))
-	 (message-enclosure?
-	  (and enclosure
-	       (eq? (mime-body-type enclosure) 'MESSAGE)
-	       (eq? (mime-body-subtype enclosure) 'RFC822)))
-	 (encoding
-	  (let ((encoding
-		 (and message-enclosure?
-		      (mime-body-one-part-encoding enclosure))))
-	    (if (and encoding (not (memq encoding '(7BIT 8BIT BINARY))))
-		;; This is illegal, but Netscape does it.
-		encoding
-		(mime-body-one-part-encoding body)))))
-    (if (and (or (not enclosure)
-		 (let ((disposition (mime-body-disposition body)))
-		   (and disposition
-			(eq? (car disposition) 'INLINE)))
-		 (let ((subtype (mime-body-subtype body)))
-		   (or (eq? subtype 'PLAIN)
-		       (memq subtype
-			     (ref-variable imail-inline-mime-text-subtypes
-					   mark)))))
-	     (known-mime-encoding? encoding)
-	     (re-string-match
-	      (string-append "\\`"
-			     (apply regexp-group
-				    (ref-variable imail-known-mime-charsets
-						  mark))
-			     "\\'")
-	      (mime-body-parameter body 'CHARSET "us-ascii")
-	      #t))
-	(begin
-	  (maybe-insert-mime-boundary context mark)
-	  (call-with-auto-wrapped-output-mark
-	   mark
-	   (insert-mime-context-left-margin context)
-	   (lambda (port)
-	     (call-with-mime-decoding-output-port encoding port #t
-	       (lambda (port)
-		 (write-mime-message-body-part message
-					       (if (or (not enclosure)
-						       message-enclosure?)
-						   `(,@selector TEXT)
-						   selector)
-					       #t
-					       port))))))
-	(insert-mime-message-attachment 'ATTACHMENT body selector context
-					mark))))
-
-(define (insert-mime-message-attachment class body selector context mark)
+  (if (and (or (not (insert-mime-context-enclosure context))
+	       (let ((disposition (mime-body-disposition body)))
+		 (and disposition
+		      (eq? (car disposition) 'INLINE)))
+	       (let ((subtype (mime-body-subtype body)))
+		 (or (eq? subtype 'PLAIN)
+		     (memq subtype
+			   (ref-variable imail-inline-mime-text-subtypes
+					 mark)))))
+	   (known-mime-encoding? (mime-part-encoding context body))
+	   (re-string-match
+	    (string-append "\\`"
+			   (apply regexp-group
+				  (ref-variable imail-known-mime-charsets
+						mark))
+			   "\\'")
+	    (mime-body-parameter body 'CHARSET "us-ascii")
+	    #t))
+      (begin
+	(maybe-insert-mime-boundary context mark)
+	(insert-mime-info (make-mime-info 'INLINE #t body selector context)
+			  message
+			  mark))
+      (insert-mime-message-attachment 'ATTACHMENT message body selector context
+				      mark)))
+
+(define (insert-mime-message-attachment class message body selector context
+					mark)
   (if (not (insert-mime-context-inline-only? context))
       (begin
 	(maybe-insert-mime-boundary context mark)
-	(let ((start (mark-right-inserting-copy mark)))
-	  (insert-string "<IMAIL-" mark)
-	  (insert-string (string-upcase (symbol->string class)) mark)
-	  (insert-string " " mark)
-	  (let ((column (mark-column mark)))
-	    (let ((name (mime-attachment-name body selector #f)))
-	      (if name
-		  (begin
-		    (insert-string "name=" mark)
-		    (insert name mark)
-		    (insert-newline mark)
-		    (change-column column mark))))
-	    (insert-string "type=" mark)
-	    (insert (mime-body-type body) mark)
-	    (insert-string "/" mark)
-	    (insert (mime-body-subtype body) mark)
-	    (insert-newline mark)
-	    (if (eq? (mime-body-type body) 'TEXT)
-		(begin
-		  (change-column column mark)
-		  (insert-string "charset=" mark)
-		  (insert (mime-body-parameter body 'CHARSET "us-ascii") mark)
-		  (insert-newline mark)))
-	    (let ((encoding (mime-body-one-part-encoding body)))
-	      (if (not (known-mime-encoding? encoding))
-		  (begin
-		    (change-column column mark)
-		    (insert-string "encoding=" mark)
-		    (insert encoding mark)
-		    (insert-newline mark))))
+	(insert-mime-info (make-mime-info class #f body selector context)
+			  message
+			  mark))))
+
+(define (insert-mime-info info message mark)
+  (let ((start (mark-right-inserting-copy mark)))
+    (if (mime-info-expanded? info)
+	(insert-mime-info-expanded info message mark)
+	(insert-mime-info-collapsed info message mark))
+    (attach-mime-info start mark info)
+    (mark-temporary! start)))
+
+(define (insert-mime-info-expanded info message mark)
+  (let ((context (mime-info-context info)))
+    (call-with-auto-wrapped-output-mark
+     mark
+     (insert-mime-context-left-margin context)
+     (lambda (port)
+       (call-with-mime-decoding-output-port
+	(mime-part-encoding context (mime-info-body info))
+	port
+	#t
+	(lambda (port)
+	  (write-mime-message-body-part
+	   message
+	   (if (let ((enclosure (insert-mime-context-enclosure context)))
+		 (or (not enclosure)
+		     (and (eq? (mime-body-type enclosure) 'MESSAGE)
+			  (eq? (mime-body-subtype enclosure) 'RFC822))))
+	       `(,@(mime-info-selector info) TEXT)
+	       (mime-info-selector info))
+	   #t
+	   port)))))))
+
+(define (insert-mime-info-collapsed info message mark)
+  message
+  (let ((body (mime-info-body info)))
+    (insert-string "<IMAIL-" mark)
+    (insert-string (string-upcase (symbol->string (mime-info-class info)))
+		   mark)
+    (insert-string " " mark)
+    (let ((column (mark-column mark)))
+      (let ((name (mime-attachment-name info #f)))
+	(if name
+	    (begin
+	      (insert-string "name=" mark)
+	      (insert name mark)
+	      (insert-newline mark)
+	      (change-column column mark))))
+      (insert-string "type=" mark)
+      (insert (mime-body-type body) mark)
+      (insert-string "/" mark)
+      (insert (mime-body-subtype body) mark)
+      (insert-newline mark)
+      (if (eq? (mime-body-type body) 'TEXT)
+	  (begin
 	    (change-column column mark)
-	    (insert-string "length=" mark)
-	    (insert (mime-body-one-part-n-octets body) mark))
-	  (insert-string ">" mark)
-	  (region-put! start mark 'IMAIL-MIME-ATTACHMENT (cons body selector))
-	  (mark-temporary! start))
-	(insert-newline mark))))
-
+	    (insert-string "charset=" mark)
+	    (insert (mime-body-parameter body 'CHARSET "us-ascii") mark)
+	    (insert-newline mark)))
+      (let ((encoding (mime-body-one-part-encoding body)))
+	(if (not (known-mime-encoding? encoding))
+	    (begin
+	      (change-column column mark)
+	      (insert-string "encoding=" mark)
+	      (insert encoding mark)
+	      (insert-newline mark))))
+      (change-column column mark)
+      (insert-string "length=" mark)
+      (insert (mime-body-one-part-n-octets body) mark))
+    (insert-string ">" mark)
+    (insert-newline mark)))
+
 (define (known-mime-encoding? encoding)
   (memq encoding '(7BIT 8BIT BINARY QUOTED-PRINTABLE BASE64)))
 
-(define (mime-attachment-name body selector provide-default?)
-  (or (mime-body-parameter body 'NAME #f)
+(define (mime-attachment-name info provide-default?)
+  (or (mime-body-parameter (mime-info-body info) 'NAME #f)
       (and provide-default?
-	   (string-append "unnamed-attachment-"
-			  (if (null? selector)
-			      "0"
-			      (decorated-string-append
-			       "" "." ""
-			       (map (lambda (n) (number->string (+ n 1)))
-				    selector)))))))
-
-(define (mark-mime-attachment mark)
-  (region-get mark 'IMAIL-MIME-ATTACHMENT #f))
-
-(define (buffer-mime-attachments buffer)
+	   (string-append (if (eq? (mime-info-class info) 'INLINE)
+			      "inline-"
+			      "unnamed-attachment-")
+			  (let ((selector (mime-info-selector info)))
+			    (if (null? selector)
+				"0"
+				(decorated-string-append
+				 "" "." ""
+				 (map (lambda (n) (number->string (+ n 1)))
+				      selector))))))))
+
+(define (attach-mime-info start end info)
+  (region-put! start end 'IMAIL-MIME-INFO info))
+
+(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 '()))
-      (let ((index
-	     (next-specific-property-change (mark-group start)
-					    (mark-index start)
-					    (mark-index end)
-					    'IMAIL-MIME-ATTACHMENT))
+      (let ((mark
+	     (find-next-specific-property-change start end 'IMAIL-MIME-INFO))
 	    (attachments
-	     (let ((attachment (region-get start 'IMAIL-MIME-ATTACHMENT #f)))
+	     (let ((attachment (region-get start 'IMAIL-MIME-INFO #f)))
 	       (if attachment
-		   (cons attachment attachments)
+		   (cons (cons attachment start) attachments)
 		   attachments))))
-	(if index
-	    (loop (make-mark (mark-group start) index) attachments)
+	(if mark
+	    (loop mark attachments)
 	    (reverse! attachments))))))
+
+(define-structure mime-info
+  (class #f read-only #t)
+  (expanded? #f)
+  (body #f read-only #t)
+  (selector #f read-only #t)
+  (context #f read-only #t))
 
 (define (call-with-mime-decoding-output-port encoding port text? generator)
   (case encoding
diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index 11d0a9904..6e00f8545 100644
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail.pkg,v 1.66 2000/06/26 15:28:14 cph Exp $
+;;; $Id: imail.pkg,v 1.67 2000/06/26 19:02:38 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -243,6 +243,7 @@
 	  edwin-command$imail-summary-by-regexp
 	  edwin-command$imail-summary-by-topic
 	  edwin-command$imail-summary-select-message
+	  edwin-command$imail-toggle-attachment
 	  edwin-command$imail-toggle-header
 	  edwin-command$imail-toggle-message
 	  edwin-command$imail-undelete-backward
diff --git a/v7/src/imail/todo.txt b/v7/src/imail/todo.txt
index e8ec7f0b5..042c15e02 100644
--- a/v7/src/imail/todo.txt
+++ b/v7/src/imail/todo.txt
@@ -1,5 +1,5 @@
 IMAIL To-Do List
-$Id: todo.txt,v 1.97 2000/06/26 15:28:37 cph Exp $
+$Id: todo.txt,v 1.98 2000/06/26 19:02:39 cph Exp $
 
 Bug fixes
 ---------
@@ -34,8 +34,6 @@ New features
 * Examine spec for text/enriched and see if it can be incorporated
   into the reader.
 
-* Command to save an attachment should work on inline entities too.
-
 * Support the "flagged" message flag by highlighting messages with
   this flag in the summary buffer.
 
@@ -43,10 +41,6 @@ New features
   original message using MIME, rather than the current copy-and-indent
   mechanism.
 
-* Command to expand attachment inline.  Sometimes attachments aren't
-  big binary things but small text things that are easier to view
-  inline.
-
 * Set the IMAIL buffer's modification bit to indicate whether the
   folder is locally modified.  Meaningful only for file folders.  Hook
   up the save-folder code into M-x save-some-buffers.