X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/e427b55370b28f55e285ce0ee4328246eb7522ea..4a2f33d1a11e0608d521520afcb14ec13dd1a722:/lisp/net/shr.el

diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 9d88d1ff44..2c8ff79763 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -1,6 +1,6 @@
 ;;; shr.el --- Simple HTML Renderer
 
-;; Copyright (C) 2010-2015 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: html
@@ -35,6 +35,7 @@
 (require 'browse-url)
 (require 'subr-x)
 (require 'dom)
+(require 'seq)
 
 (defgroup shr nil
   "Simple HTML Renderer"
@@ -57,7 +58,7 @@ fit these criteria."
   :group 'shr
   :type '(choice (const nil) regexp))
 
-(defcustom shr-use-fonts nil
+(defcustom shr-use-fonts t
   "If non-nil, use proportional fonts for text."
   :version "25.1"
   :group 'shr
@@ -152,7 +153,6 @@ cid: URL as the argument.")
 (defvar shr-ignore-cache nil)
 (defvar shr-external-rendering-functions nil)
 (defvar shr-target-id nil)
-(defvar shr-inhibit-decoration nil)
 (defvar shr-table-separator-length 1)
 (defvar shr-table-separator-pixel-width 0)
 (defvar shr-table-id nil)
@@ -178,7 +178,7 @@ cid: URL as the argument.")
 
 ;; Public functions and commands.
 (declare-function libxml-parse-html-region "xml.c"
-		  (start end &optional base-url))
+		  (start end &optional base-url discard-comments))
 
 (defun shr-render-buffer (buffer)
   "Display the HTML rendering of the current buffer."
@@ -204,6 +204,12 @@ cid: URL as the argument.")
       (goto-char begin)
       (shr-insert-document dom))))
 
+(defun shr--have-one-fringe-p ()
+  "Return non-nil if we know at least one of the fringes has non-zero width."
+  (and (fboundp 'fringe-columns)
+       (or (not (zerop (fringe-columns 'right)))
+           (not (zerop (fringe-columns 'left))))))
+
 ;;;###autoload
 (defun shr-insert-document (dom)
   "Render the parsed document DOM into the current buffer.
@@ -223,10 +229,29 @@ DOM should be a parse tree as generated by
 				     (if (not shr-use-fonts)
 					 shr-width
 				       (* shr-width (frame-char-width))))
+                                ;; We need to adjust the available
+                                ;; width for when the user disables
+                                ;; the fringes, which will cause the
+                                ;; display engine usurp one column for
+                                ;; the continuation glyph.
 				(if (not shr-use-fonts)
-				    (- (window-width) 2)
-				  (- (window-pixel-width)
-				     (* (frame-fringe-width) 2))))))
+				    (- (window-body-width) 1
+                                       (if (and (null shr-width)
+                                                (not (shr--have-one-fringe-p)))
+                                           0
+                                         1))
+				  (- (window-body-width nil t)
+                                     (* 2 (frame-char-width))
+                                     (if (and (null shr-width)
+                                              (not (shr--have-one-fringe-p)))
+                                         (* (frame-char-width) 2)
+                                       0)))))
+        bidi-display-reordering)
+    ;; If the window was hscrolled for some reason, shr-fill-lines
+    ;; below will misbehave, because it silently assumes that it
+    ;; starts with a non-hscrolled window (vertical-motion will move
+    ;; to a wrong place otherwise).
+    (set-window-hscroll nil 0)
     (shr-descend dom)
     (shr-fill-lines start (point))
     (shr-remove-trailing-whitespace start (point))
@@ -285,13 +310,25 @@ redirects somewhere else."
 (defun shr-next-link ()
   "Skip to the next link."
   (interactive)
-  (let ((skip (text-property-any (point) (point-max) 'help-echo nil)))
-    (if (or (eobp)
-	    (not (setq skip (text-property-not-all skip (point-max)
-						   'help-echo nil))))
-	(message "No next link")
+  (let ((current (get-text-property (point) 'shr-url))
+        (start (point))
+        skip)
+    (while (and (not (eobp))
+                (equal (get-text-property (point) 'shr-url) current))
+      (forward-char 1))
+    (cond
+     ((and (not (eobp))
+           (get-text-property (point) 'shr-url))
+      ;; The next link is adjacent.
+      (message "%s" (get-text-property (point) 'help-echo)))
+     ((or (eobp)
+          (not (setq skip (text-property-not-all (point) (point-max)
+                                                 'shr-url nil))))
+      (goto-char start)
+      (message "No next link"))
+     (t
       (goto-char skip)
-      (message "%s" (get-text-property (point) 'help-echo)))))
+      (message "%s" (get-text-property (point) 'help-echo))))))
 
 (defun shr-previous-link ()
   "Skip to the previous link."
@@ -407,8 +444,8 @@ size, and full-buffer size."
 	(shr-stylesheet shr-stylesheet)
 	(shr-depth (1+ shr-depth))
 	(start (point)))
-    ;; shr uses about 12 frames per nested node.
-    (if (> shr-depth (/ max-specpdl-size 12))
+    ;; shr uses many frames per nested node.
+    (if (> shr-depth (/ max-specpdl-size 15))
 	(setq shr-warning "Too deeply nested to render properly; consider increasing `max-specpdl-size'")
       (when style
 	(if (string-match "color\\|display\\|border-collapse" style)
@@ -440,8 +477,17 @@ size, and full-buffer size."
     (with-temp-buffer
       (let ((shr-indentation 0)
 	    (shr-start nil)
-	    (shr-internal-width (- (window-pixel-width)
-				   (* (frame-fringe-width) 2))))
+	    (shr-internal-width (- (window-body-width nil t)
+                                   (* 2 (frame-char-width))
+                                   ;; Adjust the window width for when
+                                   ;; the user disables the fringes,
+                                   ;; which causes the display engine
+                                   ;; to usurp one column for the
+                                   ;; continuation glyph.
+                                   (if (and (null shr-width)
+                                            (not (shr--have-one-fringe-p)))
+                                       (* (frame-char-width) 2)
+                                     0))))
 	(shr-insert text)
 	(buffer-string)))))
 
@@ -621,7 +667,9 @@ size, and full-buffer size."
 	;; There's no breakable point, so we give it up.
 	(let (found)
 	  (goto-char bp)
-	  (unless shr-kinsoku-shorten
+          ;; Don't overflow the window edge, even if
+          ;; shr-kinsoku-shorten is nil.
+	  (unless (or shr-kinsoku-shorten (null shr-width))
 	    (while (setq found (re-search-forward
 				"\\(\\c>\\)\\| \\|\\c<\\|\\c|"
 				(line-end-position) 'move)))
@@ -633,9 +681,12 @@ size, and full-buffer size."
        ;; Don't put kinsoku-bol characters at the beginning of a line,
        ;; or kinsoku-eol characters at the end of a line.
        (cond
-	(shr-kinsoku-shorten
+        ;; Don't overflow the window edge, even if shr-kinsoku-shorten
+        ;; is nil.
+	((or shr-kinsoku-shorten (null shr-width))
 	 (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
-		     (shr-char-kinsoku-eol-p (preceding-char)))
+		     (or (shr-char-kinsoku-eol-p (preceding-char))
+                         (shr-char-kinsoku-bol-p (following-char))))
 	   (backward-char 1))
 	 (when (setq failed (<= (point) start))
 	   ;; There's no breakable point that doesn't violate kinsoku,
@@ -709,6 +760,9 @@ size, and full-buffer size."
 	  shr-base))
   (when (zerop (length url))
     (setq url nil))
+  ;; Strip leading whitespace
+  (and url (string-match "\\`\\s-+" url)
+       (setq url (substring url (match-end 0))))
   (cond ((or (not url)
 	     (not base)
 	     (string-match "\\`[a-z]*:" url))
@@ -729,8 +783,13 @@ size, and full-buffer size."
 	 (url-expand-file-name url (concat (car base) (cadr base))))))
 
 (defun shr-ensure-newline ()
-  (unless (zerop (current-column))
-    (insert "\n")))
+  (unless (bobp)
+    (let ((prefix (get-text-property (line-beginning-position)
+				     'shr-prefix-length)))
+      (unless (or (zerop (current-column))
+                  (and prefix
+                       (= prefix (- (point) (line-beginning-position)))))
+        (insert "\n")))))
 
 (defun shr-ensure-paragraph ()
   (unless (bobp)
@@ -758,6 +817,10 @@ size, and full-buffer size."
 						    (line-end-position))
 		       (line-end-position)))))
 	(delete-region (match-beginning 0) (match-end 0)))
+       ;; We have a single blank line.
+       ((and (eolp) (bolp))
+        (insert "\n"))
+       ;; Insert new paragraph.
        (t
 	(insert "\n\n"))))))
 
@@ -780,16 +843,15 @@ size, and full-buffer size."
 ;; blank text at the start of the line, and the newline at the end, to
 ;; avoid ugliness.
 (defun shr-add-font (start end type)
-  (unless shr-inhibit-decoration
-    (save-excursion
-      (goto-char start)
-      (while (< (point) end)
-	(when (bolp)
-	  (skip-chars-forward " "))
-	(add-face-text-property (point) (min (line-end-position) end) type t)
-	(if (< (line-end-position) end)
-	    (forward-line 1)
-	  (goto-char end))))))
+  (save-excursion
+    (goto-char start)
+    (while (< (point) end)
+      (when (bolp)
+        (skip-chars-forward " "))
+      (add-face-text-property (point) (min (line-end-position) end) type t)
+      (if (< (line-end-position) end)
+          (forward-line 1)
+        (goto-char end)))))
 
 (defun shr-mouse-browse-url (ev)
   "Browse the URL under the mouse cursor."
@@ -862,7 +924,8 @@ If EXTERNAL, browse the URL using `shr-external-browser'."
     (let ((param (match-string 4 data))
 	  (payload (url-unhex-string (match-string 5 data))))
       (when (string-match "^.*\\(;[ \t]*base64\\)$" param)
-	(setq payload (base64-decode-string payload)))
+	(setq payload (ignore-errors
+                        (base64-decode-string payload))))
       payload)))
 
 ;; Behind display-graphic-p test.
@@ -913,7 +976,7 @@ element is the data blob and the second element is the content-type."
                             (image-animated-p image))))
             (image-animate image nil 60)))
 	image)
-    (insert alt)))
+    (insert (or alt ""))))
 
 (defun shr-rescale-image (data &optional content-type)
   "Rescale DATA, if too big, to fit the current buffer."
@@ -948,6 +1011,9 @@ Return a string with image data."
 		(search-forward "\r\n\r\n" nil t))
 	(shr-parse-image-data)))))
 
+(declare-function libxml-parse-xml-region "xml.c"
+		  (start end &optional base-url discard-comments))
+
 (defun shr-parse-image-data ()
   (let ((data (buffer-substring (point) (point-max)))
 	(content-type
@@ -1038,8 +1104,7 @@ ones, in case fg and bg are nil."
                (shr-color-visible bg fg)))))))
 
 (defun shr-colorize-region (start end fg &optional bg)
-  (when (and (not shr-inhibit-decoration)
-	     (or fg bg))
+  (when (and (or fg bg) (>= (display-color-cells) 88))
     (let ((new-colors (shr-color-check fg bg)))
       (when new-colors
 	(when fg
@@ -1066,6 +1131,15 @@ ones, in case fg and bg are nil."
 
 ;;; Tag-specific rendering rules.
 
+(defun shr-tag-html (dom)
+  (let ((dir (dom-attr dom 'dir)))
+    (cond
+     ((equal dir "ltr")
+      (setq bidi-paragraph-direction 'left-to-right))
+     ((equal dir "rtl")
+      (setq bidi-paragraph-direction 'right-to-left))))
+  (shr-generic dom))
+
 (defun shr-tag-body (dom)
   (let* ((start (point))
 	 (fgcolor (or (dom-attr dom 'fgcolor) (dom-attr dom 'text)))
@@ -1116,7 +1190,9 @@ ones, in case fg and bg are nil."
 
 (defun shr-tag-svg (dom)
   (when (and (image-type-available-p 'svg)
-	     (not shr-inhibit-images))
+	     (not shr-inhibit-images)
+             (dom-attr dom 'width)
+             (dom-attr dom 'height))
     (funcall shr-put-image-function (list (shr-dom-to-xml dom) 'image/svg+xml)
 	     "SVG Image")))
 
@@ -1209,8 +1285,7 @@ ones, in case fg and bg are nil."
 	(shr-ensure-newline)
 	(insert " "))
       (put-text-property start (1+ start) 'shr-target-id shr-target-id))
-    (when (and url
-	       (not shr-inhibit-decoration))
+    (when url
       (shr-urlify (or shr-start start) (shr-expand-url url) title))))
 
 (defun shr-tag-object (dom)
@@ -1297,7 +1372,7 @@ The preference is a float determined from `shr-prefer-media-type'."
         (start (point)))
     (unless url
       (setq url (car (shr--extract-best-source dom))))
-    (if image
+    (if (> (length image) 0)
         (shr-tag-img nil image)
       (shr-insert " [video] "))
     (shr-urlify start (shr-expand-url url))))
@@ -1344,9 +1419,7 @@ The preference is a float determined from `shr-prefer-media-type'."
 	      (and shr-blocked-images
 		   (string-match shr-blocked-images url)))
 	  (setq shr-start (point))
-	  (if (> (string-width alt) 8)
-	      (shr-insert (truncate-string-to-width alt 8))
-	    (shr-insert alt)))
+          (shr-insert alt))
 	 ((and (not shr-ignore-cache)
 	       (url-is-cached (shr-encode-url url)))
 	  (funcall shr-put-image-function (shr-get-image-data url) alt))
@@ -1407,6 +1480,10 @@ The preference is a float determined from `shr-prefer-media-type'."
   (shr-ensure-paragraph)
   (let ((shr-list-mode 'ul))
     (shr-generic dom))
+  ;; If we end on an empty <li>, then make sure we really end on a new
+  ;; paragraph.
+  (unless (bolp)
+    (insert "\n"))
   (shr-ensure-paragraph))
 
 (defun shr-tag-ol (dom)
@@ -1535,19 +1612,32 @@ The preference is a float determined from `shr-prefer-media-type'."
     ;; Then render the table again with these new "hard" widths.
     (shr-insert-table (shr-make-table dom sketch-widths t) sketch-widths)))
 
+(defun shr-table-body (dom)
+  (let ((tbodies (seq-filter (lambda (child)
+                               (eq (dom-tag child) 'tbody))
+                             (dom-non-text-children dom))))
+    (cond
+     ((null tbodies)
+      dom)
+     ((= (length tbodies) 1)
+      (car tbodies))
+     (t
+      ;; Table with multiple tbodies.  Convert into a single tbody.
+      `(tbody nil ,@(cl-reduce 'append
+                               (mapcar 'dom-non-text-children tbodies)))))))
+
 (defun shr-tag-table (dom)
   (shr-ensure-paragraph)
   (let* ((caption (dom-children (dom-child-by-tag dom 'caption)))
 	 (header (dom-non-text-children (dom-child-by-tag dom 'thead)))
-	 (body (dom-non-text-children (or (dom-child-by-tag dom 'tbody)
-					  dom)))
+	 (body (dom-non-text-children (shr-table-body dom)))
 	 (footer (dom-non-text-children (dom-child-by-tag dom 'tfoot)))
          (bgcolor (dom-attr dom 'bgcolor))
 	 (start (point))
 	 (shr-stylesheet (nconc (list (cons 'background-color bgcolor))
 				shr-stylesheet))
 	 (nheader (if header (shr-max-columns header)))
-	 (nbody (if body (shr-max-columns body)))
+	 (nbody (if body (shr-max-columns body) 0))
 	 (nfooter (if footer (shr-max-columns footer))))
     (if (and (not caption)
 	     (not header)
@@ -1676,17 +1766,18 @@ The preference is a float determined from `shr-prefer-media-type'."
 				 align)))
 	      (dolist (line lines)
 		(end-of-line)
-		(let ((start (point)))
-		  (insert
-		   line
-		   (propertize " "
-			       'display `(space :align-to (,pixel-align))
-			       'face (and (> (length line) 0)
-					  (shr-face-background
-					   (get-text-property
-					    (1- (length line)) 'face line)))
-			       'shr-table-indent shr-table-id)
-		   shr-table-vertical-line)
+		(let ((start (point))
+                      (background (and (> (length line) 0)
+                                       (shr-face-background
+                                        (get-text-property
+                                         (1- (length line)) 'face line))))
+                      (space (propertize
+                              " "
+                              'display `(space :align-to (,pixel-align))
+                              'shr-table-indent shr-table-id)))
+                  (when background
+                    (setq space (propertize space 'face background)))
+		  (insert line space shr-table-vertical-line)
 		  (shr-colorize-region
 		   start (1- (point)) (nth 5 column) (nth 6 column)))
 		(forward-line 1))
@@ -1709,13 +1800,16 @@ The preference is a float determined from `shr-prefer-media-type'."
 
 (defun shr-face-background (face)
   (and (consp face)
-       (let ((background nil))
-	 (dolist (elem face)
-	   (when (and (consp elem)
-		      (eq (car elem) :background))
-	     (setq background (cadr elem))))
-	 (and background
-	      (list :background background)))))
+       (or (and (plist-get face :background)
+                (list :background (plist-get face :background)))
+           (let ((background nil))
+             (dolist (elem face)
+               (when (and (consp elem)
+                          (eq (car elem) :background)
+                          (not background))
+                 (setq background (cadr elem))))
+             (and background
+                  (list :background background))))))
 
 (defun shr-expand-alignments (start end)
   (while (< (setq start (next-single-property-change
@@ -1802,7 +1896,6 @@ The preference is a float determined from `shr-prefer-media-type'."
 
 (defun shr-make-table-1 (dom widths &optional fill)
   (let ((trs nil)
-	(shr-inhibit-decoration (not fill))
 	(rowspans (make-vector (length widths) 0))
 	(colspan-remaining 0)
 	colspan-width colspan-count
@@ -2049,8 +2142,4 @@ The preference is a float determined from `shr-prefer-media-type'."
 
 (provide 'shr)
 
-;; Local Variables:
-;; coding: utf-8
-;; End:
-
 ;;; shr.el ends here