;;; shr.el --- Simple HTML Renderer -*- lexical-binding: t -*-
;; Copyright (C) 2010-2018 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen
;; Keywords: html
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see .
;;; Commentary:
;; This package takes a HTML parse tree (as provided by
;; libxml-parse-html-region) and renders it in the current buffer. It
;; does not do CSS, JavaScript or anything advanced: It's geared
;; towards rendering typical short snippets of HTML, like what you'd
;; find in HTML email and the like.
;;; Code:
(require 'cl-lib)
(eval-when-compile (require 'url)) ;For url-filename's setf handler.
(require 'browse-url)
(eval-when-compile (require 'subr-x))
(require 'dom)
(require 'seq)
(require 'svg)
(require 'image)
(require 'puny)
(require 'text-property-search)
(defgroup shr nil
"Simple HTML Renderer"
:version "25.1"
:group 'web)
(defcustom shr-max-image-proportion 0.9
"How big pictures displayed are in relation to the window they're in.
A value of 0.7 means that they are allowed to take up 70% of the
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 nil ; set default value to nil because monospace fonts are better for Emacs
"If non-nil, use proportional fonts for text."
:version "25.1"
:group 'shr
: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
"Frame width to use for rendering.
May either be an integer specifying a fixed width in characters,
or nil, meaning that the full width of the window should be used.
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)
(defcustom shr-bullet "* "
"Bullet used for unordered lists.
Alternative suggestions are:
- \" \"
- \" \""
:version "24.4"
:type 'string
:group 'shr)
(defcustom shr-external-browser 'browse-url-default-browser
"Function used to launch an external browser."
:version "24.4"
:group 'shr
:type 'function)
(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
"If bound, this should be a function that will return the content.
This is used for cid: URLs, and the function is called with the
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))
"Face for elements."
:version "24.1"
:group 'shr)
(defface shr-link
'((t :inherit link))
"Face for link elements."
:version "24.1"
:group 'shr)
(defface shr-selected-link
'((t :inherit shr-link :background "red"))
"Face for link elements."
:version "27.1"
:group 'shr)
(defvar shr-inhibit-images nil
"If non-nil, inhibit loading images.")
(defvar shr-external-rendering-functions nil
"Alist of tag/function pairs used to alter how shr renders certain tags.
For instance, eww uses this to alter rendering of title, forms
and other things:
\((title . eww-tag-title)
(form . eww-tag-form)
...)")
;;; Internal variables.
(defvar shr-folding-mode nil)
(defvar shr-start nil)
(defvar shr-indentation 0)
(defvar shr-internal-width nil)
(defvar shr-list-mode nil)
(defvar shr-content-cache nil)
(defvar shr-kinsoku-shorten nil)
(defvar shr-table-depth 0)
(defvar shr-stylesheet nil)
(defvar shr-base nil)
(defvar shr-depth 0)
(defvar shr-warning nil)
(defvar shr-ignore-cache nil)
(defvar shr-target-id nil)
(defvar shr-table-separator-length 1)
(defvar shr-table-separator-pixel-width 0)
(defvar shr-table-id nil)
(defvar shr-current-font nil)
(defvar shr-internal-bullet nil)
(defvar shr-map
(let ((map (make-sparse-keymap)))
(define-key map "a" 'shr-show-alt-text)
(define-key map "i" 'shr-browse-image)
(define-key map "z" 'shr-zoom-image)
(define-key map [?\t] 'shr-next-link)
(define-key map [?\M-\t] 'shr-previous-link)
(define-key map [follow-link] 'mouse-face)
(define-key map [mouse-2] 'shr-browse-url)
(define-key map "I" 'shr-insert-image)
(define-key map "w" 'shr-maybe-probe-and-copy-url)
(define-key map "u" 'shr-maybe-probe-and-copy-url)
(define-key map "v" 'shr-browse-url)
(define-key map "O" 'shr-save-contents)
(define-key map "\r" 'shr-browse-url)
map))
(defvar shr-image-map
(let ((map (copy-keymap shr-map)))
(when (boundp 'image-map)
(set-keymap-parent map image-map))
map))
;; Public functions and commands.
(declare-function libxml-parse-html-region "xml.c"
(start end &optional base-url discard-comments))
(defun shr-render-buffer (buffer)
"Display the HTML rendering of the current buffer."
(interactive (list (current-buffer)))
(or (fboundp 'libxml-parse-html-region)
(error "This function requires Emacs to be compiled with libxml2"))
(pop-to-buffer "*html*")
(erase-buffer)
(shr-insert-document
(with-current-buffer buffer
(libxml-parse-html-region (point-min) (point-max))))
(goto-char (point-min)))
;;;###autoload
(defun shr-render-region (begin end &optional buffer)
"Display the HTML rendering of the region between BEGIN and END."
(interactive "r")
(unless (fboundp 'libxml-parse-html-region)
(error "This function requires Emacs to be compiled with libxml2"))
(with-current-buffer (or buffer (current-buffer))
(let ((dom (libxml-parse-html-region begin end)))
(delete-region begin end)
(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.
DOM should be a parse tree as generated by
`libxml-parse-html-region' or similar."
(setq shr-content-cache nil)
(let ((start (point))
(shr-start nil)
(shr-base nil)
(shr-depth 0)
(shr-table-id 0)
(shr-warning nil)
(shr-table-separator-pixel-width (shr-string-pixel-width "-"))
(shr-internal-bullet (cons shr-bullet
(shr-string-pixel-width shr-bullet)))
(shr-internal-width (or (and shr-width
(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-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)
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
;; 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-blank-lines-at-the-end start (point))
(when shr-warning
(message "%s" shr-warning))))
(defun shr-fill-paragraph-with-breaks (&optional justify bre-del bre-regexp)
"Fill paragraph at or after point, breaking lines at positions matching regexp argument BRE-REGEXP.
If JUSTIFY is non-nil justify as well.
Delete matched text if BRE-DEL is non nil
BRE-REGEXP must be a regexp that determines positions where to break lines, default value is \\x2028."
(unless bre-regexp (setq bre-regexp "\x2028"))
(setq bre-regexp (concat bre-regexp "\\|\x2029"))
(save-excursion
(let ((line-begin) (paragraph-end))
(forward-paragraph)
(insert "\x2029") ; use \x2029 (unicode paragraph separator) to mark end of a paragraph
(backward-paragraph)
(setq line-begin (point))
(while (not paragraph-end)
(re-search-forward bre-regexp)
(if (equal (match-string 0) "\x2029") (setq paragraph-end t)) ; end of paragraph reached
(if (or bre-del paragraph-end) (replace-match ""))
(unless (equal (char-after) ?\n) (insert "\n")) ; I don't know why but two adjacent \n leave an empty line after fill
(fill-region-as-paragraph line-begin (- (point) 1) justify)
(setq line-begin (point)))
(delete-char -1)
)))
(defun shr-fill-paragraph (dom)
"Fill paragraph"
(when (not shr-use-fonts) ;fill-paragraph is useful only with monospace fonts
(shr-fill-paragraph-with-breaks
((lambda (x)
(cond
((equal x "right") 'right)
((equal x "center") 'center)
((equal x "left") 'left)
))
(cdr (assq 'align (dom-attributes dom)))) ; justify parameter
t) ; bre-del t
)
)
(defun shr--remove-blank-lines-at-the-end (start end)
(save-restriction
(save-excursion
(narrow-to-region start end)
(goto-char end)
(when (and (re-search-backward "[^ \n]" nil t)
(not (eobp)))
(forward-line 1)
(delete-region (point) (point-max))))))
(defun shr-url-at-point (image-url)
"Return the URL under point as a string.
If IMAGE-URL is non-nil, or there is no link under point, but
there is an image under point then copy the URL of the image
under point instead."
(if image-url
(get-text-property (point) 'image-url)
(or (get-text-property (point) 'shr-url)
(get-text-property (point) 'image-url))))
(defun shr-copy-url (url)
"Copy the URL under point to the kill ring.
If IMAGE-URL (the prefix) is non-nil, or there is no link under
point, but there is an image under point then copy the URL of the
image under point instead."
(interactive (list (shr-url-at-point current-prefix-arg)))
(if (not url)
(message "No URL under point")
(setq url (url-encode-url url))
(kill-new url)
(message "Copied %s" url)))
(defun shr-probe-url (url cont)
"Pass URL's redirect destination to CONT, if it has one.
CONT should be a function of one argument, the redirect
destination URL. If URL is not redirected, then CONT is never
called."
(interactive "P")
(url-retrieve
url (lambda (a)
(pcase a
(`(:redirect ,destination . ,_)
;; Remove common tracking junk from the URL.
(funcall cont (replace-regexp-in-string
".utm_.*" "" destination)))))
nil t))
(defun shr-probe-and-copy-url (url)
"Copy the URL under point to the kill ring.
Like `shr-copy-url', but additionally fetch URL and use its
redirection destination if it has one."
(interactive (list (shr-url-at-point current-prefix-arg)))
(if url (shr-probe-url url #'shr-copy-url)
(shr-copy-url url)))
(defun shr-maybe-probe-and-copy-url (url)
"Copy the URL under point to the kill ring.
If the URL is already at the front of the kill ring act like
`shr-probe-and-copy-url', otherwise like `shr-copy-url'."
(interactive (list (shr-url-at-point current-prefix-arg)))
(if (equal url (car kill-ring))
(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 ((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)
(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."
(interactive)
(let ((text (get-text-property (point) 'shr-alt)))
(if (not text)
(message "No image under point")
(message "%s" (shr-fill-text text)))))
(defun shr-browse-image (&optional copy-url)
"Browse the image under point.
If COPY-URL (the prefix if called interactively) is non-nil, copy
the URL of the image to the kill buffer instead."
(interactive "P")
(let ((url (get-text-property (point) 'image-url)))
(cond
((not url)
(message "No image under point"))
(copy-url
(with-temp-buffer
(insert url)
(copy-region-as-kill (point-min) (point-max))
(message "Copied %s" url)))
(t
(message "Browsing %s..." url)
(browse-url url)))))
(defun shr-insert-image ()
"Insert the image under point into the buffer."
(interactive)
(let ((url (get-text-property (point) 'image-url)))
(if (not url)
(message "No image under point")
(message "Inserting %s..." url)
(url-retrieve url 'shr-image-fetched
(list (current-buffer) (1- (point)) (point-marker))
t t))))
(defun shr-zoom-image ()
"Toggle the image size.
The size will be rotated between the default size, the original
size, and full-buffer size."
(interactive)
(let ((url (get-text-property (point) 'image-url))
(size (get-text-property (point) 'image-size))
(buffer-read-only nil))
(if (not url)
(message "No image under point")
;; Delete the old picture.
(while (get-text-property (point) 'image-url)
(forward-char -1))
(forward-char 1)
(let ((start (point)))
(while (get-text-property (point) 'image-url)
(forward-char 1))
(forward-char -1)
(put-text-property start (point) 'display nil)
(when (> (- (point) start) 2)
(delete-region start (1- (point)))))
(message "Inserting %s..." url)
(url-retrieve url 'shr-image-fetched
(list (current-buffer) (1- (point)) (point-marker)
(list (cons 'size
(cond ((or (eq size 'default)
(null size))
'original)
((eq size 'original)
'full)
((eq size 'full)
'default)))))
t))))
;;; Utility functions.
(defsubst shr-generic (dom)
(dolist (sub (dom-children dom))
(if (stringp sub)
(shr-insert sub)
(shr-descend sub))))
(defun shr-indirect-call (tag-name dom &rest args)
(let ((function (intern (concat "shr-tag-" (symbol-name tag-name)) obarray))
;; Allow other packages to override (or provide) rendering
;; of elements.
(external (cdr (assq tag-name shr-external-rendering-functions))))
(cond (external
(apply external dom args))
((fboundp function)
(apply function dom args))
(t
(apply 'shr-generic dom args)))))
(defun shr-descend (dom)
(let ((function
(intern (concat "shr-tag-" (symbol-name (dom-tag dom))) obarray))
;; Allow other packages to override (or provide) rendering
;; of elements.
(external (cdr (assq (dom-tag dom) shr-external-rendering-functions)))
(style (dom-attr dom 'style))
(shr-stylesheet shr-stylesheet)
(shr-depth (1+ shr-depth))
(start (point)))
;; shr uses many frames per nested node.
(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")
;; 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
;; negative effect on performance is deemed unjustified in
;; this case.
(cond (external
(funcall external dom))
((fboundp function)
(funcall function dom))
(t
(shr-generic dom)))
(when (and shr-target-id
(equal (dom-attr dom 'id) shr-target-id))
;; If the element was empty, we don't have anything to put the
;; anchor on. So just insert a dummy character.
(when (= start (point))
(insert "*"))
(put-text-property start (1+ start) 'shr-target-id shr-target-id))
;; If style is set, then this node has set the color.
(when style
(shr-colorize-region
start (point)
(cdr (assq 'color shr-stylesheet))
(cdr (assq 'background-color shr-stylesheet))))))))
(defun shr-fill-text (text)
(if (zerop (length text))
text
(with-temp-buffer
(let ((shr-indentation 0)
(shr-start nil)
(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)
(shr-fill-lines (point-min) (point-max))
(buffer-string)))))
(define-inline shr-char-breakable-p (char)
"Return non-nil if a line can be broken before and after CHAR."
(inline-quote (aref fill-find-break-point-function-table ,char)))
(define-inline shr-char-nospace-p (char)
"Return non-nil if no space is required before and after CHAR."
(inline-quote (aref fill-nospace-between-words-table ,char)))
;; KINSOKU is a Japanese word meaning a rule that should not be violated.
;; In Emacs, it is a term used for characters, e.g. punctuation marks,
;; parentheses, and so on, that should not be placed in the beginning
;; of a line or the end of a line.
(define-inline shr-char-kinsoku-bol-p (char)
"Return non-nil if a line ought not to begin with CHAR."
(inline-letevals (char)
(inline-quote (and (not (eq ,char ?'))
(aref (char-category-set ,char) ?>)))))
(define-inline shr-char-kinsoku-eol-p (char)
"Return non-nil if a line ought not to end with CHAR."
(inline-quote (aref (char-category-set ,char) ?<)))
(unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35))
(load "kinsoku" nil t))
(defun shr-pixel-column ()
(if (not shr-use-fonts)
(current-column)
(if (not (get-buffer-window (current-buffer)))
(save-window-excursion
;; Avoid errors if the selected window is a dedicated one,
;; and they just want to insert a document into it.
(set-window-dedicated-p nil nil)
(set-window-buffer nil (current-buffer))
(car (window-text-pixel-size nil (line-beginning-position) (point))))
(car (window-text-pixel-size nil (line-beginning-position) (point))))))
(defun shr-pixel-region ()
(- (shr-pixel-column)
(save-excursion
(goto-char (mark))
(shr-pixel-column))))
(defun shr-string-pixel-width (string)
(if (not shr-use-fonts)
(length string)
;; Save and restore point across with-temp-buffer, since
;; shr-pixel-column uses save-window-excursion, which can reset
;; point to 1.
(let ((pt (point)))
(prog1
(with-temp-buffer
(insert string)
(shr-pixel-column))
(goto-char pt)))))
(defsubst shr--translate-insertion-chars ()
;; Remove soft hyphens.
(goto-char (point-min))
(while (search-forward "Â" nil t)
(replace-match "" t t))
;; Translate non-breaking spaces into real spaces.
(goto-char (point-min))
(while (search-forward "Â " nil t)
(replace-match " " t t)))
(defun shr-insert (text)
(when (and (not (bolp))
(get-text-property (1- (point)) 'image-url))
(insert "\n"))
(cond
((eq shr-folding-mode 'none)
(let ((start (point)))
(insert text)
(save-restriction
(narrow-to-region start (point))
(shr--translate-insertion-chars)
(goto-char (point-max)))))
(t
(let ((font-start (point)))
(when (and (string-match "\\`[ \t\n\r]" text)
(not (bolp))
(not (eq (char-after (1- (point))) ? )))
(insert " "))
(let ((start (point))
(bolp (bolp)))
(insert text)
(save-restriction
(narrow-to-region start (point))
(goto-char start)
(when (looking-at "[ \t\n\r]+")
(replace-match "" t t))
(while (re-search-forward "[ \t\n\r]+" nil t)
(replace-match " " t t))
(shr--translate-insertion-chars)
(goto-char (point-max)))
;; We may have removed everything we inserted if it was just
;; spaces.
(unless (= font-start (point))
;; Mark all lines that should possibly be folded afterwards.
(when bolp
(shr-mark-fill start))
(when shr-use-fonts
(put-text-property font-start (point)
'face
(or shr-current-font 'variable-pitch)))))))))
(defun shr-fill-lines (start end)
(if (<= shr-internal-width 0)
nil
(save-restriction
(narrow-to-region start end)
(goto-char start)
(when (get-text-property (point) 'shr-indentation)
(shr-fill-line))
(while (setq start (next-single-property-change start 'shr-indentation))
(goto-char start)
(when (bolp)
(shr-fill-line)))
(goto-char (point-max)))))
(defun shr-vertical-motion (column)
(if (not shr-use-fonts)
(move-to-column column)
(unless (eolp)
(forward-char 1))
(vertical-motion (cons (/ column (frame-char-width)) 0))
(unless (eolp)
(forward-char 1))))
(defun shr-fill-line ()
(let ((shr-indentation (get-text-property (point) 'shr-indentation))
(continuation (get-text-property
(point) 'shr-continuation-indentation))
start)
(put-text-property (point) (1+ (point)) 'shr-indentation nil)
(let ((face (get-text-property (point) 'face))
(background-start (point)))
(shr-indent)
(when face
(put-text-property background-start (point) 'face
`,(shr-face-background face))))
(setq start (point))
(setq shr-indentation (or continuation shr-indentation))
;; 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)))
(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)))))
;; We don't want to use the faces on the indentation, because
;; that's ugly.
(setq props (plist-put props 'face nil))
(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))
(end (point))
failed)
(while (not (or (setq failed (<= (point) start))
(eq (preceding-char) ? )
(eq (following-char) ? )
(shr-char-breakable-p (preceding-char))
(shr-char-breakable-p (following-char))
(and (shr-char-kinsoku-bol-p (preceding-char))
(shr-char-breakable-p (following-char))
(not (shr-char-kinsoku-bol-p (following-char))))
(shr-char-kinsoku-eol-p (following-char))
(bolp)))
(backward-char 1))
(if failed
;; There's no breakable point, so we give it up.
(let (found)
(goto-char bp)
;; 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)))
(if (and found
(not (match-beginning 1)))
(goto-char (match-beginning 0)))))
(or
(eolp)
;; Don't put kinsoku-bol characters at the beginning of a line,
;; or kinsoku-eol characters at the end of a line.
(cond
;; 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 ? )))
(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,
;; so we look for the second best position.
(while (and (progn
(forward-char 1)
(<= (point) end))
(progn
(setq bp (point))
(shr-char-kinsoku-eol-p (following-char)))))
(goto-char bp)))
((shr-char-kinsoku-eol-p (preceding-char))
;; Find backward the point where kinsoku-eol characters begin.
(let ((count 4))
(while
(progn
(backward-char 1)
(and (> (setq count (1- count)) 0)
(not (memq (preceding-char) (list ?\C-@ ?\n ? )))
(or (shr-char-kinsoku-eol-p (preceding-char))
(shr-char-kinsoku-bol-p (following-char)))))))
(when (setq failed (<= (point) start))
;; There's no breakable point that doesn't violate kinsoku,
;; so we go to the second best position.
(if (looking-at "\\(\\c<+\\)\\c<")
(goto-char (match-end 1))
(forward-char 1))))
((shr-char-kinsoku-bol-p (following-char))
;; Find forward the point where kinsoku-bol characters end.
(let ((count 4))
(while (progn
(forward-char 1)
(and (>= (setq count (1- count)) 0)
(shr-char-kinsoku-bol-p (following-char))
(shr-char-breakable-p (following-char))))))))
(when (eq (following-char) ? )
(forward-char 1))))
(not failed)))
(defun shr-parse-base (url)
;; Always chop off anchors.
(when (string-match "#.*" url)
(setq url (substring url 0 (match-beginning 0))))
;; NB: URI may itself be relative to the document s URI
(setq url (shr-expand-url url))
(let* ((parsed (url-generic-parse-url url))
(local (url-filename parsed)))
(setf (url-filename parsed) "")
;; Chop off the bit after the last slash.
(when (string-match "\\`\\(.*/\\)[^/]+\\'" local)
(setq local (match-string 1 local)))
;; Always make the local bit end with a slash.
(when (and (not (zerop (length local)))
(not (eq (aref local (1- (length local))) ?/)))
(setq local (concat local "/")))
(list (url-recreate-url parsed)
local
(url-type parsed)
url)))
(autoload 'url-expand-file-name "url-expand")
;; FIXME This needs some tests writing.
;; Does it even need to exist, given that url-expand-file-name does?
(defun shr-expand-url (url &optional base)
(setq base
(if base
;; shr-parse-base should never call this with non-nil base!
(shr-parse-base base)
;; Bound by the parser.
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 ((zerop (length url))
(nth 3 base))
((or (not base)
(string-match "\\`[a-z]*:" url))
;; Absolute or empty URI
url)
((eq (aref url 0) ?/)
(if (and (> (length url) 1)
(eq (aref url 1) ?/))
;; //host...; just use the protocol
(concat (nth 2 base) ":" url)
;; Just use the host name part.
(concat (car base) url)))
((eq (aref url 0) ?#)
;; A link to an anchor.
(concat (nth 3 base) url))
(t
;; Totally relative.
(url-expand-file-name url (concat (car base) (cadr base))))))
(defun shr-ensure-newline ()
(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)
(let ((prefix (get-text-property (line-beginning-position)
'shr-prefix-length)))
(cond
((and (bolp)
(save-excursion
(forward-line -1)
(looking-at " *$")))
;; We're already at a new paragraph; do nothing.
)
((and prefix
(= prefix (- (point) (line-beginning-position))))
;; Do nothing; we're at the start of a