Mercurial > emacs

--- a/lisp/mail/rmailmm.el	Wed Feb 01 19:26:54 2006 +0000
+++ b/lisp/mail/rmailmm.el	Fri Feb 03 23:10:35 2006 +0000
@@ -25,29 +25,25 @@
 ;;; Commentary:

 ;; Essentially based on the design of Alexander Pohoyda's MIME
-;; extensions (mime-display.el and mime.el).  The current design tries
-;; to work on the current buffer, without changing it's text.  All it
-;; does is add text properties: It uses the text property `invisible'
-;; to hide MIME boundaries and ignored media types, and it uses the
-;; text property `display' to display something instead of the actual
-;; MIME part.
+;; extensions (mime-display.el and mime.el).  To use, copy a complete
+;; message into a new buffer and call (mime-show t).

 ;;; Code:

 ;;; Variables

-(defcustom mime-media-type-handlers-alist
-  '(("multipart/.*" mime-multipart-handler)
-    ("message/rfc822" mime-toggler-handler)
-    ("message/delivery-status" mime-entity-hider-handler)
-    ("message/x-body" mime-entity-hider-handler)
-    ("message/x-command-input" mime-message/x-command-input-handler)
-    ("message/external-body" mime-message/external-body-handler)
-    ("text/.*" mime-text-handler)
-    ("text/\\(x-\\)?patch" mime-bulk-handler)
-    ("image/.*" mime-image-handler)
-    ("application/pgp-signature" mime-application/pgp-signature-handler)
-    ("\\(image\\|audio\\|video\\|application\\)/.*" mime-bulk-handler))
+(defcustom rmail-mime-media-type-handlers-alist
+  '(("multipart/.*" rmail-mime-multipart-handler)
+    ("message/rfc822" rmail-mime-toggler-handler)
+    ("message/delivery-status" rmail-mime-entity-hider-handler)
+    ("message/x-body" rmail-mime-entity-hider-handler)
+    ("message/x-command-input" rmail-mime-message/x-command-input-handler)
+    ("message/external-body" rmail-mime-message/external-body-handler)
+    ("text/.*" rmail-mime-text-handler)
+    ("text/\\(x-\\)?patch" rmail-mime-bulk-handler)
+    ("image/.*" rmail-mime-image-handler)
+    ("application/pgp-signature" rmail-mime-application/pgp-signature-handler)
+    ("\\(image\\|audio\\|video\\|application\\)/.*" rmail-mime-bulk-handler))
   "Alist of media type handlers, also known as agents.
 Every handler is a list of type (string symbol) where STRING is a
 regular expression to match the media type with and SYMBOL is a
@@ -55,92 +51,112 @@
   :type 'list
   :group 'mime)

-(defcustom mime-attachment-dirs-alist
-  '(("text/.*" ("~/Documents"))
-    ("image/.*" ("~/Pictures"))
-    (".*" ("/tmp/")))
-  "Default directories to save attachments into.  Each media type may have
-it's own directory."
+(defcustom rmail-mime-attachment-dirs-alist
+  '(("text/.*" "~/Documents")
+    ("image/.*" "~/Pictures")
+    (".*" "~/Desktop" "~" "/tmp"))
+  "Default directories to save attachments into.
+Each media type may have it's own list of directories in order of
+preference.  The first existing directory in the list will be
+used."
   :type 'list
   :group 'mime)

