gnus-mime-strip-part: removing attachments

[Reiner Steib <4.uce.03.r.s@nurfuerspam.de>]

Hi,

some time ago a function to remove an attachment has been
requested[1].  I like the idea (it's a feature that even Pine has!).

Here's my draft version of `gnus-mime-strip-part', which is in fact
only a modification of `gnus-mime-save-part-and-strip'.  I would
appreciate comments.  I intend to add it to `gnus-art.el' unless
someone objects.

--8<---------------cut here---------------start------------->8---
(defun gnus-mime-strip-part ()
  "Strip the MIME part under point."
  (interactive)
  (gnus-article-check-buffer)
  (let* ((data (get-text-property (point) 'gnus-data))
	 (handles gnus-article-mime-handles)
	 (none "(none)")
	 (description
	  (or
	   (mail-decode-encoded-word-string (or (mm-handle-description data)
						none))))
	 (filename
	  (or (mail-content-type-get (mm-handle-disposition data) 'filename)
	      none))
	 (type (mm-handle-media-type data)))
    (if (mm-multiple-handles gnus-article-mime-handles)
	(error "This function is not implemented"))
    (with-current-buffer (mm-handle-buffer data)
      (let ((bsize (format "%s" (buffer-size))))
	(erase-buffer)
	(insert
	 (concat
	  "<#REMOVETHISpart type=text/plain nofile=yes disposition=attachment"
	  " description=\"Deleted attachment (" bsize " Byte)\">"
	  ",----\n"
	  "| The following attachment has been deleted:\n"
	  "|\n"
	  "| Type:           " type "\n"
	  "| Filename:       " filename "\n"
	  "| Size (encoded): " bsize " Byte\n"
	  "| Description:    " description "\n"
	  "`----\n"
	  "<#/REMOVETHISpart>"))
	(setcdr data
		(cdr (mm-make-handle nil `("text/plain"))))))
    (set-buffer gnus-summary-buffer)
    ;; FIXME: maybe some of the following code (borrowed from
    ;; `gnus-mime-save-part-and-strip') isn't necessary?
    (gnus-article-edit-article
     `(lambda ()
	(erase-buffer)
	(let ((mail-parse-charset (or gnus-article-charset
				      ',gnus-newsgroup-charset))
	      (mail-parse-ignored-charsets
	       (or gnus-article-ignored-charsets
		   ',gnus-newsgroup-ignored-charsets))
	      (mbl mml-buffer-list))
	  (setq mml-buffer-list nil)
	  (insert-buffer gnus-original-article-buffer)
	  (mime-to-mml ',handles)
	  (setq gnus-article-mime-handles nil)
	  (let ((mbl1 mml-buffer-list))
	    (setq mml-buffer-list mbl)
	    (set (make-local-variable 'mml-buffer-list) mbl1))
	  ;; LOCAL argument of add-hook differs between GNU Emacs
	  ;; and XEmacs. make-local-hook makes sure they are local.
	  (make-local-hook 'kill-buffer-hook)
	  (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
     `(lambda (no-highlight)
	(let ((mail-parse-charset (or gnus-article-charset
				      ',gnus-newsgroup-charset))
	      (message-options message-options)
	      (message-options-set-recipient)
	      (mail-parse-ignored-charsets
	       (or gnus-article-ignored-charsets
		   ',gnus-newsgroup-ignored-charsets)))
	  (mml-to-mime)
	  (mml-destroy-buffers)
	  (remove-hook 'kill-buffer-hook
		       'mml-destroy-buffers t)
	  (kill-local-variable 'mml-buffer-list))
	(gnus-summary-edit-article-done
	 ,(or (mail-header-references gnus-current-headers) "")
	 ,(gnus-group-read-only-p)
	 ,gnus-summary-buffer no-highlight))))
  ;; Not in `gnus-mime-save-part-and-strip':
  (gnus-article-edit-done)
  (gnus-summary-expand-window)
  (gnus-summary-show-article))
--8<---------------cut here---------------end--------------->8---

I'm afraid Gnus could get confused about the part-tags in this
function, so I added "REMOVETHIS".  Of course you should delete this,
when testing the function.

Bye, Reiner.

[1]
| From: Lars Magne Ingebrigtsen <larsi@gnus.org>
| Subject: Re: removing attachments in stored messages
| Newsgroups: gnu.emacs.gnus
| Date: Tue, 07 Jan 2003 05:42:20 +0100
| Message-ID: <m31y3pk1ub.fsf@quimbies.gnus.org>
| 
| Julien Avarre <eole@avarre.com> writes:
| 
| > Is there an easy way to remove attachment from a stored email in the
| > nnml backend when you are in the summary ? in the article-mode ? 
| 
| Sure.  Just `e' to edit the message, and remove the attachment.
-- 
       ,,,
      (o o)
---ooO-(_)-Ooo--- PGP key available via WWW   http://rsteib.home.pages.de/