comparison lisp/gnus/mm-decode.el @ 60302:f34a552e4a9f

Revision: [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-139 Merge from gnus--rel--5.10 Patches applied: * [e-mail]--gnu-2005/gnus--rel--5.10 (patch 32-33) - Merge from emacs--cvs-trunk--0 - Update from CVS 2005-02-27 Arne J,Ax(Brgensen <[e-mail]> * lisp/gnus/mm-decode.el (mm-dissect-buffer): Pass the from field on to `mm-dissect-multipart' and receive the from field as an (optional) argument from `mm-dissect-multipart'. (mm-dissect-multipart): Receive the from field as an argument and pass it on when we call `mm-dissect-buffer' on MIME parts. Fixes verification/decryption of signed/encrypted MIME parts.

60301:f3c5c717aa02

(defun mm-destroy-postponed-undisplay-list ()
  (when mm-postponed-undisplay-list
    (message "Destroying external MIME viewers")
    (mm-destroy-parts mm-postponed-undisplay-list)))

(defun mm-dissect-buffer (&optional no-strict-mime loose-mime)
  "Dissect the current buffer and return a list of MIME handles."
  (save-excursion
    (let (ct ctl type subtype cte cd description id result from)
      (save-restriction
	(mail-narrow-to-head)
	(when (or no-strict-mime
		  loose-mime
		  (mail-fetch-field "mime-version"))
	  (setq ct (mail-fetch-field "content-type")
		ctl (ignore-errors (mail-header-parse-content-type ct))
		cte (mail-fetch-field "content-transfer-encoding")
		cd (mail-fetch-field "content-disposition")
		description (mail-fetch-field "content-description")
		from (mail-fetch-field "from")
		id (mail-fetch-field "content-id"))
	  ;; FIXME: In some circumstances, this code is running within
	  ;; an unibyte macro.  mail-extract-address-components
	  ;; creates unibyte buffers. This `if', though not a perfect
	  ;; solution, avoids most of them.
	  (if from

	     (add-text-properties 0 (length (car ctl))
				  (list 'buffer (mm-copy-to-buffer)
					'from from
					'start start)
				  (car ctl))
	     (cons (car ctl) (mm-dissect-multipart ctl))))
	  (t
	   (mm-possibly-verify-or-decrypt
	    (mm-dissect-singlepart
	     ctl
	     (and cte (intern (downcase (mail-header-remove-whitespace

		(assoc 'format ctl)
	      t))
    (mm-make-handle
     (mm-copy-to-buffer) ctl cte nil cdl description nil id)))

(defun mm-dissect-multipart (ctl)
  (goto-char (point-min))
  (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
	 (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))
	 start parts
	 (end (save-excursion

      (goto-char (match-beginning 0))
      (when start
	(save-excursion
	  (save-restriction
	    (narrow-to-region start (point))
	    (setq parts (nconc (list (mm-dissect-buffer t)) parts)))))
      (end-of-line 2)
      (or (looking-at boundary)
	  (forward-line 1))
      (setq start (point)))
    (when (and start (< start end))
      (save-excursion
	(save-restriction
	  (narrow-to-region start end)
	  (setq parts (nconc (list (mm-dissect-buffer t)) parts)))))
    (mm-possibly-verify-or-decrypt (nreverse parts) ctl)))

(defun mm-copy-to-buffer ()
  "Copy the contents of the current buffer to a fresh buffer."
  (save-excursion

60302:f34a552e4a9f

(defun mm-destroy-postponed-undisplay-list ()
  (when mm-postponed-undisplay-list
    (message "Destroying external MIME viewers")
    (mm-destroy-parts mm-postponed-undisplay-list)))

(defun mm-dissect-buffer (&optional no-strict-mime loose-mime from)
  "Dissect the current buffer and return a list of MIME handles."
  (save-excursion
    (let (ct ctl type subtype cte cd description id result)
      (save-restriction
	(mail-narrow-to-head)
	(when (or no-strict-mime
		  loose-mime
		  (mail-fetch-field "mime-version"))
	  (setq ct (mail-fetch-field "content-type")
		ctl (ignore-errors (mail-header-parse-content-type ct))
		cte (mail-fetch-field "content-transfer-encoding")
		cd (mail-fetch-field "content-disposition")
		description (mail-fetch-field "content-description")
		id (mail-fetch-field "content-id"))
	  (unless from
		(setq from (mail-fetch-field "from")))
	  ;; FIXME: In some circumstances, this code is running within
	  ;; an unibyte macro.  mail-extract-address-components
	  ;; creates unibyte buffers. This `if', though not a perfect
	  ;; solution, avoids most of them.
	  (if from

	     (add-text-properties 0 (length (car ctl))
				  (list 'buffer (mm-copy-to-buffer)
					'from from
					'start start)
				  (car ctl))
	     (cons (car ctl) (mm-dissect-multipart ctl from))))
	  (t
	   (mm-possibly-verify-or-decrypt
	    (mm-dissect-singlepart
	     ctl
	     (and cte (intern (downcase (mail-header-remove-whitespace

		(assoc 'format ctl)
	      t))
    (mm-make-handle
     (mm-copy-to-buffer) ctl cte nil cdl description nil id)))

(defun mm-dissect-multipart (ctl from)
  (goto-char (point-min))
  (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
	 (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))
	 start parts
	 (end (save-excursion

      (goto-char (match-beginning 0))
      (when start
	(save-excursion
	  (save-restriction
	    (narrow-to-region start (point))
	    (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts)))))
      (end-of-line 2)
      (or (looking-at boundary)
	  (forward-line 1))
      (setq start (point)))
    (when (and start (< start end))
      (save-excursion
	(save-restriction
	  (narrow-to-region start end)
	  (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts)))))
    (mm-possibly-verify-or-decrypt (nreverse parts) ctl)))

(defun mm-copy-to-buffer ()
  "Copy the contents of the current buffer to a fresh buffer."
  (save-excursion