Changes committed gnus/lisp (ChangeLog gnus-art.el mm-decode.el)

"Katsumi Yamaoka" <[email protected]>
Newsgroups gmane.emacs.gnus.commits
Message-ID <[email protected]> 
Modified: ChangeLog gnus-art.el mm-decode.el

* gnus-art.el (gnus-article-browse-html-parts): Add message header and title to
 html parts.
(gnus-article-browse-html-article): Pass message header to it.

* mm-decode.el (mm-display-external): Use mm-add-meta-html-tag.


Index: ChangeLog
diff -u gnus/lisp/ChangeLog:7.1711 gnus/lisp/ChangeLog:7.1712
--- ChangeLog:7.1711	Sun Dec 16 19:31:16 2007
+++ ChangeLog	Mon Dec 17 11:55:02 2007
@@ -1,3 +1,11 @@
+2007-12-17  Katsumi Yamaoka  <[email protected]>
+
+	* gnus-art.el (gnus-article-browse-html-parts): Add message header and
+	title to html parts.
+	(gnus-article-browse-html-article): Pass message header to it.
+
+	* mm-decode.el (mm-display-external): Use mm-add-meta-html-tag.
+
 2007-12-16  Reiner Steib  <[email protected]>
 
 	* mml-sec.el, sieve-manage.el, smime.el: Make loading of password-cache
Index: gnus-art.el
diff -u gnus/lisp/gnus-art.el:7.247 gnus/lisp/gnus-art.el:7.248
--- gnus-art.el:7.247	Sat Dec 15 11:32:14 2007
+++ gnus-art.el	Mon Dec 17 11:55:02 2007
@@ -2798,9 +2798,10 @@
     (setq gnus-article-browse-html-temp-list nil))
   gnus-article-browse-html-temp-list)
 
