From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Ken Olum Newsgroups: gmane.emacs.bugs Subject: bug#4258: Preferring HTML parts Date: Sat, 06 Sep 2014 20:11:03 -0400 Message-ID: References: <200908251936.10632.marcooliva@sapo.pt> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1410048750 9028 80.91.229.3 (7 Sep 2014 00:12:30 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Sun, 7 Sep 2014 00:12:30 +0000 (UTC) Cc: 4258@debbugs.gnu.org To: Eli Zaretskii Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Sun Sep 07 02:12:23 2014 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1XQQ5Z-00052W-6f for geb-bug-gnu-emacs@m.gmane.org; Sun, 07 Sep 2014 02:12:17 +0200 Original-Received: from localhost ([::1]:36633 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XQQ5Y-0005iy-LC for geb-bug-gnu-emacs@m.gmane.org; Sat, 06 Sep 2014 20:12:16 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:56811) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XQQ5Q-0005ir-ST for bug-gnu-emacs@gnu.org; Sat, 06 Sep 2014 20:12:13 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1XQQ5L-0003cz-0L for bug-gnu-emacs@gnu.org; Sat, 06 Sep 2014 20:12:08 -0400 Original-Received: from debbugs.gnu.org ([140.186.70.43]:41009) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XQQ5K-0003cv-TM for bug-gnu-emacs@gnu.org; Sat, 06 Sep 2014 20:12:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.80) (envelope-from ) id 1XQQ5K-0001g2-Bv for bug-gnu-emacs@gnu.org; Sat, 06 Sep 2014 20:12:02 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Ken Olum Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sun, 07 Sep 2014 00:12:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 4258 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch Original-Received: via spool by 4258-submit@debbugs.gnu.org id=B4258.14100486686381 (code B ref 4258); Sun, 07 Sep 2014 00:12:02 +0000 Original-Received: (at 4258) by debbugs.gnu.org; 7 Sep 2014 00:11:08 +0000 Original-Received: from localhost ([127.0.0.1]:60806 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.80) (envelope-from ) id 1XQQ4R-0001eq-7V for submit@debbugs.gnu.org; Sat, 06 Sep 2014 20:11:08 -0400 Original-Received: from cosmos.phy.tufts.edu ([130.64.83.16]:43435) by debbugs.gnu.org with esmtp (Exim 4.80) (envelope-from ) id 1XQQ4O-0001ed-91 for 4258@debbugs.gnu.org; Sat, 06 Sep 2014 20:11:05 -0400 Original-Received: from kdo by cosmos.phy.tufts.edu ([local]:local) with local id 1XQQ4N-0000s6-RD - Using Exim-4.80.1 (MandrivaLinux) MTA (return-path ); Sat, 06 Sep 2014 20:11:03 -0400 In-Reply-To: <83mwacdbe2.fsf@gnu.org> (message from Eli Zaretskii on Sat, 06 Sep 2014 18:19:49 +0300) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.15 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 3.x X-Received-From: 140.186.70.43 X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Original-Sender: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Xref: news.gmane.org gmane.emacs.bugs:93093 Archived-At: --=-=-= Content-Type: text/plain 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 --=-=-= Content-Type: text/plain Content-Disposition: attachment; filename=html-patch-new.text *** 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 + + * 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 * 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))) --=-=-=--