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-blank-lines-at-the-end start (point))
 278     (when shr-warning
 279       (message "%s" shr-warning))))
 280
 281 (defun shr--remove-blank-lines-at-the-end (start end)
 282   (save-restriction
 283     (save-excursion
 284       (current-buffer)
 285       (narrow-to-region start end)
 286       (goto-char end)
 287       (when (and (re-search-backward "[^ \n]" nil t)
 288                  (not (eobp)))
 289         (forward-char 1)
 290         (delete-region (point) (point-max))
 291         (unless (bolp)
 292           (insert "\n"))))))
 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 ;;; Tag-specific rendering rules.
1162
1163 (defun shr-tag-html (dom)
1164   (let ((dir (dom-attr dom 'dir)))
1165     (cond
1166      ((equal dir "ltr")
1167       (setq bidi-paragraph-direction 'left-to-right))
1168      ((equal dir "rtl")
1169       (setq bidi-paragraph-direction 'right-to-left))
1170      ((equal dir "auto")
1171       (setq bidi-paragraph-direction nil))))
1172   (shr-generic dom))
1173
1174 (defun shr-tag-body (dom)
1175   (let* ((start (point))
1176          (fgcolor (or (dom-attr dom 'fgcolor) (dom-attr dom 'text)))
1177          (bgcolor (dom-attr dom 'bgcolor))
1178          (shr-stylesheet (list (cons 'color fgcolor)
1179                                (cons 'background-color bgcolor))))
1180     (shr-generic dom)
1181     (shr-colorize-region start (point) fgcolor bgcolor)))
1182
1183 (defun shr-tag-style (_dom)
1184   )
1185
1186 (defun shr-tag-script (_dom)
1187   )
1188
1189 (defun shr-tag-comment (_dom)
1190   )
1191
1192 (defun shr-dom-to-xml (dom)
1193   (with-temp-buffer
1194     (shr-dom-print dom)
1195     (buffer-string)))
1196
1197 (defun shr-dom-print (dom)
1198   "Convert DOM into a string containing the xml representation."
1199   (insert (format "<%s" (dom-tag dom)))
1200   (dolist (attr (dom-attributes dom))
1201     ;; Ignore attributes that start with a colon because they are
1202     ;; private elements.
1203     (unless (= (aref (format "%s" (car attr)) 0) ?:)
1204       (insert (format " %s=\"%s\"" (car attr) (cdr attr)))))
1205   (insert ">")
1206   (let (url)
1207     (dolist (elem (dom-children dom))
1208       (cond
1209        ((stringp elem)
1210         (insert elem))
1211        ((eq (dom-tag elem) 'comment)
1212         )
1213        ((or (not (eq (dom-tag elem) 'image))
1214             ;; Filter out blocked elements inside the SVG image.
1215             (not (setq url (dom-attr elem ':xlink:href)))
1216             (not shr-blocked-images)
1217             (not (string-match shr-blocked-images url)))
1218         (insert " ")
1219         (shr-dom-print elem)))))
1220   (insert (format "</%s>" (dom-tag dom))))
1221
1222 (defun shr-tag-svg (dom)
1223   (when (and (image-type-available-p 'svg)
1224              (not shr-inhibit-images)
1225              (dom-attr dom 'width)
1226              (dom-attr dom 'height))
1227     (funcall shr-put-image-function (list (shr-dom-to-xml dom) 'image/svg+xml)
1228              "SVG Image")))
1229
1230 (defun shr-tag-sup (dom)
1231   (let ((start (point)))
1232     (shr-generic dom)
1233     (put-text-property start (point) 'display '(raise 0.5))))
1234
1235 (defun shr-tag-sub (dom)
1236   (let ((start (point)))
1237     (shr-generic dom)
1238     (put-text-property start (point) 'display '(raise -0.5))))
1239
1240 (defun shr-tag-label (dom)
1241   (shr-generic dom)
1242   (shr-ensure-paragraph))
1243
1244 (defun shr-tag-p (dom)
1245   (shr-ensure-paragraph)
1246   (shr-generic dom)
1247   (shr-ensure-paragraph))
1248
1249 (defun shr-tag-div (dom)
1250   (shr-ensure-paragraph)
1251   (shr-generic dom)
1252   (shr-ensure-newline))
1253
1254 (defun shr-tag-s (dom)
1255   (shr-fontize-dom dom 'shr-strike-through))
1256
1257 (defun shr-tag-b (dom)
1258   (shr-fontize-dom dom 'bold))
1259
1260 (defun shr-tag-i (dom)
1261   (shr-fontize-dom dom 'italic))
1262
1263 (defun shr-tag-em (dom)
1264   (shr-fontize-dom dom 'italic))
1265
1266 (defun shr-tag-strong (dom)
1267   (shr-fontize-dom dom 'bold))
1268
1269 (defun shr-tag-u (dom)
1270   (shr-fontize-dom dom 'underline))
1271
1272 (defun shr-tag-tt (dom)
1273   (let ((shr-current-font 'default))
1274     (shr-generic dom)))
1275
1276 (defun shr-tag-ins (cont)
1277   (let* ((start (point))
1278          (color "green")
1279          (shr-stylesheet (nconc (list (cons 'color color))
1280                                 shr-stylesheet)))
1281     (shr-generic cont)
1282     (shr-colorize-region start (point) color
1283                          (cdr (assq 'background-color shr-stylesheet)))))
1284
1285 (defun shr-tag-del (cont)
1286   (let* ((start (point))
1287          (color "red")
1288          (shr-stylesheet (nconc (list (cons 'color color))
1289                                 shr-stylesheet)))
1290     (shr-fontize-dom cont 'shr-strike-through)
1291     (shr-colorize-region start (point) color
1292                          (cdr (assq 'background-color shr-stylesheet)))))
1293
1294 (defun shr-parse-style (style)
1295   (when style
1296     (save-match-data
1297       (when (string-match "\n" style)
1298         (setq style (replace-match " " t t style))))
1299     (let ((plist nil))
1300       (dolist (elem (split-string style ";"))
1301         (when elem
1302           (setq elem (split-string elem ":"))
1303           (when (and (car elem)
1304                      (cadr elem))
1305             (let ((name (replace-regexp-in-string "^ +\\| +$" "" (car elem)))
1306                   (value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem))))
1307               (when (string-match " *!important\\'" value)
1308                 (setq value (substring value 0 (match-beginning 0))))
1309               (unless (equal value "inherit")
1310                 (push (cons (intern name obarray)
1311                             value)
1312                       plist))))))
1313       plist)))
1314
1315 (defun shr-tag-base (dom)
1316   (when-let (base (dom-attr dom 'href))
1317     (setq shr-base (shr-parse-base base)))
1318   (shr-generic dom))
1319
1320 (defun shr-tag-a (dom)
1321   (let ((url (dom-attr dom 'href))
1322         (title (dom-attr dom 'title))
1323         (start (point))
1324         shr-start)
1325     (shr-generic dom)
1326     (when (and shr-target-id
1327                (equal (dom-attr dom 'name) shr-target-id))
1328       ;; We have a zero-length <a name="foo"> element, so just
1329       ;; insert...  something.
1330       (when (= start (point))
1331         (shr-ensure-newline)
1332         (insert " "))
1333       (put-text-property start (1+ start) 'shr-target-id shr-target-id))
1334     (when url
1335       (shr-urlify (or shr-start start) (shr-expand-url url) title))))
1336
1337 (defun shr-tag-object (dom)
1338   (unless shr-inhibit-images
1339     (let ((start (point))
1340           url multimedia image)
1341       (when-let (type (dom-attr dom 'type))
1342         (when (string-match "\\`image/svg" type)
1343           (setq url (dom-attr dom 'data)
1344                 image t)))
1345       (dolist (child (dom-non-text-children dom))
1346         (cond
1347          ((eq (dom-tag child) 'embed)
1348           (setq url (or url (dom-attr child 'src))
1349                 multimedia t))
1350          ((and (eq (dom-tag child) 'param)
1351                (equal (dom-attr child 'name) "movie"))
1352           (setq url (or url (dom-attr child 'value))
1353                 multimedia t))))
1354       (when url
1355         (cond
1356          (image
1357           (shr-tag-img dom url)
1358           (setq dom nil))
1359          (multimedia
1360           (shr-insert " [multimedia] ")
1361           (shr-urlify start (shr-expand-url url)))))
1362       (when dom
1363         (shr-generic dom)))))
1364
1365 (defcustom shr-prefer-media-type-alist '(("webm" . 1.0)
1366                                          ("ogv"  . 1.0)
1367                                          ("ogg"  . 1.0)
1368                                          ("opus" . 1.0)
1369                                          ("flac" . 0.9)
1370                                          ("wav"  . 0.5))
1371   "Preferences for media types.
1372 The key element should be a regexp matched against the type of the source or
1373 url if no type is specified.  The value should be a float in the range 0.0 to
1374 1.0.  Media elements with higher value are preferred."
1375   :version "24.4"
1376   :group 'shr
1377   :type '(alist :key-type regexp :value-type float))
1378
1379 (defun shr--get-media-pref (elem)
1380   "Determine the preference for ELEM.
1381 The preference is a float determined from `shr-prefer-media-type'."
1382   (let ((type (dom-attr elem 'type))
1383         (p 0.0))
1384     (unless type
1385       (setq type (dom-attr elem 'src)))
1386     (when type
1387       (dolist (pref shr-prefer-media-type-alist)
1388         (when (and
1389                (> (cdr pref) p)
1390                (string-match-p (car pref) type))
1391           (setq p (cdr pref)))))
1392     p))
1393
1394 (defun shr--extract-best-source (dom &optional url pref)
1395   "Extract the best `:src' property from <source> blocks in DOM."
1396   (setq pref (or pref -1.0))
1397   (let (new-pref)
1398     (dolist (elem (dom-non-text-children dom))
1399       (when (and (eq (dom-tag elem) 'source)
1400                  (< pref
1401                     (setq new-pref
1402                           (shr--get-media-pref elem))))
1403         (setq pref new-pref
1404               url (dom-attr elem 'src))
1405         ;; libxml's html parser isn't HTML5 compliant and non terminated
1406         ;; source tags might end up as children.  So recursion it is...
1407         (dolist (child (dom-non-text-children elem))
1408           (when (eq (dom-tag child) 'source)
1409             (let ((ret (shr--extract-best-source (list child) url pref)))
1410               (when (< pref (cdr ret))
1411                 (setq url (car ret)
1412                       pref (cdr ret)))))))))
1413   (cons url pref))
1414
1415 (defun shr-tag-video (dom)
1416   (let ((image (dom-attr dom 'poster))
1417         (url (dom-attr dom 'src))
1418         (start (point)))
1419     (unless url
1420       (setq url (car (shr--extract-best-source dom))))
1421     (if (> (length image) 0)
1422         (shr-tag-img nil image)
1423       (shr-insert " [video] "))
1424     (shr-urlify start (shr-expand-url url))))
1425
1426 (defun shr-tag-audio (dom)
1427   (let ((url (dom-attr dom 'src))
1428         (start (point)))
1429     (unless url
1430       (setq url (car (shr--extract-best-source dom))))
1431     (shr-insert " [audio] ")
1432     (shr-urlify start (shr-expand-url url))))
1433
1434 (defun shr-tag-img (dom &optional url)
1435   (when (or url
1436             (and dom
1437                  (> (length (dom-attr dom 'src)) 0)))
1438     (when (> (current-column) 0)
1439       (insert "\n"))
1440     (let ((alt (dom-attr dom 'alt))
1441           (width (shr-string-number (dom-attr dom 'width)))
1442           (height (shr-string-number (dom-attr dom 'height)))
1443           (url (shr-expand-url (or url (dom-attr dom 'src)))))
1444       (let ((start (point-marker)))
1445         (when (zerop (length alt))
1446           (setq alt "*"))
1447         (cond
1448          ((or (member (dom-attr dom 'height) '("0" "1"))
1449               (member (dom-attr dom 'width) '("0" "1")))
1450           ;; Ignore zero-sized or single-pixel images.
1451           )
1452          ((and (not shr-inhibit-images)
1453                (string-match "\\`data:" url))
1454           (let ((image (shr-image-from-data (substring url (match-end 0)))))
1455             (if image
1456                 (funcall shr-put-image-function image alt
1457                          (list :width width :height height))
1458               (insert alt))))
1459          ((and (not shr-inhibit-images)
1460                (string-match "\\`cid:" url))
1461           (let ((url (substring url (match-end 0)))
1462                 image)
1463             (if (or (not shr-content-function)
1464                     (not (setq image (funcall shr-content-function url))))
1465                 (insert alt)
1466               (funcall shr-put-image-function image alt
1467                        (list :width width :height height)))))
1468          ((or shr-inhibit-images
1469               (and shr-blocked-images
1470                    (string-match shr-blocked-images url)))
1471           (setq shr-start (point))
1472           (shr-insert alt))
1473          ((and (not shr-ignore-cache)
1474                (url-is-cached (shr-encode-url url)))
1475           (funcall shr-put-image-function (shr-get-image-data url) alt
1476                    (list :width width :height height)))
1477          (t
1478           (when (and shr-ignore-cache
1479                      (url-is-cached (shr-encode-url url)))
1480             (let ((file (url-cache-create-filename (shr-encode-url url))))
1481               (when (file-exists-p file)
1482                 (delete-file file))))
1483           (when (image-type-available-p 'svg)
1484             (insert-image
1485              (shr-make-placeholder-image dom)
1486              (or alt "")))
1487           (insert " ")
1488           (url-queue-retrieve
1489            (shr-encode-url url) 'shr-image-fetched
1490            (list (current-buffer) start (set-marker (make-marker) (point))
1491                  (list :width width :height height))
1492            t t)))
1493         (when (zerop shr-table-depth) ;; We are not in a table.
1494           (put-text-property start (point) 'keymap shr-image-map)
1495           (put-text-property start (point) 'shr-alt alt)
1496           (put-text-property start (point) 'image-url url)
1497           (put-text-property start (point) 'image-displayer
1498                              (shr-image-displayer shr-content-function))
1499           (put-text-property start (point) 'help-echo
1500                              (shr-fill-text
1501                               (or (dom-attr dom 'title) alt))))))))
1502
1503 (defun shr-string-number (string)
1504   (if (null string)
1505       nil
1506     (setq string (replace-regexp-in-string "[^0-9]" "" string))
1507     (if (zerop (length string))
1508         nil
1509       (string-to-number string))))
1510
1511 (defun shr-make-placeholder-image (dom)
1512   (let* ((edges (and
1513                  (get-buffer-window (current-buffer))
1514                  (window-inside-pixel-edges
1515                   (get-buffer-window (current-buffer)))))
1516          (scaling (image-compute-scaling-factor image-scaling-factor))
1517          (width (truncate
1518                  (* (or (shr-string-number (dom-attr dom 'width)) 100)
1519                     scaling)))
1520          (height (truncate
1521                   (* (or (shr-string-number (dom-attr dom 'height)) 100)
1522                      scaling)))
1523          (max-width
1524           (and edges
1525                (truncate (* shr-max-image-proportion
1526                             (- (nth 2 edges) (nth 0 edges))))))
1527          (max-height (and edges
1528                           (truncate (* shr-max-image-proportion
1529                                        (- (nth 3 edges) (nth 1 edges))))))
1530          svg image)
1531     (when (and max-width
1532                (> width max-width))
1533       (setq height (truncate (* (/ (float max-width) width) height))
1534             width max-width))
1535     (when (and max-height
1536                (> height max-height))
1537       (setq width (truncate (* (/ (float max-height) height) width))
1538             height max-height))
1539     (setq svg (svg-create width height))
1540     (svg-gradient svg "background" 'linear '((0 . "#b0b0b0") (100 . "#808080")))
1541     (svg-rectangle svg 0 0 width height :gradient "background"
1542                    :stroke-width 2 :stroke-color "black")
1543     (let ((image (svg-image svg)))
1544       (setf (image-property image :ascent) 100)
1545       image)))
1546
1547 (defun shr-tag-pre (dom)
1548   (let ((shr-folding-mode 'none)
1549         (shr-current-font 'default))
1550     (shr-ensure-newline)
1551     (shr-generic dom)
1552     (shr-ensure-newline)))
1553
1554 (defun shr-tag-blockquote (dom)
1555   (shr-ensure-paragraph)
1556   (let ((start (point))
1557         (shr-indentation (+ shr-indentation
1558                             (* 4 shr-table-separator-pixel-width))))
1559     (shr-generic dom)
1560     (shr-ensure-paragraph)
1561     (shr-mark-fill start)))
1562
1563 (defun shr-tag-dl (dom)
1564   (shr-ensure-paragraph)
1565   (shr-generic dom)
1566   (shr-ensure-paragraph))
1567
1568 (defun shr-tag-dt (dom)
1569   (shr-ensure-newline)
1570   (shr-generic dom)
1571   (shr-ensure-newline))
1572
1573 (defun shr-tag-dd (dom)
1574   (shr-ensure-newline)
1575   (let ((shr-indentation (+ shr-indentation
1576                             (* 4 shr-table-separator-pixel-width))))
1577     (shr-generic dom)))
1578
1579 (defun shr-tag-ul (dom)
1580   (shr-ensure-paragraph)
1581   (let ((shr-list-mode 'ul))
1582     (shr-generic dom))
1583   (shr-ensure-paragraph))
1584
1585 (defun shr-tag-ol (dom)
1586   (shr-ensure-paragraph)
1587   (let ((shr-list-mode 1))
1588     (shr-generic dom))
1589   (shr-ensure-paragraph))
1590
1591 (defun shr-tag-li (dom)
1592   (shr-ensure-newline)
1593   (let ((start (point)))
1594     (let* ((bullet
1595             (if (numberp shr-list-mode)
1596                 (prog1
1597                     (format "%d " shr-list-mode)
1598                   (setq shr-list-mode (1+ shr-list-mode)))
1599               (car shr-internal-bullet)))
1600            (width (if (numberp shr-list-mode)
1601                       (shr-string-pixel-width bullet)
1602                     (cdr shr-internal-bullet))))
1603       (insert bullet)
1604       (shr-mark-fill start)
1605       (let ((shr-indentation (+ shr-indentation width)))
1606         (put-text-property start (1+ start)
1607                            'shr-continuation-indentation shr-indentation)
1608         (put-text-property start (1+ start) 'shr-prefix-length (length bullet))
1609         (shr-generic dom)))))
1610
1611 (defun shr-mark-fill (start)
1612   ;; We may not have inserted any text to fill.
1613   (unless (= start (point))
1614     (put-text-property start (1+ start)
1615                        'shr-indentation shr-indentation)))
1616
1617 (defun shr-tag-br (dom)
1618   (when (and (not (bobp))
1619              ;; Only add a newline if we break the current line, or
1620              ;; the previous line isn't a blank line.
1621              (or (not (bolp))
1622                  (and (> (- (point) 2) (point-min))
1623                       (not (= (char-after (- (point) 2)) ?\n)))))
1624     (insert "\n"))
1625   (shr-generic dom))
1626
1627 (defun shr-tag-span (dom)
1628   (shr-generic dom))
1629
1630 (defun shr-tag-h1 (dom)
1631   (shr-heading dom (if shr-use-fonts
1632                        '(variable-pitch (:height 1.3 :weight bold))
1633                      'bold)))
1634
1635 (defun shr-tag-h2 (dom)
1636   (shr-heading dom 'bold))
1637
1638 (defun shr-tag-h3 (dom)
1639   (shr-heading dom 'italic))
1640
1641 (defun shr-tag-h4 (dom)
1642   (shr-heading dom))
1643
1644 (defun shr-tag-h5 (dom)
1645   (shr-heading dom))
1646
1647 (defun shr-tag-h6 (dom)
1648   (shr-heading dom))
1649
1650 (defun shr-tag-hr (_dom)
1651   (shr-ensure-newline)
1652   (insert (make-string (if (not shr-use-fonts)
1653                            shr-internal-width
1654                          (1+ (/ shr-internal-width
1655                                 shr-table-separator-pixel-width)))
1656                        shr-hr-line)
1657           "\n"))
1658
1659 (defun shr-tag-title (dom)
1660   (shr-heading dom 'bold 'underline))
1661
1662 (defun shr-tag-font (dom)
1663   (let* ((start (point))
1664          (color (dom-attr dom 'color))
1665          (shr-stylesheet (nconc (list (cons 'color color))
1666                                 shr-stylesheet)))
1667     (shr-generic dom)
1668     (when color
1669       (shr-colorize-region start (point) color
1670                            (cdr (assq 'background-color shr-stylesheet))))))
1671
1672 (defun shr-tag-bdo (dom)
1673   (let* ((direction (dom-attr dom 'dir))
1674          (char (cond
1675                 ((equal direction "ltr")
1676                  #x202d)                ; LRO
1677                 ((equal direction "rtl")
1678                  #x202e))))             ; RLO
1679     (when char
1680       (insert #x2068 char))             ; FSI + LRO/RLO
1681     (shr-generic dom)
1682     (when char
1683       (insert #x202c #x2069))))         ; PDF + PDI
1684
1685 (defun shr-tag-bdi (dom)
1686   (insert #x2068)                       ; FSI
1687   (shr-generic dom)
1688   (insert #x2069))                      ; PDI
1689
1690 ;;; Table rendering algorithm.
1691
1692 ;; Table rendering is the only complicated thing here.  We do this by
1693 ;; first counting how many TDs there are in each TR, and registering
1694 ;; how wide they think they should be ("width=45%", etc).  Then we
1695 ;; render each TD separately (this is done in temporary buffers, so
1696 ;; that we can use all the rendering machinery as if we were in the
1697 ;; main buffer).  Now we know how much space each TD really takes, so
1698 ;; we then render everything again with the new widths, and finally
1699 ;; insert all these boxes into the main buffer.
1700 (defun shr-tag-table-1 (dom)
1701   (setq dom (or (dom-child-by-tag dom 'tbody) dom))
1702   (let* ((shr-inhibit-images t)
1703          (shr-table-depth (1+ shr-table-depth))
1704          (shr-kinsoku-shorten t)
1705          ;; Find all suggested widths.
1706          (columns (shr-column-specs dom))
1707          ;; Compute how many pixels wide each TD should be.
1708          (suggested-widths (shr-pro-rate-columns columns))
1709          ;; Do a "test rendering" to see how big each TD is (this can
1710          ;; be smaller (if there's little text) or bigger (if there's
1711          ;; unbreakable text).
1712          (elems (or (dom-attr dom 'shr-suggested-widths)
1713                     (shr-make-table dom suggested-widths nil
1714                                     'shr-suggested-widths)))
1715          (sketch (loop for line in elems
1716                        collect (mapcar #'car line)))
1717          (natural (loop for line in elems
1718                         collect (mapcar #'cdr line)))
1719          (sketch-widths (shr-table-widths sketch natural suggested-widths)))
1720     ;; This probably won't work very well.
1721     (when (> (+ (loop for width across sketch-widths
1722                       summing (1+ width))
1723                 shr-indentation shr-table-separator-pixel-width)
1724              (frame-width))
1725       (setq truncate-lines t))
1726     ;; Then render the table again with these new "hard" widths.
1727     (shr-insert-table (shr-make-table dom sketch-widths t) sketch-widths)))
1728
1729 (defun shr-table-body (dom)
1730   (let ((tbodies (seq-filter (lambda (child)
1731                                (eq (dom-tag child) 'tbody))
1732                              (dom-non-text-children dom))))
1733     (cond
1734      ((null tbodies)
1735       dom)
1736      ((= (length tbodies) 1)
1737       (car tbodies))
1738      (t
1739       ;; Table with multiple tbodies.  Convert into a single tbody.
1740       `(tbody nil ,@(cl-reduce 'append
1741                                (mapcar 'dom-non-text-children tbodies)))))))
1742
1743 (defun shr-tag-table (dom)
1744   (shr-ensure-paragraph)
1745   (let* ((caption (dom-children (dom-child-by-tag dom 'caption)))
1746          (header (dom-non-text-children (dom-child-by-tag dom 'thead)))
1747          (body (dom-non-text-children (shr-table-body dom)))
1748          (footer (dom-non-text-children (dom-child-by-tag dom 'tfoot)))
1749          (bgcolor (dom-attr dom 'bgcolor))
1750          (start (point))
1751          (shr-stylesheet (nconc (list (cons 'background-color bgcolor))
1752                                 shr-stylesheet))
1753          (nheader (if header (shr-max-columns header)))
1754          (nbody (if body (shr-max-columns body) 0))
1755          (nfooter (if footer (shr-max-columns footer))))
1756     (if (and (not caption)
1757              (not header)
1758              (not (dom-child-by-tag dom 'tbody))
1759              (not (dom-child-by-tag dom 'tr))
1760              (not footer))
1761         ;; The table is totally invalid and just contains random junk.
1762         ;; Try to output it anyway.
1763         (shr-generic dom)
1764       ;; It's a real table, so render it.
1765       (if (dom-attr dom 'shr-fixed-table)
1766           (shr-tag-table-1 dom)
1767         ;; Only fix up the table once.
1768         (let ((table
1769                (nconc
1770                 (list 'table nil)
1771                 (if caption `((tr nil (td nil ,@caption))))
1772                 (cond
1773                  (header
1774                   (if footer
1775                       ;; header + body + footer
1776                       (if (= nheader nbody)
1777                           (if (= nbody nfooter)
1778                               `((tr nil (td nil (table nil
1779                                                        (tbody nil ,@header
1780                                                               ,@body ,@footer)))))
1781                             (nconc `((tr nil (td nil (table nil
1782                                                             (tbody nil ,@header
1783                                                                    ,@body)))))
1784                                    (if (= nfooter 1)
1785                                        footer
1786                                      `((tr nil (td nil (table
1787                                                         nil (tbody
1788                                                              nil ,@footer))))))))
1789                         (nconc `((tr nil (td nil (table nil (tbody
1790                                                              nil ,@header)))))
1791                                (if (= nbody nfooter)
1792                                    `((tr nil (td nil (table
1793                                                       nil (tbody nil ,@body
1794                                                                  ,@footer)))))
1795                                  (nconc `((tr nil (td nil (table
1796                                                            nil (tbody nil
1797                                                                       ,@body)))))
1798                                         (if (= nfooter 1)
1799                                             footer
1800                                           `((tr nil (td nil (table
1801                                                              nil
1802                                                              (tbody
1803                                                               nil
1804                                                               ,@footer))))))))))
1805                     ;; header + body
1806                     (if (= nheader nbody)
1807                         `((tr nil (td nil (table nil (tbody nil ,@header
1808                                                             ,@body)))))
1809                       (if (= nheader 1)
1810                           `(,@header (tr nil (td nil (table
1811                                                       nil (tbody nil ,@body)))))
1812                         `((tr nil (td nil (table nil (tbody nil ,@header))))
1813                           (tr nil (td nil (table nil (tbody nil ,@body)))))))))
1814                  (footer
1815                   ;; body + footer
1816                   (if (= nbody nfooter)
1817                       `((tr nil (td nil (table
1818                                          nil (tbody nil ,@body ,@footer)))))
1819                     (nconc `((tr nil (td nil (table nil (tbody nil ,@body)))))
1820                            (if (= nfooter 1)
1821                                footer
1822                              `((tr nil (td nil (table
1823                                                 nil (tbody nil ,@footer)))))))))
1824                  (caption
1825                   `((tr nil (td nil (table nil (tbody nil ,@body))))))
1826                  (body)))))
1827           (dom-set-attribute table 'shr-fixed-table t)
1828           (setcdr dom (cdr table))
1829           (shr-tag-table-1 dom))))
1830     (when bgcolor
1831       (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet))
1832                            bgcolor))
1833     ;; Finally, insert all the images after the table.  The Emacs buffer
1834     ;; model isn't strong enough to allow us to put the images actually
1835     ;; into the tables.
1836     (when (zerop shr-table-depth)
1837       (save-excursion
1838         (shr-expand-alignments start (point)))
1839       (dolist (elem (dom-by-tag dom 'object))
1840         (shr-tag-object elem))
1841       (dolist (elem (dom-by-tag dom 'img))
1842         (shr-tag-img elem)))))
1843
1844 (defun shr-insert-table (table widths)
1845   (let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet))
1846                           "collapse"))
1847          (shr-table-separator-length (if collapse 0 1))
1848          (shr-table-vertical-line (if collapse "" shr-table-vertical-line))
1849          (start (point)))
1850     (setq shr-table-id (1+ shr-table-id))
1851     (unless collapse
1852       (shr-insert-table-ruler widths))
1853     (dolist (row table)
1854       (let ((start (point))
1855             (align 0)
1856             (column-number 0)
1857             (height (let ((max 0))
1858                       (dolist (column row)
1859                         (setq max (max max (nth 2 column))))
1860                       max)))
1861         (dotimes (i (max height 1))
1862           (shr-indent)
1863           (insert shr-table-vertical-line "\n"))
1864         (dolist (column row)
1865           (when (> (nth 2 column) -1)
1866             (goto-char start)
1867             ;; Sum up all the widths from the column.  (There may be
1868             ;; more than one if this is a "colspan" column.)
1869             (dotimes (i (nth 4 column))
1870               ;; The colspan directive may be wrong and there may not be
1871               ;; that number of columns.
1872               (when (<= column-number (1- (length widths)))
1873                 (setq align (+ align
1874                                (aref widths column-number)
1875                                (* 2 shr-table-separator-pixel-width))))
1876               (setq column-number (1+ column-number)))
1877             (let ((lines (nth 3 column))
1878                   (pixel-align (if (not shr-use-fonts)
1879                                    (* align (frame-char-width))
1880                                  align)))
1881               (dolist (line lines)
1882                 (end-of-line)
1883                 (let ((start (point))
1884                       (background (and (> (length line) 0)
1885                                        (shr-face-background
1886                                         (get-text-property
1887                                          (1- (length line)) 'face line))))
1888                       (space (propertize
1889                               " "
1890                               'display `(space :align-to (,pixel-align))
1891                               'shr-table-indent shr-table-id)))
1892                   (when background
1893                     (setq space (propertize space 'face background)))
1894                   (insert line space shr-table-vertical-line)
1895                   (shr-colorize-region
1896                    start (1- (point)) (nth 5 column) (nth 6 column)))
1897                 (forward-line 1))
1898               ;; Add blank lines at padding at the bottom of the TD,
1899               ;; possibly.
1900               (dotimes (i (- height (length lines)))
1901                 (end-of-line)
1902                 (let ((start (point)))
1903                   (insert (propertize " "
1904                                       'display `(space :align-to (,pixel-align))
1905                                       'shr-table-indent shr-table-id)
1906                           shr-table-vertical-line)
1907                   (shr-colorize-region
1908                    start (1- (point)) (nth 5 column) (nth 6 column)))
1909                 (forward-line 1))))))
1910       (unless collapse
1911         (shr-insert-table-ruler widths)))
1912     (unless (= start (point))
1913       (put-text-property start (1+ start) 'shr-table-id shr-table-id))))
1914
1915 (defun shr-face-background (face)
1916   (and (consp face)
1917        (or (and (plist-get face :background)
1918                 (list :background (plist-get face :background)))
1919            (let ((background nil))
1920              (dolist (elem face)
1921                (when (and (consp elem)
1922                           (eq (car elem) :background)
1923                           (not background))
1924                  (setq background (cadr elem))))
1925              (and background
1926                   (list :background background))))))
1927
1928 (defun shr-expand-alignments (start end)
1929   (while (< (setq start (next-single-property-change
1930                          start 'shr-table-id nil end))
1931             end)
1932     (goto-char start)
1933     (let* ((shr-use-fonts t)
1934            (id (get-text-property (point) 'shr-table-id))
1935            (base (shr-pixel-column))
1936            elem)
1937       (when id
1938         (save-excursion
1939           (while (setq elem (text-property-any
1940                              (point) end 'shr-table-indent id))
1941             (goto-char elem)
1942             (let ((align (get-text-property (point) 'display)))
1943               (put-text-property (point) (1+ (point)) 'display
1944                                  `(space :align-to (,(+ (car (nth 2 align))
1945                                                         base)))))
1946             (forward-char 1)))))
1947     (setq start (1+ start))))
1948
1949 (defun shr-insert-table-ruler (widths)
1950   (when shr-table-horizontal-line
1951     (when (and (bolp)
1952                (> shr-indentation 0))
1953       (shr-indent))
1954     (insert shr-table-corner)
1955     (let ((total-width 0))
1956       (dotimes (i (length widths))
1957         (setq total-width (+ total-width (aref widths i)
1958                              (* shr-table-separator-pixel-width 2)))
1959         (insert (make-string (1+ (/ (aref widths i)
1960                                     shr-table-separator-pixel-width))
1961                              shr-table-horizontal-line)
1962                 (propertize " "
1963                             'display `(space :align-to (,total-width))
1964                             'shr-table-indent shr-table-id)
1965                 shr-table-corner)))
1966     (insert "\n")))
1967
1968 (defun shr-table-widths (table natural-table suggested-widths)
1969   (let* ((length (length suggested-widths))
1970          (widths (make-vector length 0))
1971          (natural-widths (make-vector length 0)))
1972     (dolist (row table)
1973       (let ((i 0))
1974         (dolist (column row)
1975           (aset widths i (max (aref widths i) column))
1976           (setq i (1+ i)))))
1977     (dolist (row natural-table)
1978       (let ((i 0))
1979         (dolist (column row)
1980           (aset natural-widths i (max (aref natural-widths i) column))
1981           (setq i (1+ i)))))
1982     (let ((extra (- (apply '+ (append suggested-widths nil))
1983                     (apply '+ (append widths nil))
1984                     (* shr-table-separator-pixel-width (1+ (length widths)))))
1985           (expanded-columns 0))
1986       ;; We have extra, unused space, so divide this space amongst the
1987       ;; columns.
1988       (when (> extra 0)
1989         ;; If the natural width is wider than the rendered width, we
1990         ;; want to allow the column to expand.
1991         (dotimes (i length)
1992           (when (> (aref natural-widths i) (aref widths i))
1993             (setq expanded-columns (1+ expanded-columns))))
1994         (dotimes (i length)
1995           (when (> (aref natural-widths i) (aref widths i))
1996             (aset widths i (min
1997                             (aref natural-widths i)
1998                             (+ (/ extra expanded-columns)
1999                                (aref widths i))))))))
2000     widths))
2001
2002 (defun shr-make-table (dom widths &optional fill storage-attribute)
2003   (or (cadr (assoc (list dom widths fill) shr-content-cache))
2004       (let ((data (shr-make-table-1 dom widths fill)))
2005         (push (list (list dom widths fill) data)
2006               shr-content-cache)
2007         (when storage-attribute
2008           (dom-set-attribute dom storage-attribute data))
2009         data)))
2010
2011 (defun shr-make-table-1 (dom widths &optional fill)
2012   (let ((trs nil)
2013         (rowspans (make-vector (length widths) 0))
2014         (colspan-remaining 0)
2015         colspan-width colspan-count
2016         width colspan)
2017     (dolist (row (dom-non-text-children dom))
2018       (when (eq (dom-tag row) 'tr)
2019         (let ((tds nil)
2020               (columns (dom-non-text-children row))
2021               (i 0)
2022               (width-column 0)
2023               column)
2024           (while (< i (length widths))
2025             ;; If we previously had a rowspan definition, then that
2026             ;; means that we now have a "missing" td/th element here.
2027             ;; So just insert a dummy, empty one to (sort of) emulate
2028             ;; rowspan.
2029             (setq column
2030                   (if (zerop (aref rowspans i))
2031                       (pop columns)
2032                     (aset rowspans i (1- (aref rowspans i)))
2033                     '(td)))
2034             (when (and (not (stringp column))
2035                        (or (memq (dom-tag column) '(td th))
2036                            (not column)))
2037               (when-let (span (dom-attr column 'rowspan))
2038                 (aset rowspans i (+ (aref rowspans i)
2039                                     (1- (string-to-number span)))))
2040               ;; Sanity check for invalid column-spans.
2041               (when (>= width-column (length widths))
2042                 (setq width-column 0))
2043               (setq width
2044                     (if column
2045                         (aref widths width-column)
2046                       (* 10 shr-table-separator-pixel-width)))
2047               (when (setq colspan (dom-attr column 'colspan))
2048                 (setq colspan (min (string-to-number colspan)
2049                                    ;; The colspan may be wrong, so
2050                                    ;; truncate it to the length of the
2051                                    ;; remaining columns.
2052                                    (- (length widths) i)))
2053                 (dotimes (j (1- colspan))
2054                   (setq width
2055                         (if (> (+ i 1 j) (1- (length widths)))
2056                             ;; If we have a colspan spec that's longer
2057                             ;; than the table is wide, just use the last
2058                             ;; width as the width.
2059                             (aref widths (1- (length widths)))
2060                           ;; Sum up the widths of the columns we're
2061                           ;; spanning.
2062                           (+ width
2063                              shr-table-separator-length
2064                              (aref widths (+ i 1 j))))))
2065                 (setq width-column (+ width-column (1- colspan))
2066                       colspan-count colspan
2067                       colspan-remaining colspan))
2068               (when column
2069                 (let ((data (shr-render-td column width fill)))
2070                   (if (and (not fill)
2071                            (> colspan-remaining 0))
2072                       (progn
2073                         (setq colspan-width (car data))
2074                         (let ((this-width (/ colspan-width colspan-count)))
2075                           (push (cons this-width (cadr data)) tds)
2076                           (setq colspan-remaining (1- colspan-remaining))))
2077                     (if (not fill)
2078                         (push (cons (car data) (cadr data)) tds)
2079                       (push data tds)))))
2080               (when (and colspan
2081                          (> colspan 1))
2082                 (dotimes (c (1- colspan))
2083                   (setq i (1+ i))
2084                   (push
2085                    (if fill
2086                        (list 0 0 -1 nil 1 nil nil)
2087                      '(0 . 0))
2088                    tds)))
2089               (setq i (1+ i)
2090                     width-column (1+ width-column))))
2091           (push (nreverse tds) trs))))
2092     (nreverse trs)))
2093
2094 (defun shr-pixel-buffer-width ()
2095   (if (not shr-use-fonts)
2096       (save-excursion
2097         (goto-char (point-min))
2098         (let ((max 0))
2099           (while (not (eobp))
2100             (end-of-line)
2101             (setq max (max max (current-column)))
2102             (forward-line 1))
2103           max))
2104     (if (get-buffer-window)
2105         (car (window-text-pixel-size nil (point-min) (point-max)))
2106       (save-window-excursion
2107         (set-window-buffer nil (current-buffer))
2108         (car (window-text-pixel-size nil (point-min) (point-max)))))))
2109
2110 (defun shr-render-td (dom width fill)
2111   (let ((cache (intern (format "shr-td-cache-%s-%s" width fill))))
2112     (or (dom-attr dom cache)
2113         (and fill
2114              (let (result)
2115                (dolist (attr (dom-attributes dom))
2116                  (let ((name (symbol-name (car attr))))
2117                    (when (string-match "shr-td-cache-\\([0-9]+\\)-nil" name)
2118                      (let ((cache-width (string-to-number
2119                                          (match-string 1 name))))
2120                        (when (and (>= cache-width width)
2121                                   (<= (car (cdr attr)) width))
2122                          (setq result (cdr attr)))))))
2123                result))
2124         (let ((result (shr-render-td-1 dom width fill)))
2125           (dom-set-attribute dom cache result)
2126           result))))
2127
2128 (defun shr-render-td-1 (dom width fill)
2129   (with-temp-buffer
2130     (let ((bgcolor (dom-attr dom 'bgcolor))
2131           (fgcolor (dom-attr dom 'fgcolor))
2132           (style (dom-attr dom 'style))
2133           (shr-stylesheet shr-stylesheet)
2134           (max-width 0)
2135           natural-width)
2136       (when style
2137         (setq style (and (string-match "color" style)
2138                          (shr-parse-style style))))
2139       (when bgcolor
2140         (setq style (nconc (list (cons 'background-color bgcolor))
2141                            style)))
2142       (when fgcolor
2143         (setq style (nconc (list (cons 'color fgcolor)) style)))
2144       (when style
2145         (setq shr-stylesheet (append style shr-stylesheet)))
2146       (let ((shr-internal-width width)
2147             (shr-indentation 0))
2148         (shr-descend dom))
2149       (save-window-excursion
2150         (set-window-buffer nil (current-buffer))
2151         (unless fill
2152           (setq natural-width
2153                 (or (dom-attr dom 'shr-td-cache-natural)
2154                     (let ((natural (max (shr-pixel-buffer-width)
2155                                         (shr-dom-max-natural-width dom 0))))
2156                       (dom-set-attribute dom 'shr-td-cache-natural natural)
2157                       natural))))
2158         (if (and natural-width
2159                  (<= natural-width width))
2160             (setq max-width natural-width)
2161           (let ((shr-internal-width width))
2162             (shr-fill-lines (point-min) (point-max))
2163             (setq max-width (shr-pixel-buffer-width)))))
2164       (goto-char (point-max))
2165       ;; Delete padding at the bottom of the TDs.
2166       (delete-region
2167        (point)
2168        (progn
2169          (skip-chars-backward " \t\n")
2170          (end-of-line)
2171          (point)))
2172       (goto-char (point-min))
2173       (list max-width
2174             natural-width
2175             (count-lines (point-min) (point-max))
2176             (split-string (buffer-string) "\n")
2177             (if (dom-attr dom 'colspan)
2178                 (string-to-number (dom-attr dom 'colspan))
2179               1)
2180             (cdr (assq 'color shr-stylesheet))
2181             (cdr (assq 'background-color shr-stylesheet))))))
2182
2183 (defun shr-dom-max-natural-width (dom max)
2184   (if (eq (dom-tag dom) 'table)
2185       (max max (or
2186                 (loop for line in (dom-attr dom 'shr-suggested-widths)
2187                       maximize (+
2188                                 shr-table-separator-length
2189                                 (loop for elem in line
2190                                       summing
2191                                       (+ (cdr elem)
2192                                          (* 2 shr-table-separator-length)))))
2193                 0))
2194     (dolist (child (dom-children dom))
2195       (unless (stringp child)
2196         (setq max (max (shr-dom-max-natural-width child max)))))
2197     max))
2198
2199 (defun shr-buffer-width ()
2200   (goto-char (point-min))
2201   (let ((max 0))
2202     (while (not (eobp))
2203       (end-of-line)
2204       (setq max (max max (current-column)))
2205       (forward-line 1))
2206     max))
2207
2208 (defun shr-pro-rate-columns (columns)
2209   (let ((total-percentage 0)
2210         (widths (make-vector (length columns) 0)))
2211     (dotimes (i (length columns))
2212       (setq total-percentage (+ total-percentage (aref columns i))))
2213     (setq total-percentage (/ 1.0 total-percentage))
2214     (dotimes (i (length columns))
2215       (aset widths i (max (truncate (* (aref columns i)
2216                                        total-percentage
2217                                        (- shr-internal-width
2218                                           (* (1+ (length columns))
2219                                              shr-table-separator-pixel-width))))
2220                           10)))
2221     widths))
2222
2223 ;; Return a summary of the number and shape of the TDs in the table.
2224 (defun shr-column-specs (dom)
2225   (let ((columns (make-vector (shr-max-columns dom) 1)))
2226     (dolist (row (dom-non-text-children dom))
2227       (when (eq (dom-tag row) 'tr)
2228         (let ((i 0))
2229           (dolist (column (dom-non-text-children row))
2230             (when (memq (dom-tag column) '(td th))
2231               (let ((width (dom-attr column 'width)))
2232                 (when (and width
2233                            (string-match "\\([0-9]+\\)%" width)
2234                            (not (zerop (setq width (string-to-number
2235                                                     (match-string 1 width))))))
2236                   (aset columns i (/ width 100.0))))
2237               (setq i (1+ i)))))))
2238     columns))
2239
2240 (defun shr-count (dom elem)
2241   (let ((i 0))
2242     (dolist (sub (dom-children dom))
2243       (when (and (not (stringp sub))
2244                  (eq (dom-tag sub) elem))
2245         (setq i (1+ i))))
2246     i))
2247
2248 (defun shr-max-columns (dom)
2249   (let ((max 0))
2250     (dolist (row (dom-children dom))
2251       (when (and (not (stringp row))
2252                  (eq (dom-tag row) 'tr))
2253         (setq max (max max (+ (shr-count row 'td)
2254                               (shr-count row 'th))))))
2255     max))
2256
2257 (provide 'shr)
2258
2259 ;;; shr.el ends here