-(defvar mime-total-number-of-bulk-attachments 0
+(defvar rmail-mime-total-number-of-bulk-attachments 0
   "A total number of attached bulk bodyparts in the message.  If more than 3,
 offer a way to save all attachments at once.")
-(put 'mime-total-number-of-bulk-attachments 'permanent-local t)
-
-;;; Utility Functions
-
-(defun mime-hide-region (from to)
-  "Put text property `invisible' on the region FROM TO."
-  (put-text-property from to 'invisible t))
-
-(defun mime-unhide-region (from to)
-  "Remove the text property `invisible' on the region FROM TO."
-  (remove-text-properties from to '(invisible nil)))
-
-(defun mime-display-region-as (from to text)
-  "Put text property `display' with value TEXT on the region FROM TO."
-  (put-text-property from to 'display text))
+(put 'rmail-mime-total-number-of-bulk-attachments 'permanent-local t)

 ;;; Buttons

-(defun mime-save (button)
+(defun rmail-mime-save (button)
   "Save the attachment using info in the BUTTON."
   (let* ((filename (button-get button 'filename))
 	 (directory (button-get button 'directory))
 	 (data (button-get button 'data)))
+    (while (file-exists-p (expand-file-name filename directory))
+      (let* ((f (file-name-sans-extension filename))
+	     (i 1))
+	(when (string-match "-\\([0-9]+\\)$" f)
+	  (setq i (1+ (string-to-number (match-string 1 f)))
+		f (substring f 0 (match-beginning 0))))
+	(setq filename (concat f "-" (number-to-string i) "."
+			       (file-name-extension filename)))))
     (setq filename (expand-file-name
-		    (read-file-name "Save as: "
-				    directory nil nil filename)))
+		    (read-file-name (format "Save as (default: %s): " filename)
+				    directory
+				    (expand-file-name filename directory))
+		    directory))
     (when (file-regular-p filename)
       (error (message "File `%s' already exists" filename)))
     (with-temp-file filename
       (set-buffer-file-coding-system 'no-conversion)
       (insert data))))

-(define-button-type 'mime-save
-  'action 'mime-save)
+(define-button-type 'rmail-mime-save
+  'action 'rmail-mime-save)

 ;;; Handlers

-(defun mime-text-handler (content-type
-			  content-disposition
-			  content-transfer-encoding)
+(defun rmail-mime-text-handler (content-type
+				content-disposition
+				content-transfer-encoding)
   "Handle the current buffer as a plain text MIME part.")

-(defun mime-bulk-handler (content-type
-			  content-disposition
-			  content-transfer-encoding)
+(defun rmail-mime-bulk-handler (content-type
+				content-disposition
+				content-transfer-encoding)
   "Handle the current buffer as an attachment to download."
-  (setq mime-total-number-of-bulk-attachments
-	(1+ mime-total-number-of-bulk-attachments))
+  (setq rmail-mime-total-number-of-bulk-attachments
+	(1+ rmail-mime-total-number-of-bulk-attachments))
   ;; Find the default directory for this media type
   (let* ((directory (catch 'directory
-		    (dolist (entry mime-attachment-dirs-alist)
-		      (when (string-match (car entry) (car content-type))
-			(throw 'directory (cadr entry))))))
+		      (dolist (entry rmail-mime-attachment-dirs-alist)
+			(when (string-match (car entry) (car content-type))
+			  (dolist (dir (cdr entry))
+			    (when (file-directory-p dir)
+			      (throw 'directory dir)))))))
 	 (filename (or (cdr (assq 'name (cdr content-type)))
 		       (cdr (assq 'filename (cdr content-disposition)))
 		       "noname"))
-	 (button (format "\nAttached %s file: %s"
-			 (car content-type)
-			 (let ((data (buffer-string)))
-			   (with-temp-buffer
-			     (insert-button filename :type 'mime-save
-					    'filename filename
-					    'directory directory
-					    'data data)
-			     (buffer-string))))))
-    (mime-display-region-as (point-min) (point-max) button)))
+	 (label (format "\nAttached %s file: " (car content-type)))
+	 (data (buffer-string)))
+    (delete-region (point-min) (point-max))
+    (insert label)
+    (insert-button filename
+		   :type 'rmail-mime-save
+		   'filename filename
+		   'directory directory
+		   'data data)))

-(defun mime-multipart-handler (content-type
-			       content-disposition
-			       content-transfer-encoding)
+(defun test-rmail-mime-bulk-handler ()
+  "Test of a mail used as an example in RFC 2183."
+  (let ((mail "Content-Type: image/jpeg
+Content-Disposition: attachment; filename=genome.jpeg;
+  modification-date=\"Wed, 12 Feb 1997 16:29:51 -0500\";
+Content-Description: a complete map of the human genome
+Content-Transfer-Encoding: base64
+
+iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAMAAABg3Am1AAAABGdBTUEAALGPC/xhBQAAAAZQ
+TFRF////AAAAVcLTfgAAAPZJREFUeNq9ldsOwzAIQ+3//+l1WlvA5ZLsoUiTto4TB+ISoAjy
++ITfRBfcAmgRFFeAm+J6uhdKdFhFWUgDkFsK0oUp/9G2//Kj7Jx+5tSKOdBscgUYiKHRS/me
+WATQdRUvAK0Bnmshmtn79PpaLBbbOZkjKvRnjRZoRswOkG1wFchKew2g9wXVJVZL/m4+B+vv
+9AxQQR2Q33SgAYJzzVACdAWjAfRYzYFO9n6SLnydtQHSMxYDMAKqZ/8FS/lTK+zuq3CtK64L
+UDwbgUEAUmk2Zyg101d6PhCDySgAvTvDgKiuOrc4dLxUb7UMnhGIexyI+d6U+ABuNAP4Simx
+lgAAAABJRU5ErkJggg==
+"))
+    (switch-to-buffer (get-buffer-create "*test*"))
+    (erase-buffer)
+    (insert mail)
+    (rmail-mime-show)))
+
+(defun rmail-mime-multipart-handler (content-type
+				     content-disposition
+				     content-transfer-encoding)
   "Handle the current buffer as a multipart MIME body.
 The current buffer should be narrowed to the body.  CONTENT-TYPE,
 CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING are the values
-of the respective parsed headers.  See `mime-handle' for their
+of the respective parsed headers.  See `rmail-mime-handle' for their
 format."
   ;; Some MUAs start boundaries with "--", while it should start
   ;; with "CRLF--", as defined by RFC 2046:
@@ -150,46 +166,45 @@
   ;;    of the preceding part.
   ;; We currently don't handle that.
   (let ((boundary (cdr (assq 'boundary content-type)))
-	(beg (point-min))
-	next)
+	beg next)
     (unless boundary
       (error "No boundary defined" content-type content-disposition
 	     content-transfer-encoding))
     (setq boundary (concat "\n--" boundary))
     ;; Hide the body before the first bodypart
-    (goto-char beg)
+    (goto-char (point-min))
     (when (and (search-forward boundary nil t)
 	       (looking-at "[ \t]*\n"))
-      (mime-hide-region beg (match-end 0))
-      (setq beg (match-end 0)))
+      (delete-region (point-min) (match-end 0)))
     ;; Reset the counter
-    (setq mime-total-number-of-bulk-attachments 0)
+    (setq rmail-mime-total-number-of-bulk-attachments 0)
     ;; Loop over all body parts, where beg points at the beginning of
     ;; the part and end points at the end of the part.  next points at
     ;; the beginning of the next part.
+    (setq beg (point-min))
     (while (search-forward boundary nil t)
       (setq end (match-beginning 0))
       ;; If this is the last boundary according to RFC 2046, hide the
-      ;; epilogue, else hide the boundary only.
+      ;; epilogue, else hide the boundary only.  Use a marker for
+      ;; `next' because `rmail-mime-show' may change the buffer.
       (cond ((looking-at "--[ \t]*\n")
-	     (setq next (point-max)))
+	     (setq next (point-max-marker)))
 	    ((looking-at "[ \t]*\n")
-	     (setq next (match-end 0)))
+	     (setq next (copy-marker (match-end 0))))
 	    (t
 	     (error "Malformed boundary" content-type
 		    content-disposition content-transfer-encoding)))
-      (mime-hide-region end next)
+      (delete-region end next)
       ;; Handle the part.
       (save-match-data
 	(save-excursion
 	  (save-restriction
 	    (narrow-to-region beg end)
-	    ;; FIXME: Do decoding of content-transfer-encoding
-	    (mime-show))))
+	    (rmail-mime-show))))
       (setq beg next)
       (goto-char beg))))

-(defun test-mime-multipart-handler ()
+(defun test-rmail-mime-multipart-handler ()
   "Test of a mail used as an example in RFC 2046."
   (let ((mail "From: Nathaniel Borenstein <nsb@bellcore.com>
 To: Ned Freed <ned@innosoft.com>
@@ -218,12 +233,13 @@
     (switch-to-buffer (get-buffer-create "*test*"))
     (erase-buffer)
     (insert mail)
-    (mime-show t)
-    (buffer-string)))
+    (rmail-mime-show t)))

 ;;; Main code

-(defun mime-handle (content-type content-disposition content-transfer-encoding)
+(defun rmail-mime-handle (content-type
+			  content-disposition
+			  content-transfer-encoding)
   "Handle the current buffer as a MIME part.
 The current buffer should be narrowed to the respective body.
 CONTENT-TYPE, CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING
@@ -247,29 +263,38 @@

 \(\"multipart/mixed\"
   \(\"boundary\" . \"----=_NextPart_000_0104_01C617E4.BDEC4C40\"))"
+  ;; Handle the content transfer encodings we know.  Unknown transfer
+  ;; encodings will be passed on to the various handlers.
+  (cond ((string= content-transfer-encoding "base64")
+	 (base64-decode-region (point-min) (point-max))
+	 (setq content-transfer-encoding nil))
+	((string= content-transfer-encoding "quoted-printable")
+	 (quoted-printable-decode-region (point-min) (point-max))
+	 (setq content-transfer-encoding nil)))
+  ;; Inline stuff requires work.  Attachments are handled by the bulk
+  ;; handler.
   (if (string= "inline" (car content-disposition))
       (let ((stop nil))
-	(dolist (entry mime-media-type-handlers-alist)
+	(dolist (entry rmail-mime-media-type-handlers-alist)
 	  (when (and (string-match (car entry) (car content-type)) (not stop))
 	    (progn
 	      (setq stop (funcall (cadr entry) content-type
 				  content-disposition
 				  content-transfer-encoding))))))
-    ;; treat everything else as an attachment
-    (mime-bulk-handler content-type
+    ;; Everything else is an attachment.
+    (rmail-mime-bulk-handler content-type
 		       content-disposition
 		       content-transfer-encoding)))

-(defun mime-show (&optional show-headers)
+(defun rmail-mime-show (&optional show-headers)
   "Handle the current buffer as a MIME message.
 If SHOW-HEADERS is non-nil, then the headers of the current part
-are not all hidden, as they usually are \(except for
-message/rfc822 content types\).  This is usually only used for
-the top-level call.
+will shown as usual for a MIME message.  The headers are also
+shown for the content type message/rfc822.  This function will be
+called recursively if multiple parts are available.

-The current buffer must be narrowed to a single message.
-This function will be called recursively if multiple parts
-are available."
+The current buffer must contain a single message.  It will be
+modifed."
   (let ((end (point-min))
 	content-type
 	content-transfer-encoding
@@ -307,16 +332,17 @@
 	    ;; If none specified, we are free to choose what we deem
 	    ;; suitable according to RFC 2183.  We like inline.
 	    '("inline")))
-    ;; Hide headers.
-    (if (or (string= (car content-type) "message/rfc822")
-	    show-headers)
-	(rmail-header-hide-headers)
-      (mime-hide-region (point-min) end))
     ;; Unrecognized disposition types are to be treated like
     ;; attachment according to RFC 2183.
-    (unless (string= (car content-disposition) "inline")
+    (unless (member (car content-disposition) '("inline" "attachment"))
       (setq content-disposition '("attachment")))
+    ;; Hide headers and handle the part.
     (save-restriction
-      (narrow-to-region end (point-max))
-      (mime-handle content-type content-disposition
-		   content-transfer-encoding))))
+      (if (or show-headers
+	      (string= (car content-type) "message/rfc822"))
+	  (progn
+	    (rmail-header-hide-headers)
+	    (narrow-to-region end (point-max)))
+	(delete-region (point-min) end))
+      (rmail-mime-handle content-type content-disposition
+			 content-transfer-encoding))))