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