code.delx.au - gnu-emacs/blob - lisp/net/shr.el

   1 ;;; shr.el --- Simple HTML Renderer
   2
   3 ;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: html
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This package takes a HTML parse tree (as provided by
  26 ;; libxml-parse-html-region) and renders it in the current buffer.  It
  27 ;; does not do CSS, JavaScript or anything advanced: It's geared
  28 ;; towards rendering typical short snippets of HTML, like what you'd
  29 ;; find in HTML email and the like.
  30
  31 ;;; Code:
  32
  33 (eval-when-compile (require 'cl))
  34 (eval-when-compile (require 'url))      ;For url-filename's setf handler.
  35 (require 'browse-url)
  36 (require 'subr-x)
  37 (require 'dom)
  38 (require 'seq)
  39 (require 'svg)
  40
  41 (defgroup shr nil
  42   "Simple HTML Renderer"
  43   :version "25.1"
  44   :group 'web)
  45
  46 (defcustom shr-max-image-proportion 0.9
  47   "How big pictures displayed are in relation to the window they're in.
  48 A value of 0.7 means that they are allowed to take up 70% of the
  49 width and height of the window.  If they are larger than this,
  50 and Emacs supports it, then the images will be rescaled down to
  51 fit these criteria."
  52   :version "24.1"
  53   :group 'shr
  54   :type 'float)
  55
  56 (defcustom shr-blocked-images nil
  57   "Images that have URLs matching this regexp will be blocked."
  58   :version "24.1"
  59   :group 'shr
  60   :type '(choice (const nil) regexp))
  61
  62 (defcustom shr-use-fonts t
  63   "If non-nil, use proportional fonts for text."
  64   :version "25.1"
  65   :group 'shr
  66   :type 'boolean)
  67
  68 (defcustom shr-use-colors t
  69   "If non-nil, respect color specifications in the HTML."
  70   :version "25.2"
  71   :group 'shr
  72   :type 'boolean)
  73
  74 (defcustom shr-table-horizontal-line nil
  75   "Character used to draw horizontal table lines.
  76 If nil, don't draw horizontal table lines."
  77   :group 'shr
  78   :type '(choice (const nil) character))
  79
  80 (defcustom shr-table-vertical-line ?\s
  81   "Character used to draw vertical table lines."
  82   :group 'shr
  83   :type 'character)
  84
  85 (defcustom shr-table-corner ?\s
  86   "Character used to draw table corners."
  87   :group 'shr
  88   :type 'character)
  89
  90 (defcustom shr-hr-line ?-
  91   "Character used to draw hr lines."
  92   :group 'shr
  93   :type 'character)
  94
  95 (defcustom shr-width nil
  96   "Frame width to use for rendering.
  97 May either be an integer specifying a fixed width in characters,
  98 or nil, meaning that the full width of the window should be
  99 used."
 100   :version "25.1"
 101   :type '(choice (integer :tag "Fixed width in characters")
 102                  (const   :tag "Use the width of the window" nil))
 103   :group 'shr)
 104
 105 (defcustom shr-bullet "* "
 106   "Bullet used for unordered lists.
 107 Alternative suggestions are:
 108 - \"  \"
 109 - \"  \""
 110   :version "24.4"
 111   :type 'string
 112   :group 'shr)
 113
 114 (defcustom shr-external-browser 'browse-url-default-browser
 115   "Function used to launch an external browser."
 116   :version "24.4"
 117   :group 'shr
 118   :type 'function)
 119
 120 (defcustom shr-image-animate t
 121   "Non nil means that images that can be animated will be."
 122   :version "24.4"
 123   :group 'shr
 124   :type 'boolean)
 125
 126 (defvar shr-content-function nil
 127   "If bound, this should be a function that will return the content.
 128 This is used for cid: URLs, and the function is called with the
 129 cid: URL as the argument.")
 130
 131 (defvar shr-put-image-function 'shr-put-image
 132   "Function called to put image and alt string.")
 133
 134 (defface shr-strike-through '((t (:strike-through t)))
 135   "Font for <s> elements."
 136   :group 'shr)
 137
 138 (defface shr-link
 139   '((t (:inherit link)))
 140   "Font for link elements."
 141   :group 'shr)
 142
 143 (defvar shr-inhibit-images nil
 144   "If non-nil, inhibit loading images.")
 145
 146 (defvar shr-external-rendering-functions nil
 147   "Alist of tag/function pairs used to alter how shr renders certain tags.
 148 For instance, eww uses this to alter rendering of title, forms
 149 and other things:
 150 ((title . eww-tag-title)
 151  (form . eww-tag-form)
 152  ...)")
 153
 154 ;;; Internal variables.
 155
 156 (defvar shr-folding-mode nil)
 157 (defvar shr-start nil)
 158 (defvar shr-indentation 0)
 159 (defvar shr-internal-width nil)
 160 (defvar shr-list-mode nil)
 161 (defvar shr-content-cache nil)
 162 (defvar shr-kinsoku-shorten nil)
 163 (defvar shr-table-depth 0)
 164 (defvar shr-stylesheet nil)
 165 (defvar shr-base nil)
 166 (defvar shr-depth 0)
 167 (defvar shr-warning nil)
 168 (defvar shr-ignore-cache nil)
 169 (defvar shr-target-id nil)
 170 (defvar shr-table-separator-length 1)
 171 (defvar shr-table-separator-pixel-width 0)
 172 (defvar shr-table-id nil)
 173 (defvar shr-current-font nil)
 174 (defvar shr-internal-bullet nil)
 175
 176 (defvar shr-map
 177   (let ((map (make-sparse-keymap)))
 178     (define-key map "a" 'shr-show-alt-text)
 179     (define-key map "i" 'shr-browse-image)
 180     (define-key map "z" 'shr-zoom-image)
 181     (define-key map [?\t] 'shr-next-link)
 182     (define-key map [?\M-\t] 'shr-previous-link)
 183     (define-key map [follow-link] 'mouse-face)
 184     (define-key map [mouse-2] 'shr-browse-url)
 185     (define-key map "I" 'shr-insert-image)
 186     (define-key map "w" 'shr-copy-url)
 187     (define-key map "u" 'shr-copy-url)
 188     (define-key map "v" 'shr-browse-url)
 189     (define-key map "O" 'shr-save-contents)
 190     (define-key map "\r" 'shr-browse-url)
 191     map))
 192
 193 (defvar shr-image-map
 194   (let ((map (copy-keymap shr-map)))
 195     (when (boundp 'image-map)
 196       (set-keymap-parent map image-map))
 197     map))
 198
 199 ;; Public functions and commands.
 200 (declare-function libxml-parse-html-region "xml.c"
 201                   (start end &optional base-url discard-comments))
 202
 203 (defun shr-render-buffer (buffer)
 204   "Display the HTML rendering of the current buffer."
 205   (interactive (list (current-buffer)))
 206   (or (fboundp 'libxml-parse-html-region)
 207       (error "This function requires Emacs to be compiled with libxml2"))
 208   (pop-to-buffer "*html*")
 209   (erase-buffer)
 210   (shr-insert-document
 211    (with-current-buffer buffer
 212      (libxml-parse-html-region (point-min) (point-max))))
 213   (goto-char (point-min)))
 214
 215 ;;;###autoload
 216 (defun shr-render-region (begin end &optional buffer)
 217   "Display the HTML rendering of the region between BEGIN and END."
 218   (interactive "r")
 219   (unless (fboundp 'libxml-parse-html-region)
 220     (error "This function requires Emacs to be compiled with libxml2"))
 221   (with-current-buffer (or buffer (current-buffer))
 222     (let ((dom (libxml-parse-html-region begin end)))
 223       (delete-region begin end)
 224       (goto-char begin)
 225       (shr-insert-document dom))))
 226
 227 (defun shr--have-one-fringe-p ()
 228   "Return non-nil if we know at least one of the fringes has non-zero width."
 229   (and (fboundp 'fringe-columns)
 230        (or (not (zerop (fringe-columns 'right)))
 231            (not (zerop (fringe-columns 'left))))))
 232
 233 ;;;###autoload
 234 (defun shr-insert-document (dom)
 235   "Render the parsed document DOM into the current buffer.
 236 DOM should be a parse tree as generated by
 237 `libxml-parse-html-region' or similar."
 238   (setq shr-content-cache nil)
 239   (let ((start (point))
 240         (shr-start nil)
 241         (shr-base nil)
 242         (shr-depth 0)
 243         (shr-table-id 0)
 244         (shr-warning nil)
 245         (shr-table-separator-pixel-width (shr-string-pixel-width "-"))
 246         (shr-internal-bullet (cons shr-bullet
 247                                    (shr-string-pixel-width shr-bullet)))
 248         (shr-internal-width (or (and shr-width
 249                                      (if (not shr-use-fonts)
 250                                          shr-width
 251                                        (* shr-width (frame-char-width))))
 252                                 ;; We need to adjust the available
 253                                 ;; width for when the user disables
 254                                 ;; the fringes, which will cause the
 255                                 ;; display engine usurp one column for
 256                                 ;; the continuation glyph.
 257                                 (if (not shr-use-fonts)
 258                                     (- (window-body-width) 1
 259                                        (if (and (null shr-width)
 260                                                 (not (shr--have-one-fringe-p)))
 261                                            0
 262                                          1))
 263                                   (- (window-body-width nil t)
 264                                      (* 2 (frame-char-width))
 265                                      (if (and (null shr-width)
 266                                               (not (shr--have-one-fringe-p)))
 267                                          (* (frame-char-width) 2)
 268                                        0)))))
 269         bidi-display-reordering)
 270     ;; If the window was hscrolled for some reason, shr-fill-lines
 271     ;; below will misbehave, because it silently assumes that it
 272     ;; starts with a non-hscrolled window (vertical-motion will move
 273     ;; to a wrong place otherwise).
 274     (set-window-hscroll nil 0)
 275     (shr-descend dom)
 276     (shr-fill-lines start (point))
 277     (shr-remove-trailing-whitespace start (point))
 278     (when shr-warning
 279       (message "%s" shr-warning))))
 280
 281 (defun shr-remove-trailing-whitespace (start end)
 282   (let ((width (window-width)))
 283     (save-restriction
 284       (narrow-to-region start end)
 285       (goto-char start)
 286       (while (not (eobp))
 287         (end-of-line)
 288         (when (> (shr-previous-newline-padding-width (current-column)) width)
 289           (dolist (overlay (overlays-at (point)))
 290             (when (overlay-get overlay 'before-string)
 291               (overlay-put overlay 'before-string nil))))
 292         (forward-line 1)))))
 293
 294 (defun shr-copy-url (&optional image-url)
 295   "Copy the URL under point to the kill ring.
 296 If IMAGE-URL (the prefix) is non-nil, or there is no link under
 297 point, but there is an image under point then copy the URL of the
 298 image under point instead.
 299 If called twice, then try to fetch the URL and see whether it
 300 redirects somewhere else."
 301   (interactive "P")
 302   (let ((url (or (get-text-property (point) 'shr-url)
 303                  (get-text-property (point) 'image-url))))
 304     (cond
 305      ((not url)
 306       (message "No URL under point"))
 307      ;; Resolve redirected URLs.
 308      ((equal url (car kill-ring))
 309       (url-retrieve
 310        url
 311        (lambda (a)
 312          (when (and (consp a)
 313                     (eq (car a) :redirect))
 314            (with-temp-buffer
 315              (insert (cadr a))
 316              (goto-char (point-min))
 317              ;; Remove common tracking junk from the URL.
 318              (when (re-search-forward ".utm_.*" nil t)
 319                (replace-match "" t t))
 320              (message "Copied %s" (buffer-string))
 321              (copy-region-as-kill (point-min) (point-max)))))
 322        nil t))
 323      ;; Copy the URL to the kill ring.
 324      (t
 325       (with-temp-buffer
 326         (insert (url-encode-url url))
 327         (copy-region-as-kill (point-min) (point-max))
 328         (message "Copied %s" (buffer-string)))))))
 329
 330 (defun shr-next-link ()
 331   "Skip to the next link."
 332   (interactive)
 333   (let ((current (get-text-property (point) 'shr-url))
 334         (start (point))
 335         skip)
 336     (while (and (not (eobp))
 337                 (equal (get-text-property (point) 'shr-url) current))
 338       (forward-char 1))
 339     (cond
 340      ((and (not (eobp))
 341            (get-text-property (point) 'shr-url))
 342       ;; The next link is adjacent.
 343       (message "%s" (get-text-property (point) 'help-echo)))
 344      ((or (eobp)
 345           (not (setq skip (text-property-not-all (point) (point-max)
 346                                                  'shr-url nil))))
 347       (goto-char start)
 348       (message "No next link"))
 349      (t
 350       (goto-char skip)
 351       (message "%s" (get-text-property (point) 'help-echo))))))
 352
 353 (defun shr-previous-link ()
 354   "Skip to the previous link."
 355   (interactive)
 356   (let ((start (point))
 357         (found nil))
 358     ;; Skip past the current link.
 359     (while (and (not (bobp))
 360                 (get-text-property (point) 'help-echo))
 361       (forward-char -1))
 362     ;; Find the previous link.
 363     (while (and (not (bobp))
 364                 (not (setq found (get-text-property (point) 'help-echo))))
 365       (forward-char -1))
 366     (if (not found)
 367         (progn
 368           (message "No previous link")
 369           (goto-char start))
 370       ;; Put point at the start of the link.
 371       (while (and (not (bobp))
 372                   (get-text-property (point) 'help-echo))
 373         (forward-char -1))
 374       (forward-char 1)
 375       (message "%s" (get-text-property (point) 'help-echo)))))
 376
 377 (defun shr-show-alt-text ()
 378   "Show the ALT text of the image under point."
 379   (interactive)
 380   (let ((text (get-text-property (point) 'shr-alt)))
 381     (if (not text)
 382         (message "No image under point")
 383       (message "%s" (shr-fill-text text)))))
 384
 385 (defun shr-browse-image (&optional copy-url)
 386   "Browse the image under point.
 387 If COPY-URL (the prefix if called interactively) is non-nil, copy
 388 the URL of the image to the kill buffer instead."
 389   (interactive "P")
 390   (let ((url (get-text-property (point) 'image-url)))
 391     (cond
 392      ((not url)
 393       (message "No image under point"))
 394      (copy-url
 395       (with-temp-buffer
 396         (insert url)
 397         (copy-region-as-kill (point-min) (point-max))
 398         (message "Copied %s" url)))
 399      (t
 400       (message "Browsing %s..." url)
 401       (browse-url url)))))
 402
 403 (defun shr-insert-image ()
 404   "Insert the image under point into the buffer."
 405   (interactive)
 406   (let ((url (get-text-property (point) 'image-url)))
 407     (if (not url)
 408         (message "No image under point")
 409       (message "Inserting %s..." url)
 410       (url-retrieve url 'shr-image-fetched
 411                     (list (current-buffer) (1- (point)) (point-marker))
 412                     t t))))
 413
 414 (defun shr-zoom-image ()
 415   "Toggle the image size.
 416 The size will be rotated between the default size, the original
 417 size, and full-buffer size."
 418   (interactive)
 419   (let ((url (get-text-property (point) 'image-url))
 420         (size (get-text-property (point) 'image-size))
 421         (buffer-read-only nil))
 422     (if (not url)
 423         (message "No image under point")
 424       ;; Delete the old picture.
 425       (while (get-text-property (point) 'image-url)
 426         (forward-char -1))
 427       (forward-char 1)
 428       (let ((start (point)))
 429         (while (get-text-property (point) 'image-url)
 430           (forward-char 1))
 431         (forward-char -1)
 432         (put-text-property start (point) 'display nil)
 433         (when (> (- (point) start) 2)
 434           (delete-region start (1- (point)))))
 435       (message "Inserting %s..." url)
 436       (url-retrieve url 'shr-image-fetched
 437                     (list (current-buffer) (1- (point)) (point-marker)
 438                           (list (cons 'size
 439                                       (cond ((or (eq size 'default)
 440                                                  (null size))
 441                                              'original)
 442                                             ((eq size 'original)
 443                                              'full)
 444                                             ((eq size 'full)
 445                                              'default)))))
 446                     t))))
 447
 448 ;;; Utility functions.
 449
 450 (defsubst shr-generic (dom)
 451   (dolist (sub (dom-children dom))
 452     (if (stringp sub)
 453         (shr-insert sub)
 454       (shr-descend sub))))
 455
 456 (defun shr-descend (dom)
 457   (let ((function
 458          (intern (concat "shr-tag-" (symbol-name (dom-tag dom))) obarray))
 459         ;; Allow other packages to override (or provide) rendering
 460         ;; of elements.
 461         (external (cdr (assq (dom-tag dom) shr-external-rendering-functions)))
 462         (style (dom-attr dom 'style))
 463         (shr-stylesheet shr-stylesheet)
 464         (shr-depth (1+ shr-depth))
 465         (start (point)))
 466     ;; shr uses many frames per nested node.
 467     (if (> shr-depth (/ max-specpdl-size 15))
 468         (setq shr-warning "Too deeply nested to render properly; consider increasing `max-specpdl-size'")
 469       (when style
 470         (if (string-match "color\\|display\\|border-collapse" style)
 471             (setq shr-stylesheet (nconc (shr-parse-style style)
 472                                         shr-stylesheet))
 473           (setq style nil)))
 474       ;; If we have a display:none, then just ignore this part of the DOM.
 475       (unless (equal (cdr (assq 'display shr-stylesheet)) "none")
 476         (cond (external
 477                (funcall external dom))
 478               ((fboundp function)
 479                (funcall function dom))
 480               (t
 481                (shr-generic dom)))
 482         (when (and shr-target-id
 483                    (equal (dom-attr dom 'id) shr-target-id))
 484           ;; If the element was empty, we don't have anything to put the
 485           ;; anchor on.  So just insert a dummy character.
 486           (when (= start (point))
 487             (insert "*"))
 488           (put-text-property start (1+ start) 'shr-target-id shr-target-id))
 489         ;; If style is set, then this node has set the color.
 490         (when style
 491           (shr-colorize-region
 492            start (point)
 493            (cdr (assq 'color shr-stylesheet))
 494            (cdr (assq 'background-color shr-stylesheet))))))))
 495
 496 (defun shr-fill-text (text)
 497   (if (zerop (length text))
 498       text
 499     (with-temp-buffer
 500       (let ((shr-indentation 0)
 501             (shr-start nil)
 502             (shr-internal-width (- (window-body-width nil t)
 503                                    (* 2 (frame-char-width))
 504                                    ;; Adjust the window width for when
 505                                    ;; the user disables the fringes,
 506                                    ;; which causes the display engine
 507                                    ;; to usurp one column for the
 508                                    ;; continuation glyph.
 509                                    (if (and (null shr-width)
 510                                             (not (shr--have-one-fringe-p)))
 511                                        (* (frame-char-width) 2)
 512                                      0))))
 513         (shr-insert text)
 514         (buffer-string)))))
 515
 516 (define-inline shr-char-breakable-p (char)
 517   "Return non-nil if a line can be broken before and after CHAR."
 518   (inline-quote (aref fill-find-break-point-function-table ,char)))
 519 (define-inline shr-char-nospace-p (char)
 520   "Return non-nil if no space is required before and after CHAR."
 521   (inline-quote (aref fill-nospace-between-words-table ,char)))
 522
 523 ;; KINSOKU is a Japanese word meaning a rule that should not be violated.
 524 ;; In Emacs, it is a term used for characters, e.g. punctuation marks,
 525 ;; parentheses, and so on, that should not be placed in the beginning
 526 ;; of a line or the end of a line.
 527 (define-inline shr-char-kinsoku-bol-p (char)
 528   "Return non-nil if a line ought not to begin with CHAR."
 529   (inline-letevals (char)
 530     (inline-quote (and (not (eq ,char ?'))
 531                        (aref (char-category-set ,char) ?>)))))
 532 (define-inline shr-char-kinsoku-eol-p (char)
 533   "Return non-nil if a line ought not to end with CHAR."
 534   (inline-quote (aref (char-category-set ,char) ?<)))
 535 (unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35))
 536   (load "kinsoku" nil t))
 537
 538 (defun shr-pixel-column ()
 539   (if (not shr-use-fonts)
 540       (current-column)
 541     (if (not (get-buffer-window (current-buffer)))
 542         (save-window-excursion
 543           (set-window-buffer nil (current-buffer))
 544           (car (window-text-pixel-size nil (line-beginning-position) (point))))
 545       (car (window-text-pixel-size nil (line-beginning-position) (point))))))
 546
 547 (defun shr-pixel-region ()
 548   (- (shr-pixel-column)
 549      (save-excursion
 550        (goto-char (mark))
 551        (shr-pixel-column))))
 552
 553 (defun shr-string-pixel-width (string)
 554   (if (not shr-use-fonts)
 555       (length string)
 556     (with-temp-buffer
 557       (insert string)
 558       (shr-pixel-column))))
 559
 560 (defun shr-insert (text)
 561   (when (and (not (bolp))
 562              (get-text-property (1- (point)) 'image-url))
 563     (insert "\n"))
 564   (cond
 565    ((eq shr-folding-mode 'none)
 566     (let ((start (point)))
 567       (insert text)
 568       (save-restriction
 569         (narrow-to-region start (point))
 570         ;; Remove soft hyphens.
 571         (goto-char (point-min))
 572         (while (search-forward "" nil t)
 573           (replace-match "" t t))
 574         (goto-char (point-max)))))
 575    (t
 576     (let ((font-start (point)))
 577       (when (and (string-match "\\`[ \t\n\r ]" text)
 578                  (not (bolp))
 579                  (not (eq (char-after (1- (point))) ? )))
 580         (insert " "))
 581       (let ((start (point))
 582             (bolp (bolp)))
 583         (insert text)
 584         (save-restriction
 585           (narrow-to-region start (point))
 586           (goto-char start)
 587           (when (looking-at "[ \t\n\r ]+")
 588             (replace-match "" t t))
 589           (while (re-search-forward "[ \t\n\r ]+" nil t)
 590             (replace-match " " t t))
 591           ;; Remove soft hyphens.
 592           (goto-char (point-min))
 593           (while (search-forward "" nil t)
 594             (replace-match "" t t))
 595           (goto-char (point-max)))
 596         ;; We may have removed everything we inserted if if was just
 597         ;; spaces.
 598         (unless (= font-start (point))
 599           ;; Mark all lines that should possibly be folded afterwards.
 600           (when bolp
 601             (shr-mark-fill start))
 602           (when shr-use-fonts
 603             (put-text-property font-start (point)
 604                                'face
 605                                (or shr-current-font 'variable-pitch)))))))))
 606
 607 (defun shr-fill-lines (start end)
 608   (if (<= shr-internal-width 0)
 609       nil
 610     (save-restriction
 611       (narrow-to-region start end)
 612       (goto-char start)
 613       (when (get-text-property (point) 'shr-indentation)
 614         (shr-fill-line))
 615       (while (setq start (next-single-property-change start 'shr-indentation))
 616         (goto-char start)
 617         (when (bolp)
 618           (shr-fill-line)))
 619       (goto-char (point-max)))))
 620
 621 (defun shr-vertical-motion (column)
 622   (if (not shr-use-fonts)
 623       (move-to-column column)
 624     (unless (eolp)
 625       (forward-char 1))
 626     (vertical-motion (cons (/ column (frame-char-width)) 0))
 627     (unless (eolp)
 628       (forward-char 1))))
 629
 630 (defun shr-fill-line ()
 631   (let ((shr-indentation (get-text-property (point) 'shr-indentation))
 632         (continuation (get-text-property
 633                        (point) 'shr-continuation-indentation))
 634         start)
 635     (put-text-property (point) (1+ (point)) 'shr-indentation nil)
 636     (let ((face (get-text-property (point) 'face))
 637           (background-start (point)))
 638       (shr-indent)
 639       (when face
 640         (put-text-property background-start (point) 'face
 641                            `,(shr-face-background face))))
 642     (setq start (point))
 643     (setq shr-indentation (or continuation shr-indentation))
 644     (shr-vertical-motion shr-internal-width)
 645     (when (looking-at " $")
 646       (delete-region (point) (line-end-position)))
 647     (while (not (eolp))
 648       ;; We have to do some folding.  First find the first
 649       ;; previous point suitable for folding.
 650       (if (or (not (shr-find-fill-point (line-beginning-position)))
 651               (= (point) start))
 652           ;; We had unbreakable text (for this width), so just go to
 653           ;; the first space and carry on.
 654           (progn
 655             (beginning-of-line)
 656             (skip-chars-forward " ")
 657             (search-forward " " (line-end-position) 'move)))
 658       ;; Success; continue.
 659       (when (= (preceding-char) ?\s)
 660         (delete-char -1))
 661       (let ((face (get-text-property (point) 'face))
 662             (background-start (point)))
 663         (insert "\n")
 664         (shr-indent)
 665         (when face
 666           (put-text-property background-start (point) 'face
 667                              `,(shr-face-background face))))
 668       (setq start (point))
 669       (shr-vertical-motion shr-internal-width)
 670       (when (looking-at " $")
 671         (delete-region (point) (line-end-position))))))
 672
 673 (defun shr-find-fill-point (start)
 674   (let ((bp (point))
 675         (end (point))
 676         failed)
 677     (while (not (or (setq failed (<= (point) start))
 678                     (eq (preceding-char) ? )
 679                     (eq (following-char) ? )
 680                     (shr-char-breakable-p (preceding-char))
 681                     (shr-char-breakable-p (following-char))
 682                     (and (shr-char-kinsoku-bol-p (preceding-char))
 683                          (shr-char-breakable-p (following-char))
 684                          (not (shr-char-kinsoku-bol-p (following-char))))
 685                     (shr-char-kinsoku-eol-p (following-char))
 686                     (bolp)))
 687       (backward-char 1))
 688     (if failed
 689         ;; There's no breakable point, so we give it up.
 690         (let (found)
 691           (goto-char bp)
 692           ;; Don't overflow the window edge, even if
 693           ;; shr-kinsoku-shorten is nil.
 694           (unless (or shr-kinsoku-shorten (null shr-width))
 695             (while (setq found (re-search-forward
 696                                 "\\(\\c>\\)\\| \\|\\c<\\|\\c|"
 697                                 (line-end-position) 'move)))
 698             (if (and found
 699                      (not (match-beginning 1)))
 700                 (goto-char (match-beginning 0)))))
 701       (or
 702        (eolp)
 703        ;; Don't put kinsoku-bol characters at the beginning of a line,
 704        ;; or kinsoku-eol characters at the end of a line.
 705        (cond
 706         ;; Don't overflow the window edge, even if shr-kinsoku-shorten
 707         ;; is nil.
 708         ((or shr-kinsoku-shorten (null shr-width))
 709          (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
 710                      (or (shr-char-kinsoku-eol-p (preceding-char))
 711                          (shr-char-kinsoku-bol-p (following-char))))
 712            (backward-char 1))
 713          (when (setq failed (<= (point) start))
 714            ;; There's no breakable point that doesn't violate kinsoku,
 715            ;; so we look for the second best position.
 716            (while (and (progn
 717                          (forward-char 1)
 718                          (<= (point) end))
 719                        (progn
 720                          (setq bp (point))
 721                          (shr-char-kinsoku-eol-p (following-char)))))
 722            (goto-char bp)))
 723         ((shr-char-kinsoku-eol-p (preceding-char))
 724          ;; Find backward the point where kinsoku-eol characters begin.
 725          (let ((count 4))
 726            (while
 727                (progn
 728                  (backward-char 1)
 729                  (and (> (setq count (1- count)) 0)
 730                       (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
 731                       (or (shr-char-kinsoku-eol-p (preceding-char))
 732                           (shr-char-kinsoku-bol-p (following-char)))))))
 733          (when (setq failed (<= (point) start))
 734            ;; There's no breakable point that doesn't violate kinsoku,
 735            ;; so we go to the second best position.
 736            (if (looking-at "\\(\\c<+\\)\\c<")
 737                (goto-char (match-end 1))
 738              (forward-char 1))))
 739         ((shr-char-kinsoku-bol-p (following-char))
 740          ;; Find forward the point where kinsoku-bol characters end.
 741          (let ((count 4))
 742            (while (progn
 743                     (forward-char 1)
 744                     (and (>= (setq count (1- count)) 0)
 745                          (shr-char-kinsoku-bol-p (following-char))
 746                          (shr-char-breakable-p (following-char))))))))
 747        (when (eq (following-char) ? )
 748          (forward-char 1))))
 749     (not failed)))
 750
 751 (defun shr-parse-base (url)
 752   ;; Always chop off anchors.
 753   (when (string-match "#.*" url)
 754     (setq url (substring url 0 (match-beginning 0))))
 755   ;; NB: <base href="" > URI may itself be relative to the document s URI
 756   (setq url (shr-expand-url url))
 757   (let* ((parsed (url-generic-parse-url url))
 758          (local (url-filename parsed)))
 759     (setf (url-filename parsed) "")
 760     ;; Chop off the bit after the last slash.
 761     (when (string-match "\\`\\(.*/\\)[^/]+\\'" local)
 762       (setq local (match-string 1 local)))
 763     ;; Always make the local bit end with a slash.
 764     (when (and (not (zerop (length local)))
 765                (not (eq (aref local (1- (length local))) ?/)))
 766       (setq local (concat local "/")))
 767     (list (url-recreate-url parsed)
 768           local
 769           (url-type parsed)
 770           url)))
 771
 772 (autoload 'url-expand-file-name "url-expand")
 773
 774 ;; FIXME This needs some tests writing.
 775 ;; Does it even need to exist, given that url-expand-file-name does?
 776 (defun shr-expand-url (url &optional base)
 777   (setq base
 778         (if base
 779             ;; shr-parse-base should never call this with non-nil base!
 780             (shr-parse-base base)
 781           ;; Bound by the parser.
 782           shr-base))
 783   (when (zerop (length url))
 784     (setq url nil))
 785   ;; Strip leading whitespace
 786   (and url (string-match "\\`\\s-+" url)
 787        (setq url (substring url (match-end 0))))
 788   (cond ((or (not url)
 789              (not base)
 790              (string-match "\\`[a-z]*:" url))
 791          ;; Absolute or empty URI
 792          (or url (nth 3 base)))
 793         ((eq (aref url 0) ?/)
 794          (if (and (> (length url) 1)
 795                   (eq (aref url 1) ?/))
 796              ;; //host...; just use the protocol
 797              (concat (nth 2 base) ":" url)
 798            ;; Just use the host name part.
 799            (concat (car base) url)))
 800         ((eq (aref url 0) ?#)
 801          ;; A link to an anchor.
 802          (concat (nth 3 base) url))
 803         (t
 804          ;; Totally relative.
 805          (url-expand-file-name url (concat (car base) (cadr base))))))
 806
 807 (defun shr-ensure-newline ()
 808   (unless (zerop (current-column))
 809     (insert "\n")))
 810
 811 (defun shr-ensure-paragraph ()
 812   (unless (bobp)
 813     (let ((prefix (get-text-property (line-beginning-position)
 814                                      'shr-prefix-length)))
 815       (cond
 816        ((and (bolp)
 817              (save-excursion
 818                (forward-line -1)
 819                (looking-at " *$")))
 820         ;; We're already at a new paragraph; do nothing.
 821         )
 822        ((and prefix
 823              (= prefix (- (point) (line-beginning-position))))
 824         ;; Do nothing; we're at the start of a <li>.
 825         )
 826        ((save-excursion
 827           (beginning-of-line)
 828           ;; If the current line is totally blank, and doesn't even
 829           ;; have any face properties set, then delete the blank
 830           ;; space.
 831           (and (looking-at " *$")
 832                (not (get-text-property (point) 'face))
 833                (not (= (next-single-property-change (point) 'face nil
 834                                                     (line-end-position))
 835                        (line-end-position)))))
 836         (delete-region (match-beginning 0) (match-end 0)))
 837        (t
 838         (insert "\n\n"))))))
 839
 840 (defun shr-indent ()
 841   (when (> shr-indentation 0)
 842     (insert
 843      (if (not shr-use-fonts)
 844          (make-string shr-indentation ?\s)
 845        (propertize " "
 846                    'display
 847                    `(space :width (,shr-indentation)))))))
 848
 849 (defun shr-fontize-dom (dom &rest types)
 850   (let ((start (point)))
 851     (shr-generic dom)
 852     (dolist (type types)
 853       (shr-add-font start (point) type))))
 854
 855 ;; Add face to the region, but avoid putting the font properties on
 856 ;; blank text at the start of the line, and the newline at the end, to
 857 ;; avoid ugliness.
 858 (defun shr-add-font (start end type)
 859   (save-excursion
 860     (goto-char start)
 861     (while (< (point) end)
 862       (when (bolp)
 863         (skip-chars-forward " "))
 864       (add-face-text-property (point) (min (line-end-position) end) type t)
 865       (if (< (line-end-position) end)
 866           (forward-line 1)
 867         (goto-char end)))))
 868
 869 (defun shr-mouse-browse-url (ev)
 870   "Browse the URL under the mouse cursor."
 871   (interactive "e")
 872   (mouse-set-point ev)
 873   (shr-browse-url))
 874
 875 (defun shr-browse-url (&optional external mouse-event)
 876   "Browse the URL under point.
 877 If EXTERNAL, browse the URL using `shr-external-browser'."
 878   (interactive (list current-prefix-arg last-nonmenu-event))
 879   (mouse-set-point mouse-event)
 880   (let ((url (get-text-property (point) 'shr-url)))
 881     (cond
 882      ((not url)
 883       (message "No link under point"))
 884      ((string-match "^mailto:" url)
 885       (browse-url-mail url))
 886      (t
 887       (if external
 888           (funcall shr-external-browser url)
 889         (browse-url url))))))
 890
 891 (defun shr-save-contents (directory)
 892   "Save the contents from URL in a file."
 893   (interactive "DSave contents of URL to directory: ")
 894   (let ((url (get-text-property (point) 'shr-url)))
 895     (if (not url)
 896         (message "No link under point")
 897       (url-retrieve (shr-encode-url url)
 898                     'shr-store-contents (list url directory)
 899                     nil t))))
 900
 901 (defun shr-store-contents (status url directory)
 902   (unless (plist-get status :error)
 903     (when (or (search-forward "\n\n" nil t)
 904               (search-forward "\r\n\r\n" nil t))
 905       (write-region (point) (point-max)
 906                     (expand-file-name (file-name-nondirectory url)
 907                                       directory)))))
 908
 909 (defun shr-image-fetched (status buffer start end &optional flags)
 910   (let ((image-buffer (current-buffer)))
 911     (when (and (buffer-name buffer)
 912                (not (plist-get status :error)))
 913       (url-store-in-cache image-buffer)
 914       (when (or (search-forward "\n\n" nil t)
 915                 (search-forward "\r\n\r\n" nil t))
 916         (let ((data (shr-parse-image-data)))
 917           (with-current-buffer buffer
 918             (save-excursion
 919               (let ((alt (buffer-substring start end))
 920                     (properties (text-properties-at start))
 921                     (inhibit-read-only t))
 922                 (delete-region start end)
 923                 (goto-char start)
 924                 (funcall shr-put-image-function data alt flags)
 925                 (while properties
 926                   (let ((type (pop properties))
 927                         (value (pop properties)))
 928                     (unless (memq type '(display image-size))
 929                       (put-text-property start (point) type value))))))))))
 930     (kill-buffer image-buffer)))
 931
 932 (defun shr-image-from-data (data)
 933   "Return an image from the data: URI content DATA."
 934   (when (string-match
 935          "\\(\\([^/;,]+\\(/[^;,]+\\)?\\)\\(;[^;,]+\\)*\\)?,\\(.*\\)"
 936          data)
 937     (let ((param (match-string 4 data))
 938           (payload (url-unhex-string (match-string 5 data))))
 939       (when (string-match "^.*\\(;[ \t]*base64\\)$" param)
 940         (setq payload (base64-decode-string payload)))
 941       payload)))
 942
 943 ;; Behind display-graphic-p test.
 944 (declare-function image-size "image.c" (spec &optional pixels frame))
 945 (declare-function image-animate "image" (image &optional index limit))
 946
 947 (defun shr-put-image (spec alt &optional flags)
 948   "Insert image SPEC with a string ALT.  Return image.
 949 SPEC is either an image data blob, or a list where the first
 950 element is the data blob and the second element is the content-type."
 951   (if (display-graphic-p)
 952       (let* ((size (cdr (assq 'size flags)))
 953              (data (if (consp spec)
 954                        (car spec)
 955                      spec))
 956              (content-type (and (consp spec)
 957                                 (cadr spec)))
 958              (start (point))
 959              (image (cond
 960                      ((eq size 'original)
 961                       (create-image data nil t :ascent 100
 962                                     :format content-type))
 963                      ((eq content-type 'image/svg+xml)
 964                       (create-image data 'svg t :ascent 100))
 965                      ((eq size 'full)
 966                       (ignore-errors
 967                         (shr-rescale-image data content-type
 968                                            (plist-get flags :width)
 969                                            (plist-get flags :height))))
 970                      (t
 971                       (ignore-errors
 972                         (shr-rescale-image data content-type
 973                                            (plist-get flags :width)
 974                                            (plist-get flags :height)))))))
 975         (when image
 976           ;; When inserting big-ish pictures, put them at the
 977           ;; beginning of the line.
 978           (when (and (> (current-column) 0)
 979                      (> (car (image-size image t)) 400))
 980             (insert "\n"))
 981           (if (eq size 'original)
 982               (insert-sliced-image image (or alt "*") nil 20 1)
 983             (insert-image image (or alt "*")))
 984           (put-text-property start (point) 'image-size size)
 985           (when (and shr-image-animate
 986                      (cond ((fboundp 'image-multi-frame-p)
 987                        ;; Only animate multi-frame things that specify a
 988                        ;; delay; eg animated gifs as opposed to
 989                        ;; multi-page tiffs.  FIXME?
 990                             (cdr (image-multi-frame-p image)))
 991                            ((fboundp 'image-animated-p)
 992                             (image-animated-p image))))
 993             (image-animate image nil 60)))
 994         image)
 995     (insert (or alt ""))))
 996
 997 (defun shr-rescale-image (data content-type width height)
 998   "Rescale DATA, if too big, to fit the current buffer.
 999 WIDTH and HEIGHT are the sizes given in the HTML data, if any."
1000   (if (not (and (fboundp 'imagemagick-types)
1001                 (get-buffer-window (current-buffer))))
1002       (create-image data nil t :ascent 100)
1003     (let* ((edges (window-inside-pixel-edges
1004                    (get-buffer-window (current-buffer))))
1005            (max-width (truncate (* shr-max-image-proportion
1006                                    (- (nth 2 edges) (nth 0 edges)))))
1007            (max-height (truncate (* shr-max-image-proportion
1008                                     (- (nth 3 edges) (nth 1 edges))))))
1009       (when (or (and width
1010                      (> width max-width))
1011                 (and height
1012                      (> height max-height)))
1013         (setq width nil
1014               height nil))
1015       (if (and width height)
1016           (create-image
1017            data 'imagemagick t
1018            :ascent 100
1019            :width width
1020            :height height
1021            :format content-type)
1022         (create-image
1023          data 'imagemagick t
1024          :ascent 100
1025          :max-width max-width
1026          :max-height max-height
1027          :format content-type)))))
1028
1029 ;; url-cache-extract autoloads url-cache.
1030 (declare-function url-cache-create-filename "url-cache" (url))
1031 (autoload 'mm-disable-multibyte "mm-util")
1032 (autoload 'browse-url-mail "browse-url")
1033
1034 (defun shr-get-image-data (url)
1035   "Get image data for URL.
1036 Return a string with image data."
1037   (with-temp-buffer
1038     (mm-disable-multibyte)
1039     (when (ignore-errors
1040             (url-cache-extract (url-cache-create-filename (shr-encode-url url)))
1041             t)
1042       (when (or (search-forward "\n\n" nil t)
1043                 (search-forward "\r\n\r\n" nil t))
1044         (shr-parse-image-data)))))
1045
1046 (declare-function libxml-parse-xml-region "xml.c"
1047                   (start end &optional base-url discard-comments))
1048
1049 (defun shr-parse-image-data ()
1050   (let ((data (buffer-substring (point) (point-max)))
1051         (content-type
1052          (save-excursion
1053            (save-restriction
1054              (narrow-to-region (point-min) (point))
1055              (let ((content-type (mail-fetch-field "content-type")))
1056                (and content-type
1057                     ;; Remove any comments in the type string.
1058                     (intern (replace-regexp-in-string ";.*" "" content-type)
1059                             obarray)))))))
1060     ;; SVG images may contain references to further images that we may
1061     ;; want to block.  So special-case these by parsing the XML data
1062     ;; and remove the blocked bits.
1063     (when (eq content-type 'image/svg+xml)
1064       (setq data
1065             (shr-dom-to-xml
1066              (libxml-parse-xml-region (point) (point-max)))))
1067     (list data content-type)))
1068
1069 (defun shr-image-displayer (content-function)
1070   "Return a function to display an image.
1071 CONTENT-FUNCTION is a function to retrieve an image for a cid url that
1072 is an argument.  The function to be returned takes three arguments URL,
1073 START, and END.  Note that START and END should be markers."
1074   `(lambda (url start end)
1075      (when url
1076        (if (string-match "\\`cid:" url)
1077            ,(when content-function
1078               `(let ((image (funcall ,content-function
1079                                      (substring url (match-end 0)))))
1080                  (when image
1081                    (goto-char start)
1082                    (funcall shr-put-image-function
1083                             image (buffer-substring start end))
1084                    (delete-region (point) end))))
1085          (url-retrieve url 'shr-image-fetched
1086                        (list (current-buffer) start end)
1087                        t t)))))
1088
1089 (defun shr-heading (dom &rest types)
1090   (shr-ensure-paragraph)
1091   (apply #'shr-fontize-dom dom types)
1092   (shr-ensure-paragraph))
1093
1094 (defun shr-urlify (start url &optional title)
1095   (shr-add-font start (point) 'shr-link)
1096   (add-text-properties
1097    start (point)
1098    (list 'shr-url url
1099          'help-echo (let ((iri (or (ignore-errors
1100                                      (decode-coding-string
1101                                       (url-unhex-string url)
1102                                       'utf-8 t))
1103                                    url)))
1104                       (if title (format "%s (%s)" iri title) iri))
1105          'follow-link t
1106          'mouse-face 'highlight))
1107   ;; Don't overwrite any keymaps that are already in the buffer (i.e.,
1108   ;; image keymaps).
1109   (while (and start
1110               (< start (point)))
1111     (let ((next (next-single-property-change start 'keymap nil (point))))
1112       (if (get-text-property start 'keymap)
1113           (setq start next)
1114         (put-text-property start (or next (point)) 'keymap shr-map)))))
1115
1116 (defun shr-encode-url (url)
1117   "Encode URL."
1118   (browse-url-url-encode-chars url "[)$ ]"))
1119
1120 (autoload 'shr-color-visible "shr-color")
1121 (autoload 'shr-color->hexadecimal "shr-color")
1122
1123 (defun shr-color-check (fg bg)
1124   "Check that FG is visible on BG.
1125 Returns (fg bg) with corrected values.
1126 Returns nil if the colors that would be used are the default
1127 ones, in case fg and bg are nil."
1128   (when (or fg bg)
1129     (let ((fixed (cond ((null fg) 'fg)
1130                        ((null bg) 'bg))))
1131       ;; Convert colors to hexadecimal, or set them to default.
1132       (let ((fg (or (shr-color->hexadecimal fg)
1133                     (frame-parameter nil 'foreground-color)))
1134             (bg (or (shr-color->hexadecimal bg)
1135                     (frame-parameter nil 'background-color))))
1136         (cond ((eq fixed 'bg)
1137                ;; Only return the new fg
1138                (list nil (cadr (shr-color-visible bg fg t))))
1139               ((eq fixed 'fg)
1140                ;; Invert args and results and return only the new bg
1141                (list (cadr (shr-color-visible fg bg t)) nil))
1142               (t
1143                (shr-color-visible bg fg)))))))
1144
1145 (defun shr-colorize-region (start end fg &optional bg)
1146   (when (and shr-use-colors
1147              (or fg bg)
1148              (>= (display-color-cells) 88))
1149     (let ((new-colors (shr-color-check fg bg)))
1150       (when new-colors
1151         (when fg
1152           (add-face-text-property start end
1153                                   (list :foreground (cadr new-colors))
1154                                   t))
1155         (when bg
1156           (add-face-text-property start end
1157                                   (list :background (car new-colors))
1158                                   t)))
1159       new-colors)))
1160
1161 (defun shr-previous-newline-padding-width (width)
1162   (let ((overlays (overlays-at (point)))
1163         (previous-width 0))
1164     (if (null overlays)
1165         width
1166       (dolist (overlay overlays)
1167         (setq previous-width
1168               (+ previous-width
1169                  (length (plist-get (overlay-properties overlay)
1170                                     'before-string)))))
1171       (+ width previous-width))))
1172
1173 ;;; Tag-specific rendering rules.
1174
1175 (defun shr-tag-html (dom)
1176   (let ((dir (dom-attr dom 'dir)))
1177     (cond
1178      ((equal dir "ltr")
1179       (setq bidi-paragraph-direction 'left-to-right))
1180      ((equal dir "rtl")
1181       (setq bidi-paragraph-direction 'right-to-left))))
1182   (shr-generic dom))
1183
1184 (defun shr-tag-body (dom)
1185   (let* ((start (point))
1186          (fgcolor (or (dom-attr dom 'fgcolor) (dom-attr dom 'text)))
1187          (bgcolor (dom-attr dom 'bgcolor))
1188          (shr-stylesheet (list (cons 'color fgcolor)
1189                                (cons 'background-color bgcolor))))
1190     (shr-generic dom)
1191     (shr-colorize-region start (point) fgcolor bgcolor)))
1192
1193 (defun shr-tag-style (_dom)
1194   )
1195
1196 (defun shr-tag-script (_dom)
1197   )
1198
1199 (defun shr-tag-comment (_dom)
1200   )
1201
1202 (defun shr-dom-to-xml (dom)
1203   (with-temp-buffer
1204     (shr-dom-print dom)
1205     (buffer-string)))
1206
1207 (defun shr-dom-print (dom)
1208   "Convert DOM into a string containing the xml representation."
1209   (insert (format "<%s" (dom-tag dom)))
1210   (dolist (attr (dom-attributes dom))
1211     ;; Ignore attributes that start with a colon because they are
1212     ;; private elements.
1213     (unless (= (aref (format "%s" (car attr)) 0) ?:)
1214       (insert (format " %s=\"%s\"" (car attr) (cdr attr)))))
1215   (insert ">")
1216   (let (url)
1217     (dolist (elem (dom-children dom))
1218       (cond
1219        ((stringp elem)
1220         (insert elem))
1221        ((eq (dom-tag elem) 'comment)
1222         )
1223        ((or (not (eq (dom-tag elem) 'image))
1224             ;; Filter out blocked elements inside the SVG image.
1225             (not (setq url (dom-attr elem ':xlink:href)))
1226             (not shr-blocked-images)
1227             (not (string-match shr-blocked-images url)))
1228         (insert " ")
1229         (shr-dom-print elem)))))
1230   (insert (format "</%s>" (dom-tag dom))))
1231
1232 (defun shr-tag-svg (dom)
1233   (when (and (image-type-available-p 'svg)
1234              (not shr-inhibit-images)
1235              (dom-attr dom 'width)
1236              (dom-attr dom 'height))
1237     (funcall shr-put-image-function (list (shr-dom-to-xml dom) 'image/svg+xml)
1238              "SVG Image")))
1239
1240 (defun shr-tag-sup (dom)
1241   (let ((start (point)))
1242     (shr-generic dom)
1243     (put-text-property start (point) 'display '(raise 0.5))))
1244
1245 (defun shr-tag-sub (dom)
1246   (let ((start (point)))
1247     (shr-generic dom)
1248     (put-text-property start (point) 'display '(raise -0.5))))
1249
1250 (defun shr-tag-label (dom)
1251   (shr-generic dom)
1252   (shr-ensure-paragraph))
1253
1254 (defun shr-tag-p (dom)
1255   (shr-ensure-paragraph)
1256   (shr-generic dom)
1257   (shr-ensure-paragraph))
1258
1259 (defun shr-tag-div (dom)
1260   (shr-ensure-paragraph)
1261   (shr-generic dom)
1262   (shr-ensure-newline))
1263
1264 (defun shr-tag-s (dom)
1265   (shr-fontize-dom dom 'shr-strike-through))
1266
1267 (defun shr-tag-b (dom)
1268   (shr-fontize-dom dom 'bold))
1269
1270 (defun shr-tag-i (dom)
1271   (shr-fontize-dom dom 'italic))
1272
1273 (defun shr-tag-em (dom)
1274   (shr-fontize-dom dom 'italic))
1275
1276 (defun shr-tag-strong (dom)
1277   (shr-fontize-dom dom 'bold))
1278
1279 (defun shr-tag-u (dom)
1280   (shr-fontize-dom dom 'underline))
1281
1282 (defun shr-tag-tt (dom)
1283   (let ((shr-current-font 'default))
1284     (shr-generic dom)))
1285
1286 (defun shr-tag-ins (cont)
1287   (let* ((start (point))
1288          (color "green")
1289          (shr-stylesheet (nconc (list (cons 'color color))
1290                                 shr-stylesheet)))
1291     (shr-generic cont)
1292     (shr-colorize-region start (point) color
1293                          (cdr (assq 'background-color shr-stylesheet)))))
1294
1295 (defun shr-tag-del (cont)
1296   (let* ((start (point))
1297          (color "red")
1298          (shr-stylesheet (nconc (list (cons 'color color))
1299                                 shr-stylesheet)))
1300     (shr-fontize-dom cont 'shr-strike-through)
1301     (shr-colorize-region start (point) color
1302                          (cdr (assq 'background-color shr-stylesheet)))))
1303
1304 (defun shr-parse-style (style)
1305   (when style
1306     (save-match-data
1307       (when (string-match "\n" style)
1308         (setq style (replace-match " " t t style))))
1309     (let ((plist nil))
1310       (dolist (elem (split-string style ";"))
1311         (when elem
1312           (setq elem (split-string elem ":"))
1313           (when (and (car elem)
1314                      (cadr elem))
1315             (let ((name (replace-regexp-in-string "^ +\\| +$" "" (car elem)))
1316                   (value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem))))
1317               (when (string-match " *!important\\'" value)
1318                 (setq value (substring value 0 (match-beginning 0))))
1319               (unless (equal value "inherit")
1320                 (push (cons (intern name obarray)
1321                             value)
1322                       plist))))))
1323       plist)))
1324
1325 (defun shr-tag-base (dom)
1326   (when-let (base (dom-attr dom 'href))
1327     (setq shr-base (shr-parse-base base)))
1328   (shr-generic dom))
1329
1330 (defun shr-tag-a (dom)
1331   (let ((url (dom-attr dom 'href))
1332         (title (dom-attr dom 'title))
1333         (start (point))
1334         shr-start)
1335     (shr-generic dom)
1336     (when (and shr-target-id
1337                (equal (dom-attr dom 'name) shr-target-id))
1338       ;; We have a zero-length <a name="foo"> element, so just
1339       ;; insert...  something.
1340       (when (= start (point))
1341         (shr-ensure-newline)
1342         (insert " "))
1343       (put-text-property start (1+ start) 'shr-target-id shr-target-id))
1344     (when url
1345       (shr-urlify (or shr-start start) (shr-expand-url url) title))))
1346
1347 (defun shr-tag-object (dom)
1348   (unless shr-inhibit-images
1349     (let ((start (point))
1350           url multimedia image)
1351       (when-let (type (dom-attr dom 'type))
1352         (when (string-match "\\`image/svg" type)
1353           (setq url (dom-attr dom 'data)
1354                 image t)))
1355       (dolist (child (dom-non-text-children dom))
1356         (cond
1357          ((eq (dom-tag child) 'embed)
1358           (setq url (or url (dom-attr child 'src))
1359                 multimedia t))
1360          ((and (eq (dom-tag child) 'param)
1361                (equal (dom-attr child 'name) "movie"))
1362           (setq url (or url (dom-attr child 'value))
1363                 multimedia t))))
1364       (when url
1365         (cond
1366          (image
1367           (shr-tag-img dom url)
1368           (setq dom nil))
1369          (multimedia
1370           (shr-insert " [multimedia] ")
1371           (shr-urlify start (shr-expand-url url)))))
1372       (when dom
1373         (shr-generic dom)))))
1374
1375 (defcustom shr-prefer-media-type-alist '(("webm" . 1.0)
1376                                          ("ogv"  . 1.0)
1377                                          ("ogg"  . 1.0)
1378                                          ("opus" . 1.0)
1379                                          ("flac" . 0.9)
1380                                          ("wav"  . 0.5))
1381   "Preferences for media types.
1382 The key element should be a regexp matched against the type of the source or
1383 url if no type is specified.  The value should be a float in the range 0.0 to
1384 1.0.  Media elements with higher value are preferred."
1385   :version "24.4"
1386   :group 'shr
1387   :type '(alist :key-type regexp :value-type float))
1388
1389 (defun shr--get-media-pref (elem)
1390   "Determine the preference for ELEM.
1391 The preference is a float determined from `shr-prefer-media-type'."
1392   (let ((type (dom-attr elem 'type))
1393         (p 0.0))
1394     (unless type
1395       (setq type (dom-attr elem 'src)))
1396     (when type
1397       (dolist (pref shr-prefer-media-type-alist)
1398         (when (and
1399                (> (cdr pref) p)
1400                (string-match-p (car pref) type))
1401           (setq p (cdr pref)))))
1402     p))
1403
1404 (defun shr--extract-best-source (dom &optional url pref)
1405   "Extract the best `:src' property from <source> blocks in DOM."
1406   (setq pref (or pref -1.0))
1407   (let (new-pref)
1408     (dolist (elem (dom-non-text-children dom))
1409       (when (and (eq (dom-tag elem) 'source)
1410                  (< pref
1411                     (setq new-pref
1412                           (shr--get-media-pref elem))))
1413         (setq pref new-pref
1414               url (dom-attr elem 'src))
1415         ;; libxml's html parser isn't HTML5 compliant and non terminated
1416         ;; source tags might end up as children.  So recursion it is...
1417         (dolist (child (dom-non-text-children elem))
1418           (when (eq (dom-tag child) 'source)
1419             (let ((ret (shr--extract-best-source (list child) url pref)))
1420               (when (< pref (cdr ret))
1421                 (setq url (car ret)
1422                       pref (cdr ret)))))))))
1423   (cons url pref))
1424
1425 (defun shr-tag-video (dom)
1426   (let ((image (dom-attr dom 'poster))
1427         (url (dom-attr dom 'src))
1428         (start (point)))
1429     (unless url
1430       (setq url (car (shr--extract-best-source dom))))
1431     (if (> (length image) 0)
1432         (shr-tag-img nil image)
1433       (shr-insert " [video] "))
1434     (shr-urlify start (shr-expand-url url))))
1435
1436 (defun shr-tag-audio (dom)
1437   (let ((url (dom-attr dom 'src))
1438         (start (point)))
1439     (unless url
1440       (setq url (car (shr--extract-best-source dom))))
1441     (shr-insert " [audio] ")
1442     (shr-urlify start (shr-expand-url url))))
1443
1444 (defun shr-tag-img (dom &optional url)
1445   (when (or url
1446             (and dom
1447                  (> (length (dom-attr dom 'src)) 0)))
1448     (when (> (current-column) 0)
1449       (insert "\n"))
1450     (let ((alt (dom-attr dom 'alt))
1451           (width (shr-string-number (dom-attr dom 'width)))
1452           (height (shr-string-number (dom-attr dom 'height)))
1453           (url (shr-expand-url (or url (dom-attr dom 'src)))))
1454       (let ((start (point-marker)))
1455         (when (zerop (length alt))
1456           (setq alt "*"))
1457         (cond
1458          ((or (member (dom-attr dom 'height) '("0" "1"))
1459               (member (dom-attr dom 'width) '("0" "1")))
1460           ;; Ignore zero-sized or single-pixel images.
1461           )
1462          ((and (not shr-inhibit-images)
1463                (string-match "\\`data:" url))
1464           (let ((image (shr-image-from-data (substring url (match-end 0)))))
1465             (if image
1466                 (funcall shr-put-image-function image alt
1467                          (list :width width :height height))
1468               (insert alt))))
1469          ((and (not shr-inhibit-images)
1470                (string-match "\\`cid:" url))
1471           (let ((url (substring url (match-end 0)))
1472                 image)
1473             (if (or (not shr-content-function)
1474                     (not (setq image (funcall shr-content-function url))))
1475                 (insert alt)
1476               (funcall shr-put-image-function image alt
1477                        (list :width width :height height)))))
1478          ((or shr-inhibit-images
1479               (and shr-blocked-images
1480                    (string-match shr-blocked-images url)))
1481           (setq shr-start (point))
1482           (shr-insert alt))
1483          ((and (not shr-ignore-cache)
1484                (url-is-cached (shr-encode-url url)))
1485           (funcall shr-put-image-function (shr-get-image-data url) alt
1486                    (list :width width :height height)))
1487          (t
1488           (when (and shr-ignore-cache
1489                      (url-is-cached (shr-encode-url url)))
1490             (let ((file (url-cache-create-filename (shr-encode-url url))))
1491               (when (file-exists-p file)
1492                 (delete-file file))))
1493           (when (image-type-available-p 'svg)
1494             (insert-image
1495              (shr-make-placeholder-image dom)
1496              (or alt "")))
1497           (insert " ")
1498           (url-queue-retrieve
1499            (shr-encode-url url) 'shr-image-fetched
1500            (list (current-buffer) start (set-marker (make-marker) (1- (point)))
1501                  (list :width width :height height))
1502            t t)))
1503         (when (zerop shr-table-depth) ;; We are not in a table.
1504           (put-text-property start (point) 'keymap shr-image-map)
1505           (put-text-property start (point) 'shr-alt alt)
1506           (put-text-property start (point) 'image-url url)
1507           (put-text-property start (point) 'image-displayer
1508                              (shr-image-displayer shr-content-function))
1509           (put-text-property start (point) 'help-echo
1510                              (shr-fill-text
1511                               (or (dom-attr dom 'title) alt))))))))
1512
1513 (defun shr-string-number (string)
1514   (if (null string)
1515       nil
1516     (setq string (replace-regexp-in-string "[^0-9]" "" string))
1517     (if (zerop (length string))
1518         nil
1519       (string-to-number string))))
1520
1521 (defun shr-make-placeholder-image (dom)
1522   (let* ((edges (and
1523                  (get-buffer-window (current-buffer))
1524                  (window-inside-pixel-edges
1525                   (get-buffer-window (current-buffer)))))
1526          (scaling (image-compute-scaling-factor image-scaling-factor))
1527          (width (truncate
1528                  (* (or (shr-string-number (dom-attr dom 'width)) 100)
1529                     scaling)))
1530          (height (truncate
1531                   (* (or (shr-string-number (dom-attr dom 'height)) 100)
1532                      scaling)))
1533          (max-width
1534           (and edges
1535                (truncate (* shr-max-image-proportion
1536                             (- (nth 2 edges) (nth 0 edges))))))
1537          (max-height (and edges
1538                           (truncate (* shr-max-image-proportion
1539                                        (- (nth 3 edges) (nth 1 edges))))))
1540          svg image)
1541     (when (and max-width
1542                (> width max-width))
1543       (setq height (truncate (* (/ (float max-width) width) height))
1544             width max-width))
1545     (when (and max-height
1546                (> height max-height))
1547       (setq width (truncate (* (/ (float max-height) height) width))
1548             height max-height))
1549     (setq svg (svg-create width height))
1550     (svg-gradient svg "background" 'linear '((0 . "#b0b0b0") (100 . "#808080")))
1551     (svg-rectangle svg 0 0 width height :gradient "background"
1552                    :stroke-width 2 :stroke-color "black")
1553     (let ((image (svg-image svg)))
1554       (setf (image-property image :ascent) 100)
1555       image)))
1556
1557 (defun shr-tag-pre (dom)
1558   (let ((shr-folding-mode 'none)
1559         (shr-current-font 'default))
1560     (shr-ensure-newline)
1561     (shr-generic dom)
1562     (shr-ensure-newline)))
1563
1564 (defun shr-tag-blockquote (dom)
1565   (shr-ensure-paragraph)
1566   (let ((start (point))
1567         (shr-indentation (+ shr-indentation
1568                             (* 4 shr-table-separator-pixel-width))))
1569     (shr-generic dom)
1570     (shr-ensure-paragraph)
1571     (shr-mark-fill start)))
1572
1573 (defun shr-tag-dl (dom)
1574   (shr-ensure-paragraph)
1575   (shr-generic dom)
1576   (shr-ensure-paragraph))
1577
1578 (defun shr-tag-dt (dom)
1579   (shr-ensure-newline)
1580   (shr-generic dom)
1581   (shr-ensure-newline))
1582
1583 (defun shr-tag-dd (dom)
1584   (shr-ensure-newline)
1585   (let ((shr-indentation (+ shr-indentation
1586                             (* 4 shr-table-separator-pixel-width))))
1587     (shr-generic dom)))
1588
1589 (defun shr-tag-ul (dom)
1590   (shr-ensure-paragraph)
1591   (let ((shr-list-mode 'ul))
1592     (shr-generic dom))
1593   (shr-ensure-paragraph))
1594
1595 (defun shr-tag-ol (dom)
1596   (shr-ensure-paragraph)
1597   (let ((shr-list-mode 1))
1598     (shr-generic dom))
1599   (shr-ensure-paragraph))
1600
1601 (defun shr-tag-li (dom)
1602   (shr-ensure-newline)
1603   (let ((start (point)))
1604     (let* ((bullet
1605             (if (numberp shr-list-mode)
1606                 (prog1
1607                     (format "%d " shr-list-mode)
1608                   (setq shr-list-mode (1+ shr-list-mode)))
1609               (car shr-internal-bullet)))
1610            (width (if (numberp shr-list-mode)
1611                       (shr-string-pixel-width bullet)
1612                     (cdr shr-internal-bullet))))
1613       (insert bullet)
1614       (shr-mark-fill start)
1615       (let ((shr-indentation (+ shr-indentation width)))
1616         (put-text-property start (1+ start)
1617                            'shr-continuation-indentation shr-indentation)
1618         (put-text-property start (1+ start) 'shr-prefix-length (length bullet))
1619         (shr-generic dom)))))
1620
1621 (defun shr-mark-fill (start)
1622   ;; We may not have inserted any text to fill.
1623   (unless (= start (point))
1624     (put-text-property start (1+ start)
1625                        'shr-indentation shr-indentation)))
1626
1627 (defun shr-tag-br (dom)
1628   (when (and (not (bobp))
1629              ;; Only add a newline if we break the current line, or
1630              ;; the previous line isn't a blank line.
1631              (or (not (bolp))
1632                  (and (> (- (point) 2) (point-min))
1633                       (not (= (char-after (- (point) 2)) ?\n)))))
1634     (insert "\n"))
1635   (shr-generic dom))
1636
1637 (defun shr-tag-span (dom)
1638   (shr-generic dom))
1639
1640 (defun shr-tag-h1 (dom)
1641   (shr-heading dom (if shr-use-fonts
1642                        '(variable-pitch (:height 1.3 :weight bold))
1643                      'bold)))
1644
1645 (defun shr-tag-h2 (dom)
1646   (shr-heading dom 'bold))
1647
1648 (defun shr-tag-h3 (dom)
1649   (shr-heading dom 'italic))
1650
1651 (defun shr-tag-h4 (dom)
1652   (shr-heading dom))
1653
1654 (defun shr-tag-h5 (dom)
1655   (shr-heading dom))
1656
1657 (defun shr-tag-h6 (dom)
1658   (shr-heading dom))
1659
1660 (defun shr-tag-hr (_dom)
1661   (shr-ensure-newline)
1662   (insert (make-string (if (not shr-use-fonts)
1663                            shr-internal-width
1664                          (1+ (/ shr-internal-width
1665                                 shr-table-separator-pixel-width)))
1666                        shr-hr-line)
1667           "\n"))
1668
1669 (defun shr-tag-title (dom)
1670   (shr-heading dom 'bold 'underline))
1671
1672 (defun shr-tag-font (dom)
1673   (let* ((start (point))
1674          (color (dom-attr dom 'color))
1675          (shr-stylesheet (nconc (list (cons 'color color))
1676                                 shr-stylesheet)))
1677     (shr-generic dom)
1678     (when color
1679       (shr-colorize-region start (point) color
1680                            (cdr (assq 'background-color shr-stylesheet))))))
1681
1682 ;;; Table rendering algorithm.
1683
1684 ;; Table rendering is the only complicated thing here.  We do this by
1685 ;; first counting how many TDs there are in each TR, and registering
1686 ;; how wide they think they should be ("width=45%", etc).  Then we
1687 ;; render each TD separately (this is done in temporary buffers, so
1688 ;; that we can use all the rendering machinery as if we were in the
1689 ;; main buffer).  Now we know how much space each TD really takes, so
1690 ;; we then render everything again with the new widths, and finally
1691 ;; insert all these boxes into the main buffer.
1692 (defun shr-tag-table-1 (dom)
1693   (setq dom (or (dom-child-by-tag dom 'tbody) dom))
1694   (let* ((shr-inhibit-images t)
1695          (shr-table-depth (1+ shr-table-depth))
1696          (shr-kinsoku-shorten t)
1697          ;; Find all suggested widths.
1698          (columns (shr-column-specs dom))
1699          ;; Compute how many pixels wide each TD should be.
1700          (suggested-widths (shr-pro-rate-columns columns))
1701          ;; Do a "test rendering" to see how big each TD is (this can
1702          ;; be smaller (if there's little text) or bigger (if there's
1703          ;; unbreakable text).
1704          (elems (or (dom-attr dom 'shr-suggested-widths)
1705                     (shr-make-table dom suggested-widths nil
1706                                     'shr-suggested-widths)))
1707          (sketch (loop for line in elems
1708                        collect (mapcar #'car line)))
1709          (natural (loop for line in elems
1710                         collect (mapcar #'cdr line)))
1711          (sketch-widths (shr-table-widths sketch natural suggested-widths)))
1712     ;; This probably won't work very well.
1713     (when (> (+ (loop for width across sketch-widths
1714                       summing (1+ width))
1715                 shr-indentation shr-table-separator-pixel-width)
1716              (frame-width))
1717       (setq truncate-lines t))
1718     ;; Then render the table again with these new "hard" widths.
1719     (shr-insert-table (shr-make-table dom sketch-widths t) sketch-widths)))
1720
1721 (defun shr-table-body (dom)
1722   (let ((tbodies (seq-filter (lambda (child)
1723                                (eq (dom-tag child) 'tbody))
1724                              (dom-non-text-children dom))))
1725     (cond
1726      ((null tbodies)
1727       dom)
1728      ((= (length tbodies) 1)
1729       (car tbodies))
1730      (t
1731       ;; Table with multiple tbodies.  Convert into a single tbody.
1732       `(tbody nil ,@(cl-reduce 'append
1733                                (mapcar 'dom-non-text-children tbodies)))))))
1734
1735 (defun shr-tag-table (dom)
1736   (shr-ensure-paragraph)
1737   (let* ((caption (dom-children (dom-child-by-tag dom 'caption)))
1738          (header (dom-non-text-children (dom-child-by-tag dom 'thead)))
1739          (body (dom-non-text-children (shr-table-body dom)))
1740          (footer (dom-non-text-children (dom-child-by-tag dom 'tfoot)))
1741          (bgcolor (dom-attr dom 'bgcolor))
1742          (start (point))
1743          (shr-stylesheet (nconc (list (cons 'background-color bgcolor))
1744                                 shr-stylesheet))
1745          (nheader (if header (shr-max-columns header)))
1746          (nbody (if body (shr-max-columns body) 0))
1747          (nfooter (if footer (shr-max-columns footer))))
1748     (if (and (not caption)
1749              (not header)
1750              (not (dom-child-by-tag dom 'tbody))
1751              (not (dom-child-by-tag dom 'tr))
1752              (not footer))
1753         ;; The table is totally invalid and just contains random junk.
1754         ;; Try to output it anyway.
1755         (shr-generic dom)
1756       ;; It's a real table, so render it.
1757       (if (dom-attr dom 'shr-fixed-table)
1758           (shr-tag-table-1 dom)
1759         ;; Only fix up the table once.
1760         (let ((table
1761                (nconc
1762                 (list 'table nil)
1763                 (if caption `((tr nil (td nil ,@caption))))
1764                 (cond
1765                  (header
1766                   (if footer
1767                       ;; header + body + footer
1768                       (if (= nheader nbody)
1769                           (if (= nbody nfooter)
1770                               `((tr nil (td nil (table nil
1771                                                        (tbody nil ,@header
1772                                                               ,@body ,@footer)))))
1773                             (nconc `((tr nil (td nil (table nil
1774                                                             (tbody nil ,@header
1775                                                                    ,@body)))))
1776                                    (if (= nfooter 1)
1777                                        footer
1778                                      `((tr nil (td nil (table
1779                                                         nil (tbody
1780                                                              nil ,@footer))))))))
1781                         (nconc `((tr nil (td nil (table nil (tbody
1782                                                              nil ,@header)))))
1783                                (if (= nbody nfooter)
1784                                    `((tr nil (td nil (table
1785                                                       nil (tbody nil ,@body
1786                                                                  ,@footer)))))
1787                                  (nconc `((tr nil (td nil (table
1788                                                            nil (tbody nil
1789                                                                       ,@body)))))
1790                                         (if (= nfooter 1)
1791                                             footer
1792                                           `((tr nil (td nil (table
1793                                                              nil
1794                                                              (tbody
1795                                                               nil
1796                                                               ,@footer))))))))))
1797                     ;; header + body
1798                     (if (= nheader nbody)
1799                         `((tr nil (td nil (table nil (tbody nil ,@header
1800                                                             ,@body)))))
1801                       (if (= nheader 1)
1802                           `(,@header (tr nil (td nil (table
1803                                                       nil (tbody nil ,@body)))))
1804                         `((tr nil (td nil (table nil (tbody nil ,@header))))
1805                           (tr nil (td nil (table nil (tbody nil ,@body)))))))))
1806                  (footer
1807                   ;; body + footer
1808                   (if (= nbody nfooter)
1809                       `((tr nil (td nil (table
1810                                          nil (tbody nil ,@body ,@footer)))))
1811                     (nconc `((tr nil (td nil (table nil (tbody nil ,@body)))))
1812                            (if (= nfooter 1)
1813                                footer
1814                              `((tr nil (td nil (table
1815                                                 nil (tbody nil ,@footer)))))))))
1816                  (caption
1817                   `((tr nil (td nil (table nil (tbody nil ,@body))))))
1818                  (body)))))
1819           (dom-set-attribute table 'shr-fixed-table t)
1820           (setcdr dom (cdr table))
1821           (shr-tag-table-1 dom))))
1822     (when bgcolor
1823       (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet))
1824                            bgcolor))
1825     ;; Finally, insert all the images after the table.  The Emacs buffer
1826     ;; model isn't strong enough to allow us to put the images actually
1827     ;; into the tables.
1828     (when (zerop shr-table-depth)
1829       (save-excursion
1830         (shr-expand-alignments start (point)))
1831       (dolist (elem (dom-by-tag dom 'object))
1832         (shr-tag-object elem))
1833       (dolist (elem (dom-by-tag dom 'img))
1834         (shr-tag-img elem)))))
1835
1836 (defun shr-insert-table (table widths)
1837   (let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet))
1838                           "collapse"))
1839          (shr-table-separator-length (if collapse 0 1))
1840          (shr-table-vertical-line (if collapse "" shr-table-vertical-line))
1841          (start (point)))
1842     (setq shr-table-id (1+ shr-table-id))
1843     (unless collapse
1844       (shr-insert-table-ruler widths))
1845     (dolist (row table)
1846       (let ((start (point))
1847             (align 0)
1848             (column-number 0)
1849             (height (let ((max 0))
1850                       (dolist (column row)
1851                         (setq max (max max (nth 2 column))))
1852                       max)))
1853         (dotimes (i (max height 1))
1854           (shr-indent)
1855           (insert shr-table-vertical-line "\n"))
1856         (dolist (column row)
1857           (when (> (nth 2 column) -1)
1858             (goto-char start)
1859             ;; Sum up all the widths from the column.  (There may be
1860             ;; more than one if this is a "colspan" column.)
1861             (dotimes (i (nth 4 column))
1862               ;; The colspan directive may be wrong and there may not be
1863               ;; that number of columns.
1864               (when (<= column-number (1- (length widths)))
1865                 (setq align (+ align
1866                                (aref widths column-number)
1867                                (* 2 shr-table-separator-pixel-width))))
1868               (setq column-number (1+ column-number)))
1869             (let ((lines (nth 3 column))
1870                   (pixel-align (if (not shr-use-fonts)
1871                                    (* align (frame-char-width))
1872                                  align)))
1873               (dolist (line lines)
1874                 (end-of-line)
1875                 (let ((start (point))
1876                       (background (and (> (length line) 0)
1877                                        (shr-face-background
1878                                         (get-text-property
1879                                          (1- (length line)) 'face line))))
1880                       (space (propertize
1881                               " "
1882                               'display `(space :align-to (,pixel-align))
1883                               'shr-table-indent shr-table-id)))
1884                   (when background
1885                     (setq space (propertize space 'face background)))
1886                   (insert line space shr-table-vertical-line)
1887                   (shr-colorize-region
1888                    start (1- (point)) (nth 5 column) (nth 6 column)))
1889                 (forward-line 1))
1890               ;; Add blank lines at padding at the bottom of the TD,
1891               ;; possibly.
1892               (dotimes (i (- height (length lines)))
1893                 (end-of-line)
1894                 (let ((start (point)))
1895                   (insert (propertize " "
1896                                       'display `(space :align-to (,pixel-align))
1897                                       'shr-table-indent shr-table-id)
1898                           shr-table-vertical-line)
1899                   (shr-colorize-region
1900                    start (1- (point)) (nth 5 column) (nth 6 column)))
1901                 (forward-line 1))))))
1902       (unless collapse
1903         (shr-insert-table-ruler widths)))
1904     (unless (= start (point))
1905       (put-text-property start (1+ start) 'shr-table-id shr-table-id))))
1906
1907 (defun shr-face-background (face)
1908   (and (consp face)
1909        (or (and (plist-get face :background)
1910                 (list :background (plist-get face :background)))
1911            (let ((background nil))
1912              (dolist (elem face)
1913                (when (and (consp elem)
1914                           (eq (car elem) :background)
1915                           (not background))
1916                  (setq background (cadr elem))))
1917              (and background
1918                   (list :background background))))))
1919
1920 (defun shr-expand-alignments (start end)
1921   (while (< (setq start (next-single-property-change
1922                          start 'shr-table-id nil end))
1923             end)
1924     (goto-char start)
1925     (let* ((shr-use-fonts t)
1926            (id (get-text-property (point) 'shr-table-id))
1927            (base (shr-pixel-column))
1928            elem)
1929       (when id
1930         (save-excursion
1931           (while (setq elem (text-property-any
1932                              (point) end 'shr-table-indent id))
1933             (goto-char elem)
1934             (let ((align (get-text-property (point) 'display)))
1935               (put-text-property (point) (1+ (point)) 'display
1936                                  `(space :align-to (,(+ (car (nth 2 align))
1937                                                         base)))))
1938             (forward-char 1)))))
1939     (setq start (1+ start))))
1940
1941 (defun shr-insert-table-ruler (widths)
1942   (when shr-table-horizontal-line
1943     (when (and (bolp)
1944                (> shr-indentation 0))
1945       (shr-indent))
1946     (insert shr-table-corner)
1947     (let ((total-width 0))
1948       (dotimes (i (length widths))
1949         (setq total-width (+ total-width (aref widths i)
1950                              (* shr-table-separator-pixel-width 2)))
1951         (insert (make-string (1+ (/ (aref widths i)
1952                                     shr-table-separator-pixel-width))
1953                              shr-table-horizontal-line)
1954                 (propertize " "
1955                             'display `(space :align-to (,total-width))
1956                             'shr-table-indent shr-table-id)
1957                 shr-table-corner)))
1958     (insert "\n")))
1959
1960 (defun shr-table-widths (table natural-table suggested-widths)
1961   (let* ((length (length suggested-widths))
1962          (widths (make-vector length 0))
1963          (natural-widths (make-vector length 0)))
1964     (dolist (row table)
1965       (let ((i 0))
1966         (dolist (column row)
1967           (aset widths i (max (aref widths i) column))
1968           (setq i (1+ i)))))
1969     (dolist (row natural-table)
1970       (let ((i 0))
1971         (dolist (column row)
1972           (aset natural-widths i (max (aref natural-widths i) column))
1973           (setq i (1+ i)))))
1974     (let ((extra (- (apply '+ (append suggested-widths nil))
1975                     (apply '+ (append widths nil))
1976                     (* shr-table-separator-pixel-width (1+ (length widths)))))
1977           (expanded-columns 0))
1978       ;; We have extra, unused space, so divide this space amongst the
1979       ;; columns.
1980       (when (> extra 0)
1981         ;; If the natural width is wider than the rendered width, we
1982         ;; want to allow the column to expand.
1983         (dotimes (i length)
1984           (when (> (aref natural-widths i) (aref widths i))
1985             (setq expanded-columns (1+ expanded-columns))))
1986         (dotimes (i length)
1987           (when (> (aref natural-widths i) (aref widths i))
1988             (aset widths i (min
1989                             (aref natural-widths i)
1990                             (+ (/ extra expanded-columns)
1991                                (aref widths i))))))))
1992     widths))
1993
1994 (defun shr-make-table (dom widths &optional fill storage-attribute)
1995   (or (cadr (assoc (list dom widths fill) shr-content-cache))
1996       (let ((data (shr-make-table-1 dom widths fill)))
1997         (push (list (list dom widths fill) data)
1998               shr-content-cache)
1999         (when storage-attribute
2000           (dom-set-attribute dom storage-attribute data))
2001         data)))
2002
2003 (defun shr-make-table-1 (dom widths &optional fill)
2004   (let ((trs nil)
2005         (rowspans (make-vector (length widths) 0))
2006         (colspan-remaining 0)
2007         colspan-width colspan-count
2008         width colspan)
2009     (dolist (row (dom-non-text-children dom))
2010       (when (eq (dom-tag row) 'tr)
2011         (let ((tds nil)
2012               (columns (dom-non-text-children row))
2013               (i 0)
2014               (width-column 0)
2015               column)
2016           (while (< i (length widths))
2017             ;; If we previously had a rowspan definition, then that
2018             ;; means that we now have a "missing" td/th element here.
2019             ;; So just insert a dummy, empty one to (sort of) emulate
2020             ;; rowspan.
2021             (setq column
2022                   (if (zerop (aref rowspans i))
2023                       (pop columns)
2024                     (aset rowspans i (1- (aref rowspans i)))
2025                     '(td)))
2026             (when (and (not (stringp column))
2027                        (or (memq (dom-tag column) '(td th))
2028                            (not column)))
2029               (when-let (span (dom-attr column 'rowspan))
2030                 (aset rowspans i (+ (aref rowspans i)
2031                                     (1- (string-to-number span)))))
2032               ;; Sanity check for invalid column-spans.
2033               (when (>= width-column (length widths))
2034                 (setq width-column 0))
2035               (setq width
2036                     (if column
2037                         (aref widths width-column)
2038                       (* 10 shr-table-separator-pixel-width)))
2039               (when (setq colspan (dom-attr column 'colspan))
2040                 (setq colspan (min (string-to-number colspan)
2041                                    ;; The colspan may be wrong, so
2042                                    ;; truncate it to the length of the
2043                                    ;; remaining columns.
2044                                    (- (length widths) i)))
2045                 (dotimes (j (1- colspan))
2046                   (setq width
2047                         (if (> (+ i 1 j) (1- (length widths)))
2048                             ;; If we have a colspan spec that's longer
2049                             ;; than the table is wide, just use the last
2050                             ;; width as the width.
2051                             (aref widths (1- (length widths)))
2052                           ;; Sum up the widths of the columns we're
2053                           ;; spanning.
2054                           (+ width
2055                              shr-table-separator-length
2056                              (aref widths (+ i 1 j))))))
2057                 (setq width-column (+ width-column (1- colspan))
2058                       colspan-count colspan
2059                       colspan-remaining colspan))
2060               (when column
2061                 (let ((data (shr-render-td column width fill)))
2062                   (if (and (not fill)
2063                            (> colspan-remaining 0))
2064                       (progn
2065                         (setq colspan-width (car data))
2066                         (let ((this-width (/ colspan-width colspan-count)))
2067                           (push (cons this-width (cadr data)) tds)
2068                           (setq colspan-remaining (1- colspan-remaining))))
2069                     (if (not fill)
2070                         (push (cons (car data) (cadr data)) tds)
2071                       (push data tds)))))
2072               (when (and colspan
2073                          (> colspan 1))
2074                 (dotimes (c (1- colspan))
2075                   (setq i (1+ i))
2076                   (push
2077                    (if fill
2078                        (list 0 0 -1 nil 1 nil nil)
2079                      '(0 . 0))
2080                    tds)))
2081               (setq i (1+ i)
2082                     width-column (1+ width-column))))
2083           (push (nreverse tds) trs))))
2084     (nreverse trs)))
2085
2086 (defun shr-pixel-buffer-width ()
2087   (if (not shr-use-fonts)
2088       (save-excursion
2089         (goto-char (point-min))
2090         (let ((max 0))
2091           (while (not (eobp))
2092             (end-of-line)
2093             (setq max (max max (current-column)))
2094             (forward-line 1))
2095           max))
2096     (if (get-buffer-window)
2097         (car (window-text-pixel-size nil (point-min) (point-max)))
2098       (save-window-excursion
2099         (set-window-buffer nil (current-buffer))
2100         (car (window-text-pixel-size nil (point-min) (point-max)))))))
2101
2102 (defun shr-render-td (dom width fill)
2103   (let ((cache (intern (format "shr-td-cache-%s-%s" width fill))))
2104     (or (dom-attr dom cache)
2105         (and fill
2106              (let (result)
2107                (dolist (attr (dom-attributes dom))
2108                  (let ((name (symbol-name (car attr))))
2109                    (when (string-match "shr-td-cache-\\([0-9]+\\)-nil" name)
2110                      (let ((cache-width (string-to-number
2111                                          (match-string 1 name))))
2112                        (when (and (>= cache-width width)
2113                                   (<= (car (cdr attr)) width))
2114                          (setq result (cdr attr)))))))
2115                result))
2116         (let ((result (shr-render-td-1 dom width fill)))
2117           (dom-set-attribute dom cache result)
2118           result))))
2119
2120 (defun shr-render-td-1 (dom width fill)
2121   (with-temp-buffer
2122     (let ((bgcolor (dom-attr dom 'bgcolor))
2123           (fgcolor (dom-attr dom 'fgcolor))
2124           (style (dom-attr dom 'style))
2125           (shr-stylesheet shr-stylesheet)
2126           (max-width 0)
2127           natural-width)
2128       (when style
2129         (setq style (and (string-match "color" style)
2130                          (shr-parse-style style))))
2131       (when bgcolor
2132         (setq style (nconc (list (cons 'background-color bgcolor))
2133                            style)))
2134       (when fgcolor
2135         (setq style (nconc (list (cons 'color fgcolor)) style)))
2136       (when style
2137         (setq shr-stylesheet (append style shr-stylesheet)))
2138       (let ((shr-internal-width width)
2139             (shr-indentation 0))
2140         (shr-descend dom))
2141       (save-window-excursion
2142         (set-window-buffer nil (current-buffer))
2143         (unless fill
2144           (setq natural-width
2145                 (or (dom-attr dom 'shr-td-cache-natural)
2146                     (let ((natural (max (shr-pixel-buffer-width)
2147                                         (shr-dom-max-natural-width dom 0))))
2148                       (dom-set-attribute dom 'shr-td-cache-natural natural)
2149                       natural))))
2150         (if (and natural-width
2151                  (<= natural-width width))
2152             (setq max-width natural-width)
2153           (let ((shr-internal-width width))
2154             (shr-fill-lines (point-min) (point-max))
2155             (setq max-width (shr-pixel-buffer-width)))))
2156       (goto-char (point-max))
2157       ;; Delete padding at the bottom of the TDs.
2158       (delete-region
2159        (point)
2160        (progn
2161          (skip-chars-backward " \t\n")
2162          (end-of-line)
2163          (point)))
2164       (goto-char (point-min))
2165       (list max-width
2166             natural-width
2167             (count-lines (point-min) (point-max))
2168             (split-string (buffer-string) "\n")
2169             (if (dom-attr dom 'colspan)
2170                 (string-to-number (dom-attr dom 'colspan))
2171               1)
2172             (cdr (assq 'color shr-stylesheet))
2173             (cdr (assq 'background-color shr-stylesheet))))))
2174
2175 (defun shr-dom-max-natural-width (dom max)
2176   (if (eq (dom-tag dom) 'table)
2177       (max max (or
2178                 (loop for line in (dom-attr dom 'shr-suggested-widths)
2179                       maximize (+
2180                                 shr-table-separator-length
2181                                 (loop for elem in line
2182                                       summing
2183                                       (+ (cdr elem)
2184                                          (* 2 shr-table-separator-length)))))
2185                 0))
2186     (dolist (child (dom-children dom))
2187       (unless (stringp child)
2188         (setq max (max (shr-dom-max-natural-width child max)))))
2189     max))
2190
2191 (defun shr-buffer-width ()
2192   (goto-char (point-min))
2193   (let ((max 0))
2194     (while (not (eobp))
2195       (end-of-line)
2196       (setq max (max max (current-column)))
2197       (forward-line 1))
2198     max))
2199
2200 (defun shr-pro-rate-columns (columns)
2201   (let ((total-percentage 0)
2202         (widths (make-vector (length columns) 0)))
2203     (dotimes (i (length columns))
2204       (setq total-percentage (+ total-percentage (aref columns i))))
2205     (setq total-percentage (/ 1.0 total-percentage))
2206     (dotimes (i (length columns))
2207       (aset widths i (max (truncate (* (aref columns i)
2208                                        total-percentage
2209                                        (- shr-internal-width
2210                                           (* (1+ (length columns))
2211                                              shr-table-separator-pixel-width))))
2212                           10)))
2213     widths))
2214
2215 ;; Return a summary of the number and shape of the TDs in the table.
2216 (defun shr-column-specs (dom)
2217   (let ((columns (make-vector (shr-max-columns dom) 1)))
2218     (dolist (row (dom-non-text-children dom))
2219       (when (eq (dom-tag row) 'tr)
2220         (let ((i 0))
2221           (dolist (column (dom-non-text-children row))
2222             (when (memq (dom-tag column) '(td th))
2223               (let ((width (dom-attr column 'width)))
2224                 (when (and width
2225                            (string-match "\\([0-9]+\\)%" width)
2226                            (not (zerop (setq width (string-to-number
2227                                                     (match-string 1 width))))))
2228                   (aset columns i (/ width 100.0))))
2229               (setq i (1+ i)))))))
2230     columns))
2231
2232 (defun shr-count (dom elem)
2233   (let ((i 0))
2234     (dolist (sub (dom-children dom))
2235       (when (and (not (stringp sub))
2236                  (eq (dom-tag sub) elem))
2237         (setq i (1+ i))))
2238     i))
2239
2240 (defun shr-max-columns (dom)
2241   (let ((max 0))
2242     (dolist (row (dom-children dom))
2243       (when (and (not (stringp row))
2244                  (eq (dom-tag row) 'tr))
2245         (setq max (max max (+ (shr-count row 'td)
2246                               (shr-count row 'th))))))
2247     max))
2248
2249 (provide 'shr)
2250
2251 ;;; shr.el ends here