bug#4258: Preferring HTML parts

[Ken Olum <kdo@cosmos.phy.tufts.edu>]

[-- Attachment #1: Type: text/plain, Size: 167 bytes --]

OK, here is a new version of the patch including the change to only
default rmail-mime-prefer-html to t if we have a renderer.

                                  Ken


[-- Attachment #2: html-patch-new.text --]
[-- Type: text/plain, Size: 10248 bytes --]

*** trunk/lisp/ChangeLog	2014-08-27 13:46:08.509697000 -0400
--- new/lisp/ChangeLog	2014-09-04 11:40:20.490492186 -0400
***************
*** 1,3 ****
--- 1,21 ----
+ 2013-12-27  Ken Olum  <kdo@cosmos.phy.tufts.edu>
+ 
+ 	* mail/rmailmm.el (rmail-mime-process): Handle text/html
+ 	separately from other text/ types.  Suppress tagline for
+ 	multipart body.
+ 	(rmail-mime-parse): Don't change visibility of tagline here.
+ 	(rmail-mime-set-bulk-data, rmail-mime-insert-bulk):
+ 	Handle text/html specially.
+ 	(rmail-mime-render-html-function,rmail-mime-prefer-html): New variables.
+ 	(rmail-mime-insert-html, rmail-mime-render-html-shr)
+ 	(rmail-mime-render-html-lynx): New functions.
+ 	(rmail-mime-fix-inserted-faces): New function.
+ 	(rmail-mime-process-multipart): Find best part to show
+ 	following rmail-mime-prefer-html if set.
+ 	(rmail-mime-searching): New variable.
+ 	(rmail-search-mime-message): Bind rmail-mime-searching to
+ 	suppress rendering while searching.
+ 
  2014-08-27  Dmitry Antipov  <dmantipov@yandex.ru>
  
  	* startup.el (normal-top-level): Now use internal--top-level-message.
*** trunk/lisp/mail/rmailmm.el	Wed May 21 12:32:30 2014
--- new/lisp/mail/rmailmm.el	Fri Sep  5 12:00:31 2014
***************
*** 131,136 ****
--- 131,156 ----
    :version "23.2"
    :group 'rmail-mime)
  
+ (defcustom rmail-mime-render-html-function
+   (cond ((fboundp 'libxml-parse-html-region) 'rmail-mime-render-html-shr)
+ 	((executable-find "lynx") 'rmail-mime-render-html-lynx)
+ 	(t nil))
+   "Function to convert HTML to text.  Called with buffer containing HTML
+ extracted from message in a temporary buffer.  Converts to text in current 
+ buffer. If NIL, display HTML source."
+   :group 'rmail
+   :version "24.5"
+   :type '(choice function (const nil)))
+ 
+ (defcustom rmail-mime-prefer-html
+   ;; Default to preferring HTML parts, but only if we have a renderer
+   (if rmail-mime-render-html-function t nil)
+   "If non-nil, default to showing HTML part rather than text part
+ when both are available"
+   :group 'rmail
+   :version "24.5"
+   :type 'boolean)
+ 
  ;;; End of user options.
  
  ;;; Global variables that always have let-binding when referred.
***************
*** 150,155 ****
--- 170,179 ----
  The value is usually nil, and bound to non-nil while inserting
  MIME entities.")
  
+ (defvar rmail-mime-searching nil
+   "Bound to T inside `rmail-search-mime-message' to suppress expensive 
+ operations such as HTML decoding")
+ 
  ;;; MIME-entity object
  
  (defun rmail-mime-entity (type disposition transfer-encoding
***************
*** 631,636 ****
--- 655,711 ----
      (insert-image (create-image data (cdr bulk-data) t))
      (insert "\n")))
  
+ (defun rmail-mime-insert-html (entity)
+   "Decode, render, and insert html from MIME-entity ENTITY."
+   (let ((body (rmail-mime-entity-body entity))
+ 	(transfer-encoding (rmail-mime-entity-transfer-encoding entity))
+ 	(buffer (current-buffer)))
+     (with-temp-buffer
+       (set-buffer-multibyte nil)
+       (setq buffer-undo-list t)
+       (insert-buffer-substring rmail-mime-mbox-buffer
+ 			       (aref body 0) (aref body 1))
+       (cond ((string= transfer-encoding "base64")
+ 	     (ignore-errors (base64-decode-region (point-min) (point-max))))
+ 	    ((string= transfer-encoding "quoted-printable")
+ 	     (quoted-printable-decode-region (point-min) (point-max))))
+       ;; Convert html in temporary buffer to text and insert in original buffer
+       (let ((source-buffer (current-buffer)))
+ 	(with-current-buffer buffer
+ 	  (let ((start (point)))
+ 	    (if rmail-mime-render-html-function
+ 		(funcall rmail-mime-render-html-function source-buffer)
+ 	      (insert-buffer-substring source-buffer))
+ 	    (rmail-mime-fix-inserted-faces start)))))))
+ 
+ (defun rmail-mime-render-html-shr (source-buffer)
+   (let ((dom (with-current-buffer source-buffer
+ 	       (libxml-parse-html-region (point-min) (point-max))))
+ 	;; Image retrieval happens asynchronously, but meanwhile
+ 	;; `rmail-swap-buffers' may have been run, leaving
+ 	;; `shr-image-fetched' trying to insert the image in the wrong buffer.
+ 	(shr-inhibit-images t))
+     (shr-insert-document dom)))
+ 
+ (defun rmail-mime-render-html-lynx (source-buffer)
+   (let ((destination-buffer (current-buffer)))
+     (with-current-buffer source-buffer
+       (call-process-region (point-min) (point-max)
+ 			   "lynx" nil destination-buffer nil
+ 			   "-stdin" "-dump" "-force_html"
+ 			   "-dont_wrap_pre" "-width=70"))))
+ 
+ ;; Put font-lock-face properties matching face properties on text
+ ;; inserted, e.g., by shr, in text from START to point.
+ (defun rmail-mime-fix-inserted-faces (start)
+   (while (< start (point))
+     (let ((face (get-text-property start 'face))
+ 	  (next (next-single-property-change 
+ 		 start 'face (current-buffer) (point))))
+       (if face				; anything to do?
+ 	  (put-text-property start next 'font-lock-face face))
+       (setq start next))))
+     
  (defun rmail-mime-toggle-button (button)
    "Hide or show the body of the MIME-entity associated with BUTTON."
    (save-excursion
***************
*** 675,680 ****
--- 750,757 ----
  		    (setq size (/ (* size 7) 3)))))))
  
      (cond
+      ((string-match "text/html" content-type)
+       (setq type 'html))
       ((string-match "text/" content-type)
        (setq type 'text))
       ((string-match "image/\\(.*\\)" content-type)
***************
*** 784,789 ****
--- 861,872 ----
        (if (rmail-mime-display-body new)
  	  (cond ((eq (cdr bulk-data) 'text)
  		 (rmail-mime-insert-decoded-text entity))
+ 		((eq (cdr bulk-data) 'html)
+ 		 ;; Render HTML if display single message, but if searching
+ 		 ;; don't render but just search HTML itself.
+ 		 (if rmail-mime-searching
+ 		     (rmail-mime-insert-decoded-text entity)
+ 		   (rmail-mime-insert-html entity)))
  		((cdr bulk-data)
  		 (rmail-mime-insert-image entity))
  		(t
***************
*** 918,935 ****
        (setq entities (nreverse entities))
        (if (string-match "alternative" subtype)
  	  ;; Find the best entity to show, and hide all the others.
! 	  (let (best second)
  	    (dolist (child entities)
  	      (if (string= (or (car (rmail-mime-entity-disposition child))
  			       (car content-disposition))
  			   "inline")
! 		  (if (string-match "text/plain"
! 				    (car (rmail-mime-entity-type child)))
! 		      (setq best child)
! 		    (if (string-match "text/.*"
! 				      (car (rmail-mime-entity-type child)))
! 			(setq second child)))))
! 	    (or best (not second) (setq best second))
  	    (dolist (child entities)
  	      (unless (eq best child)
  		(aset (rmail-mime-entity-body child) 2 nil)
--- 1001,1028 ----
        (setq entities (nreverse entities))
        (if (string-match "alternative" subtype)
  	  ;; Find the best entity to show, and hide all the others.
! 	  ;; If rmail-mime-prefer-html is set, html is best, then plain.
! 	  ;; If not, plain is best, then html.
! 	  ;; Then comes any other text part.
! 	  ;; If thereto of the same type, earlier entities in the message (later
! 	  ;; in the reverse list) are preferred.
! 	  (let (best best-priority)
  	    (dolist (child entities)
  	      (if (string= (or (car (rmail-mime-entity-disposition child))
  			       (car content-disposition))
  			   "inline")
! 		  (let ((type (car (rmail-mime-entity-type child))))
! 		    (if (string-match "text/" type)
! 			;; Consider all inline text parts
! 			(let ((priority
! 			       (cond ((string-match "text/html" type)
! 				      (if rmail-mime-prefer-html 1 2))
! 				     ((string-match "text/plain" type)
! 				      (if rmail-mime-prefer-html 2 1))
! 				     (t 3))))
! 			  (if (or (null best) (<= priority best-priority))
! 			      (setq best child
! 				    best-priority priority)))))))
  	    (dolist (child entities)
  	      (unless (eq best child)
  		(aset (rmail-mime-entity-body child) 2 nil)
***************
*** 1114,1119 ****
--- 1207,1214 ----
  	  (cond ((string-match "multipart/.*" (car content-type))
  		 (save-restriction
  		   (narrow-to-region (1- end) (point-max))
+ 		   (if (zerop (length parse-tag)) ; top level of message
+ 		       (aset new 1 (aset tagline 2 nil))) ; don't show tagline
  		   (setq children (rmail-mime-process-multipart
  				   content-type
  				   content-disposition
***************
*** 1134,1139 ****
--- 1229,1240 ----
  		     (aset (rmail-mime-entity-tagline msg) 2 nil)
  		     (setq children (list msg)
  			   handler 'rmail-mime-insert-multipart))))
+ 		((and is-inline (string-match "text/html" (car content-type)))
+ 		 ;; Display tagline, so part can be detached
+ 		 (aset new 1 (aset tagline 2 t))
+ 		 (aset new 2 (aset body 2 t)) ; display body also.
+ 		 (setq handler 'rmail-mime-insert-bulk))
+ 		;; Inline non-HTML text
  		((and is-inline (string-match "text/" (car content-type)))
  		 ;; Don't need a tagline.
  		 (aset new 1 (aset tagline 2 nil))
***************
*** 1186,1195 ****
  		   (new (aref (rmail-mime-entity-display entity) 1)))
  	      ;; Show header.
  	      (aset new 0 (aset (rmail-mime-entity-header entity) 2 t))
- 	      ;; Show tagline if and only if body is not shown.
- 	      (if (aref new 2)
- 		  (aset new 1 (aset (rmail-mime-entity-tagline entity) 2 nil))
- 		(aset new 1 (aset (rmail-mime-entity-tagline entity) 2 t)))
  	      entity)))
        (error (format "%s" err)))))
  
--- 1287,1292 ----
***************
*** 1390,1396 ****
    "Function to set in `rmail-search-mime-message-function' (which see)."
    (save-restriction
      (narrow-to-region (rmail-msgbeg msg) (rmail-msgend msg))
!     (let* ((rmail-mime-mbox-buffer (current-buffer))
  	   (rmail-mime-view-buffer rmail-view-buffer)
  	   (header-end (save-excursion
  			 (re-search-forward "^$" nil 'move) (point)))
--- 1487,1494 ----
    "Function to set in `rmail-search-mime-message-function' (which see)."
    (save-restriction
      (narrow-to-region (rmail-msgbeg msg) (rmail-msgend msg))
!     (let* ((rmail-mime-searching t)	; mark inside search
! 	   (rmail-mime-mbox-buffer (current-buffer))
  	   (rmail-mime-view-buffer rmail-view-buffer)
  	   (header-end (save-excursion
  			 (re-search-forward "^$" nil 'move) (point)))