-(defun gnus-article-browse-html-parts (list)
+(defun gnus-article-browse-html-parts (list &optional header)
   "View all \"text/html\" parts from LIST.
-Recurse into multiparts."
+Recurse into multiparts.  The optional HEADER that should be a decoded
+message header will be added to the bodies of the \"text/html\" parts."
   ;; Internal function used by `gnus-article-browse-html-article'.
   (let (type file charset tmp-file showed)
     ;; Find and show the html-parts.
@@ -2809,10 +2810,11 @@
       (cond ((not (listp handle)))
 	    ((or (equal (car (setq type (mm-handle-type handle))) "text/html")
 		 (and (equal (car type) "message/external-body")
-		      (setq file (or (mail-content-type-get type 'name)
-				     (mail-content-type-get
-				      (mm-handle-disposition handle)
-				      'filename)))
+		      (or header
+			  (setq file (or (mail-content-type-get type 'name)
+					 (mail-content-type-get
+					  (mm-handle-disposition handle)
+					  'filename))))
 		      (or (mm-handle-cache handle)
 			  (condition-case code
 			      (progn (mm-extern-cache-contents handle) t)
@@ -2825,24 +2827,109 @@
 			      type (mm-handle-type handle))
 			(equal (car type) "text/html"))))
 	     (when (or (setq charset (mail-content-type-get type 'charset))
+		       header
 		       (not file))
 	       (setq tmp-file (mm-make-temp-file
 			       ;; Do we need to care for 8.3 filenames?
 			       "mm-" nil ".html")))
-	     (if charset
-		 ;; Add a meta html tag to specify charset.
-		 (mm-with-unibyte-buffer
-		   (insert (if (eq charset 'gnus-decoded)
-			       (mm-encode-coding-string (mm-get-part handle)
-							(setq charset 'utf-8))
-			     (mm-get-part handle)))
-		   (if (or (mm-add-meta-html-tag handle charset)
-			   (not file))
-		       (mm-write-region (point-min) (point-max)
-					tmp-file nil nil nil 'binary t)
-		     (setq tmp-file nil)))
-	       (when tmp-file
-		 (mm-save-part-to-file handle tmp-file)))
+	     ;; Add a meta html tag to specify charset and a header.
+	     (cond
+	      (header
+	       (with-temp-buffer
+		 (mm-enable-multibyte)
+		 (setq case-fold-search t)
+		 (insert header "\n")
+		 (let ((title (message-fetch-field "subject"))
+		       body hcharset coding)
+		   (goto-char (point-min))
+		   (while (re-search-forward "\\(<\\)\\|\\(>\\)\\|&" nil t)
+		     (replace-match (cond ((match-beginning 1) "&lt;")
+					  ((match-beginning 2) "&gt;")
+					  (t "&amp;"))))
+		   (goto-char (point-min))
+		   (insert "<pre>")
+		   (goto-char (point-max))
+		   (insert "</pre>\n<hr>\n")
+		   (if (eq charset 'gnus-decoded)
+		       (setq charset 'utf-8
+			     header (mm-encode-coding-string (buffer-string)
+							     charset)
+			     title (when title
+				     (mm-encode-coding-string title charset))
+			     body (mm-encode-coding-string (mm-get-part handle)
+							   charset))
+		     (setq hcharset (mm-find-mime-charset-region (point-min)
+								 (point-max)))
+		     (cond ((> (length hcharset) 1)
+			    (setq hcharset 'utf-8
+				  coding hcharset))
+			   ((= (length hcharset) 1)
+			    (setq hcharset (car hcharset)
+				  coding (mm-charset-to-coding-system
+					  hcharset))))
+		     (if coding
+			 (if charset
+			     (progn
+			       (setq body
+				     (mm-charset-to-coding-system charset))
+			       (if (eq coding body)
+				   (setq header (mm-encode-coding-string
+						 (buffer-string) coding)
+					 title (when title
+						 (mm-encode-coding-string
+						  title coding))
+					 body (mm-get-part handle))
+				 (setq charset 'utf-8
+				       header (mm-encode-coding-string
+					       (buffer-string) charset)
+				       title (when title
+					       (mm-encode-coding-string
+						title charset))
+				       body (mm-encode-coding-string
+					     (mm-decode-coding-string
+					      (mm-get-part handle) body)
+					     charset))))
+			   (setq charset hcharset
+				 header (mm-encode-coding-string
+					 (buffer-string) coding)
+				 title (when title
+					 (mm-encode-coding-string
+					  title coding))
+				 body (mm-get-part handle)))
+		       (setq header (mm-string-as-unibyte (buffer-string))
+			     body (mm-get-part handle))))
+		   (erase-buffer)
+		   (mm-disable-multibyte)
+		   (insert body)
+		   (when charset
+		     (mm-add-meta-html-tag handle charset))
+		   (when title
+		     (goto-char (point-min))
+		     (unless (search-forward "<title>" nil t)
+		       (re-search-forward "<head>\\s-*" nil t)
+		       (insert "<title>" title "</title>\n"))))
+		 (goto-char (point-min))
+		 (or (re-search-forward
+		      "<body\\(?:\\s-+[^>]+\\|\\s-*\\)>\\s-*" nil t)
+		     (re-search-forward
+		      "</head\\(?:\\s-+[^>]+\\|\\s-*\\)>\\s-*" nil t))
+		 (insert header)
+		 (mm-write-region (point-min) (point-max)
+				  tmp-file nil nil nil 'binary t)))
+	      (charset
+	       (mm-with-unibyte-buffer
+		 (insert (if (eq charset 'gnus-decoded)
+			     (mm-encode-coding-string
+			      (mm-get-part handle)
+			      (setq charset 'utf-8))
+			   (mm-get-part handle)))
+		 (if (or (mm-add-meta-html-tag handle charset)
+			 (not file))
+		     (mm-write-region (point-min) (point-max)
+				      tmp-file nil nil nil 'binary t)
+		   (setq tmp-file nil))))
+	      (tmp-file
+	       (mm-save-part-to-file handle tmp-file)))
 	     (when tmp-file
 	       (add-to-list 'gnus-article-browse-html-temp-list tmp-file))
 	     (add-hook 'gnus-summary-prepare-exit-hook
@@ -2862,8 +2949,10 @@
     showed))
 
 ;; FIXME: Documentation in texi/gnus.texi missing.
-(defun gnus-article-browse-html-article ()
+(defun gnus-article-browse-html-article (&optional arg)
   "View \"text/html\" parts of the current article with a WWW browser.
+The message header is added to the beginning of every html part unless
+the prefix argument ARG is given.
 
 Warning: Spammers use links to images in HTML articles to verify
 whether you have read the message.  As
@@ -2874,20 +2963,35 @@
 If you alwasy want to display HTML part in the browser, set
 `mm-text-html-renderer' to nil."
   ;; Cf. `mm-w3m-safe-url-regexp'
-  (interactive)
-  (save-window-excursion
-    ;; Open raw article and select the buffer
-    (gnus-summary-show-article t)
-    (gnus-summary-select-article-buffer)
-    (let ((parts (mm-dissect-buffer t t)))
+  (interactive "P")
+  (if arg
+      (gnus-summary-show-article)
+    (let ((gnus-visible-headers (or (get 'gnus-visible-headers 'standard-value)
+				    gnus-visible-headers)))
+      (gnus-summary-show-article)))
+  (with-current-buffer gnus-article-buffer
+    (let ((header (unless arg
+		    (save-restriction
+		      (widen)
+		      (buffer-substring-no-properties
+		       (goto-char (point-min))
+		       (if (search-forward "\n\n" nil t)
+			   (match-beginning 0)
+			 (goto-char (point-max))
+			 (skip-chars-backward "\t\n ")
+			 (point))))))
+	  parts)
+      (set-buffer gnus-original-article-buffer)
+      (setq parts (mm-dissect-buffer t t))
       ;; If singlepart, enforce a list.
       (when (and (bufferp (car parts))
 		 (stringp (car (mm-handle-type parts))))
 	(setq parts (list parts)))
       ;; Process the list
-      (unless (gnus-article-browse-html-parts parts)
+      (unless (gnus-article-browse-html-parts parts header)
 	(gnus-error 3 "Mail doesn't contain a \"text/html\" part!"))
-      (gnus-summary-show-article))))
+      (unless arg
+	(gnus-summary-show-article)))))
 
 (defun article-hide-list-identifiers ()
   "Remove list identifies from the Subject header.
Index: mm-decode.el
diff -u gnus/lisp/mm-decode.el:7.59 gnus/lisp/mm-decode.el:7.60
--- mm-decode.el:7.59	Sun Dec 16 05:23:18 2007
+++ mm-decode.el	Mon Dec 17 11:55:02 2007
@@ -751,6 +751,7 @@
 		  (set-buffer (generate-new-buffer " *mm*"))
 		  (setq method nil))
 	      (mm-insert-part handle)
+	      (mm-add-meta-html-tag handle)
 	      (let ((win (get-buffer-window cur t)))
 		(when win
 		  (select-window win)))
@@ -774,6 +775,7 @@
 		  (mm-handle-set-undisplayer handle mm)))))
 	;; The function is a string to be executed.
 	(mm-insert-part handle)
+	(mm-add-meta-html-tag handle)
 	(let* ((dir (mm-make-temp-file
 		     (expand-file-name "emm." mm-tmp-directory) 'dir))
 	       (filename (or
lmpx.com only provides a reader for public news (NNTP) servers. It is not affiliated with the servers or forums shown here and is not responsible for the content of articles, which is written by their respective authors.