diff options
Diffstat (limited to 'lisp/net/shr.el')
| -rw-r--r-- | lisp/net/shr.el | 320 |
1 files changed, 198 insertions, 122 deletions
diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 4e584e131fa..fbd1a9b7661 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -30,7 +30,7 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) (eval-when-compile (require 'url)) ;For url-filename's setf handler. (require 'browse-url) (eval-when-compile (require 'subr-x)) @@ -38,6 +38,8 @@ (require 'seq) (require 'svg) (require 'image) +(require 'puny) +(require 'text-property-search) (defgroup shr nil "Simple HTML Renderer" @@ -51,46 +53,44 @@ width and height of the window. If they are larger than this, and Emacs supports it, then the images will be rescaled down to fit these criteria." :version "24.1" - :group 'shr :type 'float) (defcustom shr-blocked-images nil "Images that have URLs matching this regexp will be blocked." :version "24.1" - :group 'shr :type '(choice (const nil) regexp)) (defcustom shr-use-fonts t "If non-nil, use proportional fonts for text." :version "25.1" - :group 'shr + :type 'boolean) + +(defcustom shr-discard-aria-hidden nil + "If non-nil, don't render tags with `aria-hidden=\"true\"'. +This attribute is meant to tell screen readers to ignore a tag." + :version "27.1" :type 'boolean) (defcustom shr-use-colors t "If non-nil, respect color specifications in the HTML." :version "26.1" - :group 'shr :type 'boolean) (defcustom shr-table-horizontal-line nil "Character used to draw horizontal table lines. If nil, don't draw horizontal table lines." - :group 'shr :type '(choice (const nil) character)) (defcustom shr-table-vertical-line ?\s "Character used to draw vertical table lines." - :group 'shr :type 'character) (defcustom shr-table-corner ?\s "Character used to draw table corners." - :group 'shr :type 'character) (defcustom shr-hr-line ?- "Character used to draw hr lines." - :group 'shr :type 'character) (defcustom shr-width nil @@ -101,8 +101,7 @@ If `shr-use-fonts' is set, the mean character width is used to compute the pixel width, which is used instead." :version "25.1" :type '(choice (integer :tag "Fixed width in characters") - (const :tag "Use the width of the window" nil)) - :group 'shr) + (const :tag "Use the width of the window" nil))) (defcustom shr-bullet "* " "Bullet used for unordered lists. @@ -110,19 +109,14 @@ Alternative suggestions are: - \" \" - \" \"" :version "24.4" - :type 'string - :group 'shr) + :type 'string) -(defcustom shr-external-browser 'browse-url-default-browser - "Function used to launch an external browser." - :version "24.4" - :group 'shr - :type 'function) +(define-obsolete-variable-alias 'shr-external-browser + 'browse-url-secondary-browser-function "27.1") (defcustom shr-image-animate t "Non nil means that images that can be animated will be." :version "24.4" - :group 'shr :type 'boolean) (defvar shr-content-function nil @@ -133,14 +127,26 @@ cid: URL as the argument.") (defvar shr-put-image-function 'shr-put-image "Function called to put image and alt string.") -(defface shr-strike-through '((t (:strike-through t))) - "Font for <s> elements." - :group 'shr) +(defface shr-strike-through '((t :strike-through t)) + "Face for <s> elements." + :version "24.1") (defface shr-link - '((t (:inherit link))) - "Font for link elements." - :group 'shr) + '((t :inherit link)) + "Face for link elements." + :version "24.1") + +(defface shr-selected-link + '((t :inherit shr-link :background "red")) + "Temporary face for externally visited link elements. +When a link is visited with an external browser, the link +temporarily blinks with this face." + :version "27.1") + +(defface shr-abbreviation + '((t :inherit underline :underline (:style wave))) + "Face for <abbr> elements." + :version "27.1") (defvar shr-inhibit-images nil "If non-nil, inhibit loading images.") @@ -267,7 +273,9 @@ DOM should be a parse tree as generated by (if (and (null shr-width) (not (shr--have-one-fringe-p))) (* (frame-char-width) 2) - 0))))) + 0) + 1)))) + (max-specpdl-size max-specpdl-size) bidi-display-reordering) ;; If the window was hscrolled for some reason, shr-fill-lines ;; below will misbehave, because it silently assumes that it @@ -344,52 +352,45 @@ If the URL is already at the front of the kill ring act like (shr-probe-and-copy-url url) (shr-copy-url url))) +(defun shr--current-link-region () + (let ((current (get-text-property (point) 'shr-url)) + start) + (save-excursion + ;; Go to the beginning. + (while (and (not (bobp)) + (equal (get-text-property (point) 'shr-url) current)) + (forward-char -1)) + (unless (equal (get-text-property (point) 'shr-url) current) + (forward-char 1)) + (setq start (point)) + ;; Go to the end. + (while (and (not (eobp)) + (equal (get-text-property (point) 'shr-url) current)) + (forward-char 1)) + (list start (point))))) + +(defun shr--blink-link () + (let* ((region (shr--current-link-region)) + (overlay (make-overlay (car region) (cadr region)))) + (overlay-put overlay 'face 'shr-selected-link) + (run-at-time 1 nil (lambda () + (delete-overlay overlay))))) + (defun shr-next-link () "Skip to the next link." (interactive) - (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)))))) + (let ((match (text-property-search-forward 'shr-url nil nil t))) + (if (not match) + (message "No next link") + (goto-char (prop-match-beginning match)) + (message "%s" (get-text-property (point) 'help-echo))))) (defun shr-previous-link () "Skip to the previous link." (interactive) - (let ((start (point)) - (found nil)) - ;; Skip past the current link. - (while (and (not (bobp)) - (get-text-property (point) 'help-echo)) - (forward-char -1)) - ;; Find the previous link. - (while (and (not (bobp)) - (not (setq found (get-text-property (point) 'help-echo)))) - (forward-char -1)) - (if (not found) - (progn - (message "No previous link") - (goto-char start)) - ;; Put point at the start of the link. - (while (and (not (bobp)) - (get-text-property (point) 'help-echo)) - (forward-char -1)) - (forward-char 1) - (message "%s" (get-text-property (point) 'help-echo))))) + (if (not (text-property-search-backward 'shr-url nil nil t)) + (message "No previous link") + (message "%s" (get-text-property (point) 'help-echo)))) (defun shr-show-alt-text () "Show the ALT text of the image under point." @@ -493,15 +494,20 @@ size, and full-buffer size." (shr-depth (1+ shr-depth)) (start (point))) ;; 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'") + (if (and (> shr-depth (/ max-specpdl-size 15)) + (not (and (y-or-n-p "Too deeply nested to render properly; increase `max-specpdl-size'?") + (setq max-specpdl-size (* max-specpdl-size 2))))) + (setq shr-warning + "Not rendering the complete page because of too-deep nesting") (when style (if (string-match "color\\|display\\|border-collapse" style) (setq shr-stylesheet (nconc (shr-parse-style style) shr-stylesheet)) (setq style nil))) ;; If we have a display:none, then just ignore this part of the DOM. - (unless (equal (cdr (assq 'display shr-stylesheet)) "none") + (unless (or (equal (cdr (assq 'display shr-stylesheet)) "none") + (and shr-discard-aria-hidden + (equal (dom-attr dom 'aria-hidden) "true"))) ;; We don't use shr-indirect-call here, since shr-descend is ;; the central bit of shr.el, and should be as fast as ;; possible. Having one more level of indirection with its @@ -689,37 +695,49 @@ size, and full-buffer size." `,(shr-face-background face)))) (setq start (point)) (setq shr-indentation (or continuation shr-indentation)) - (shr-vertical-motion shr-internal-width) - (when (looking-at " $") - (delete-region (point) (line-end-position))) - (while (not (eolp)) - ;; We have to do some folding. First find the first - ;; previous point suitable for folding. - (if (or (not (shr-find-fill-point (line-beginning-position))) - (= (point) start)) - ;; We had unbreakable text (for this width), so just go to - ;; the first space and carry on. - (progn - (beginning-of-line) - (skip-chars-forward " ") - (search-forward " " (line-end-position) 'move))) - ;; Success; continue. - (when (= (preceding-char) ?\s) - (delete-char -1)) - (let ((props `(face ,(get-text-property (point) 'face) - ;; Don't break the image-displayer property - ;; as it will cause `gnus-article-show-images' - ;; to show the two or more same images. - image-displayer - ,(get-text-property (point) 'image-displayer))) - (gap-start (point))) - (insert "\n") - (shr-indent) - (add-text-properties gap-start (point) props)) - (setq start (point)) + ;; If we have an indentation that's wider than the width we're + ;; trying to fill to, then just give up and don't do any filling. + (when (< shr-indentation shr-internal-width) (shr-vertical-motion shr-internal-width) (when (looking-at " $") - (delete-region (point) (line-end-position)))))) + (delete-region (point) (line-end-position))) + (while (not (eolp)) + ;; We have to do some folding. First find the first + ;; previous point suitable for folding. + (if (or (not (shr-find-fill-point (line-beginning-position))) + (= (point) start)) + ;; We had unbreakable text (for this width), so just go to + ;; the first space and carry on. + (progn + (beginning-of-line) + (skip-chars-forward " ") + (search-forward " " (line-end-position) 'move))) + ;; Success; continue. + (when (= (preceding-char) ?\s) + (delete-char -1)) + (let ((gap-start (point))) + (insert "\n") + (shr-indent) + (when (and (> (1- gap-start) (point-min)) + ;; The link on both sides of the newline are the + ;; same... + (equal (get-text-property (point) 'shr-url) + (get-text-property (1- gap-start) 'shr-url))) + ;; ... so we join the two bits into one link logically, but + ;; not visually. This makes navigation between links work + ;; well, but avoids underscores before the link on the next + ;; line when indented. + (let* ((props (copy-sequence (text-properties-at (point)))) + (face (plist-get props 'face))) + ;; We don't want to use the faces on the indentation, because + ;; that's ugly, but we do want to use the background colour. + (when face + (setq props (plist-put props 'face (shr-face-background face)))) + (add-text-properties gap-start (point) props)))) + (setq start (point)) + (shr-vertical-motion shr-internal-width) + (when (looking-at " $") + (delete-region (point) (line-end-position))))))) (defun shr-find-fill-point (start) (let ((bp (point)) @@ -936,7 +954,7 @@ size, and full-buffer size." (defun shr-browse-url (&optional external mouse-event) "Browse the URL at point using `browse-url'. If EXTERNAL is non-nil (interactively, the prefix argument), browse -the URL using `shr-external-browser'. +the URL using `browse-url-secondary-browser-function'. If this function is invoked by a mouse click, it will browse the URL at the position of the click. Optional argument MOUSE-EVENT describes the mouse click event." @@ -950,7 +968,9 @@ the mouse click event." (browse-url-mail url)) (t (if external - (funcall shr-external-browser url) + (progn + (funcall browse-url-secondary-browser-function url) + (shr--blink-link)) (browse-url url)))))) (defun shr-save-contents (directory) @@ -1064,6 +1084,16 @@ element is the data blob and the second element is the content-type." image) (insert (or alt "")))) +(defun shr--image-type () + "Emacs image type to use when displaying images. +If Emacs has native image scaling support, that's used, but if +not, `imagemagick' is preferred if it's present." + (if (or (and (fboundp 'image-transforms-p) + (image-transforms-p)) + (not (fboundp 'imagemagick-types))) + nil + 'imagemagick)) + (defun shr-rescale-image (data content-type width height &optional max-width max-height) "Rescale DATA, if too big, to fit the current buffer. @@ -1072,8 +1102,7 @@ WIDTH and HEIGHT are the sizes given in the HTML data, if any. The size of the displayed image will not exceed MAX-WIDTH/MAX-HEIGHT. If not given, use the current window width/height instead." - (if (or (not (fboundp 'imagemagick-types)) - (not (get-buffer-window (current-buffer)))) + (if (not (get-buffer-window (current-buffer))) (create-image data nil t :ascent 100) (let* ((edges (window-inside-pixel-edges (get-buffer-window (current-buffer)))) @@ -1094,13 +1123,13 @@ width/height instead." (< (* width scaling) max-width) (< (* height scaling) max-height)) (create-image - data 'imagemagick t + data (shr--image-type) t :ascent 100 :width width :height height :format content-type) (create-image - data 'imagemagick t + data (shr--image-type) t :ascent 100 :max-width max-width :max-height max-height @@ -1178,12 +1207,26 @@ START, and END. Note that START and END should be markers." (add-text-properties start (point) (list 'shr-url url - 'help-echo (let ((iri (or (ignore-errors - (decode-coding-string - (url-unhex-string url) - 'utf-8 t)) - url))) - (if title (format "%s (%s)" iri title) iri)) + 'button t + 'category 'shr ; For button.el button buffers. + 'help-echo (let ((parsed (url-generic-parse-url + (or (ignore-errors + (decode-coding-string + (url-unhex-string url) + 'utf-8 t)) + url))) + iri) + ;; If we have an IDNA domain, then show the + ;; decoded version in the mouseover to let the + ;; user know that there's something possibly + ;; fishy. + (when (url-host parsed) + (setf (url-host parsed) + (puny-encode-domain (url-host parsed)))) + (setq iri (url-recreate-url parsed)) + (if title + (format "%s (%s)" iri title) + iri)) 'follow-link t 'mouse-face 'highlight)) ;; Don't overwrite any keymaps that are already in the buffer (i.e., @@ -1319,19 +1362,19 @@ ones, in case fg and bg are nil." (shr-generic dom) (put-text-property start (point) 'display '(raise -0.5)))) -(defun shr-tag-label (dom) - (shr-generic dom) - (shr-ensure-paragraph)) - (defun shr-tag-p (dom) (shr-ensure-paragraph) (shr-generic dom) (shr-ensure-paragraph)) (defun shr-tag-div (dom) - (shr-ensure-newline) - (shr-generic dom) - (shr-ensure-newline)) + (let ((display (cdr (assq 'display shr-stylesheet)))) + (if (or (equal display "inline") + (equal display "inline-block")) + (shr-generic dom) + (shr-ensure-newline) + (shr-generic dom) + (shr-ensure-newline)))) (defun shr-tag-s (dom) (shr-fontize-dom dom 'shr-strike-through)) @@ -1351,10 +1394,14 @@ ones, in case fg and bg are nil." (defun shr-tag-u (dom) (shr-fontize-dom dom 'underline)) -(defun shr-tag-tt (dom) +(defun shr-tag-code (dom) (let ((shr-current-font 'default)) (shr-generic dom))) +(defun shr-tag-tt (dom) + ;; The `tt' tag is deprecated in favor of `code'. + (shr-tag-code dom)) + (defun shr-tag-ins (cont) (let* ((start (point)) (color "green") @@ -1416,6 +1463,21 @@ ones, in case fg and bg are nil." (when url (shr-urlify (or shr-start start) (shr-expand-url url) title)))) +(defun shr-tag-abbr (dom) + (when-let* ((title (dom-attr dom 'title)) + (start (point))) + (shr-generic dom) + (shr-add-font start (point) 'shr-abbreviation) + (add-text-properties + start (point) + (list + 'help-echo title + 'mouse-face 'highlight)))) + +(defun shr-tag-acronym (dom) + ;; `acronym' is deprecated in favor of `abbr'. + (shr-tag-abbr dom)) + (defun shr-tag-object (dom) (unless shr-inhibit-images (let ((start (point)) @@ -1455,7 +1517,6 @@ The key element should be a regexp matched against the type of the source or url if no type is specified. The value should be a float in the range 0.0 to 1.0. Media elements with higher value are preferred." :version "24.4" - :group 'shr :type '(alist :key-type regexp :value-type float)) (defun shr--get-media-pref (elem) @@ -1528,6 +1589,10 @@ The preference is a float determined from `shr-prefer-media-type'." (when (zerop (length alt)) (setq alt "*")) (cond + ((null url) + ;; After further expansion, there turned out to be no valid + ;; src in the img after all. + ) ((or (member (dom-attr dom 'height) '("0" "1")) (member (dom-attr dom 'width) '("0" "1"))) ;; Ignore zero-sized or single-pixel images. @@ -1662,7 +1727,7 @@ The preference is a float determined from `shr-prefer-media-type'." (svg-gradient svg "background" 'linear '((0 . "#b0b0b0") (100 . "#808080"))) (svg-rectangle svg 0 0 width height :gradient "background" :stroke-width 2 :stroke-color "black") - (let ((image (svg-image svg))) + (let ((image (svg-image svg :scale 1))) (setf (image-property image :ascent) 100) image))) @@ -1710,7 +1775,14 @@ The preference is a float determined from `shr-prefer-media-type'." (defun shr-tag-ol (dom) (shr-ensure-paragraph) - (let ((shr-list-mode 1)) + (let* ((attrs (dom-attributes dom)) + (start-attr (alist-get 'start attrs)) + ;; Start at 1 if there is no start attribute + ;; or if start can't be parsed as an integer. + (start-index (condition-case _ + (cl-parse-integer start-attr) + (t 1))) + (shr-list-mode start-index)) (shr-generic dom)) (shr-ensure-paragraph)) @@ -1738,7 +1810,10 @@ The preference is a float determined from `shr-prefer-media-type'." (defun shr-mark-fill (start) ;; We may not have inserted any text to fill. - (unless (= start (point)) + (when (and (/= start (point)) + ;; Tables insert themselves with the correct indentation, + ;; so don't do anything if we're at the start of a table. + (not (get-text-property start 'shr-table-id))) (put-text-property start (1+ start) 'shr-indentation shr-indentation))) @@ -2035,7 +2110,8 @@ flags that control whether to collect or render objects." (setq max (max max (nth 2 column)))) max))) (dotimes (_ (max height 1)) - (shr-indent) + (when (bolp) + (shr-indent)) (insert shr-table-vertical-line "\n")) (dolist (column row) (when (> (nth 2 column) -1) |