lisp/net/shr.el

   1 ;;; shr.el --- Simple HTML Renderer
   2
   3 ;; Copyright (C) 2010-2013 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
  37 (defgroup shr nil
  38   "Simple HTML Renderer"
  39   :version "24.1"
  40   :group 'hypermedia)
  41
  42 (defcustom shr-max-image-proportion 0.9
  43   "How big pictures displayed are in relation to the window they're in.
  44 A value of 0.7 means that they are allowed to take up 70% of the
  45 width and height of the window.  If they are larger than this,
  46 and Emacs supports it, then the images will be rescaled down to
  47 fit these criteria."
  48   :version "24.1"
  49   :group 'shr
  50   :type 'float)
  51
  52 (defcustom shr-blocked-images nil
  53   "Images that have URLs matching this regexp will be blocked."
  54   :version "24.1"
  55   :group 'shr
  56   :type '(choice (const nil) regexp))
  57
  58 (defcustom shr-table-horizontal-line nil
  59   "Character used to draw horizontal table lines.
  60 If nil, don't draw horizontal table lines."
  61   :group 'shr
  62   :type 'character)
  63
  64 (defcustom shr-table-vertical-line ?\s
  65   "Character used to draw vertical table lines."
  66   :group 'shr
  67   :type 'character)
  68
  69 (defcustom shr-table-corner ?\s
  70   "Character used to draw table corners."
  71   :group 'shr
  72   :type 'character)
  73
  74 (defcustom shr-hr-line ?-
  75   "Character used to draw hr lines."
  76   :group 'shr
  77   :type 'character)
  78
  79 (defcustom shr-width fill-column
  80   "Frame width to use for rendering.
  81 May either be an integer specifying a fixed width in characters,
  82 or nil, meaning that the full width of the window should be
  83 used."
  84   :type '(choice (integer :tag "Fixed width in characters")
  85                  (const   :tag "Use the width of the window" nil))
  86   :group 'shr)
  87
  88 (defcustom shr-bullet "* "
  89   "Bullet used for unordered lists.
  90 Alternative suggestions are:
  91 - \"  \"
  92 - \"  \""
  93   :type 'string
  94   :group 'shr)
  95
  96 (defcustom shr-external-browser 'browse-url-default-browser
  97   "Function used to launch an external browser."
  98   :version "24.4"
  99   :group 'shr
 100   :type 'function)
 101
 102 (defvar shr-content-function nil
 103   "If bound, this should be a function that will return the content.
 104 This is used for cid: URLs, and the function is called with the
 105 cid: URL as the argument.")
 106
 107 (defvar shr-put-image-function 'shr-put-image
 108   "Function called to put image and alt string.")
 109
 110 (defface shr-strike-through '((t (:strike-through t)))
 111   "Font for <s> elements."
 112   :group 'shr)
 113
 114 (defface shr-link
 115   '((t (:inherit link)))
 116   "Font for link elements."
 117   :group 'shr)
 118
 119 ;;; Internal variables.
 120
 121 (defvar shr-folding-mode nil)
 122 (defvar shr-state nil)
 123 (defvar shr-start nil)
 124 (defvar shr-indentation 0)
 125 (defvar shr-inhibit-images nil)
 126 (defvar shr-list-mode nil)
 127 (defvar shr-content-cache nil)
 128 (defvar shr-kinsoku-shorten nil)
 129 (defvar shr-table-depth 0)
 130 (defvar shr-stylesheet nil)
 131 (defvar shr-base nil)
 132 (defvar shr-ignore-cache nil)
 133 (defvar shr-external-rendering-functions nil)
 134 (defvar shr-target-id nil)
 135 (defvar shr-inhibit-decoration nil)
 136 (defvar shr-table-separator-length 1)
 137
 138 (defvar shr-map
 139   (let ((map (make-sparse-keymap)))
 140     (define-key map "a" 'shr-show-alt-text)
 141     (define-key map "i" 'shr-browse-image)
 142     (define-key map "z" 'shr-zoom-image)
 143     (define-key map [tab] 'shr-next-link)
 144     (define-key map [backtab] 'shr-previous-link)
 145     (define-key map [follow-link] 'mouse-face)
 146     (define-key map "I" 'shr-insert-image)
 147     (define-key map "w" 'shr-copy-url)
 148     (define-key map "u" 'shr-copy-url)
 149     (define-key map "v" 'shr-browse-url)
 150     (define-key map "o" 'shr-save-contents)
 151     (define-key map "\r" 'shr-browse-url)
 152     map))
 153
 154 ;; Public functions and commands.
 155 (declare-function libxml-parse-html-region "xml.c"
 156                   (start end &optional base-url))
 157
 158 (defun shr-render-buffer (buffer)
 159   "Display the HTML rendering of the current buffer."
 160   (interactive (list (current-buffer)))
 161   (or (fboundp 'libxml-parse-html-region)
 162       (error "This function requires Emacs to be compiled with libxml2"))
 163   (pop-to-buffer "*html*")
 164   (erase-buffer)
 165   (shr-insert-document
 166    (with-current-buffer buffer
 167      (libxml-parse-html-region (point-min) (point-max))))
 168   (goto-char (point-min)))
 169
 170 (defun shr-render-region (begin end &optional buffer)
 171   "Display the HTML rendering of the region between BEGIN and END."
 172   (interactive "r")
 173   (unless (fboundp 'libxml-parse-html-region)
 174     (error "This function requires Emacs to be compiled with libxml2"))
 175   (with-current-buffer (or buffer (current-buffer))
 176     (let ((dom (libxml-parse-html-region begin end)))
 177       (delete-region begin end)
 178       (goto-char begin)
 179       (shr-insert-document dom))))
 180
 181 (defun shr-visit-file (file)
 182   "Parse FILE as an HTML document, and render it in a new buffer."
 183   (interactive "fHTML file name: ")
 184   (with-temp-buffer
 185     (insert-file-contents file)
 186     (shr-render-buffer (current-buffer))))
 187
 188 ;;;###autoload
 189 (defun shr-insert-document (dom)
 190   "Render the parsed document DOM into the current buffer.
 191 DOM should be a parse tree as generated by
 192 `libxml-parse-html-region' or similar."
 193   (setq shr-content-cache nil)
 194   (let ((start (point))
 195         (shr-state nil)
 196         (shr-start nil)
 197         (shr-base nil)
 198         (shr-preliminary-table-render 0)
 199         (shr-width (or shr-width (1- (window-width)))))
 200     (shr-descend (shr-transform-dom dom))
 201     (shr-remove-trailing-whitespace start (point))))
 202
 203 (defun shr-remove-trailing-whitespace (start end)
 204   (let ((width (window-width)))
 205     (save-restriction
 206       (narrow-to-region start end)
 207       (goto-char start)
 208       (while (not (eobp))
 209         (end-of-line)
 210         (when (> (shr-previous-newline-padding-width (current-column)) width)
 211           (dolist (overlay (overlays-at (point)))
 212             (when (overlay-get overlay 'before-string)
 213               (overlay-put overlay 'before-string nil))))
 214         (forward-line 1)))))
 215
 216 (defun shr-copy-url ()
 217   "Copy the URL under point to the kill ring.
 218 If called twice, then try to fetch the URL and see whether it
 219 redirects somewhere else."
 220   (interactive)
 221   (let ((url (get-text-property (point) 'shr-url)))
 222     (cond
 223      ((not url)
 224       (message "No URL under point"))
 225      ;; Resolve redirected URLs.
 226      ((equal url (car kill-ring))
 227       (url-retrieve
 228        url
 229        (lambda (a)
 230          (when (and (consp a)
 231                     (eq (car a) :redirect))
 232            (with-temp-buffer
 233              (insert (cadr a))
 234              (goto-char (point-min))
 235              ;; Remove common tracking junk from the URL.
 236              (when (re-search-forward ".utm_.*" nil t)
 237                (replace-match "" t t))
 238              (message "Copied %s" (buffer-string))
 239              (copy-region-as-kill (point-min) (point-max)))))
 240        nil t))
 241      ;; Copy the URL to the kill ring.
 242      (t
 243       (with-temp-buffer
 244         (insert url)
 245         (copy-region-as-kill (point-min) (point-max))
 246         (message "Copied %s" url))))))
 247
 248 (defun shr-next-link ()
 249   "Skip to the next link."
 250   (interactive)
 251   (let ((skip (text-property-any (point) (point-max) 'help-echo nil)))
 252     (if (not (setq skip (text-property-not-all skip (point-max)
 253                                                'help-echo nil)))
 254         (message "No next link")
 255       (goto-char skip)
 256       (message "%s" (get-text-property (point) 'help-echo)))))
 257
 258 (defun shr-previous-link ()
 259   "Skip to the previous link."
 260   (interactive)
 261   (let ((start (point))
 262         (found nil))
 263     ;; Skip past the current link.
 264     (while (and (not (bobp))
 265                 (get-text-property (point) 'help-echo))
 266       (forward-char -1))
 267     ;; Find the previous link.
 268     (while (and (not (bobp))
 269                 (not (setq found (get-text-property (point) 'help-echo))))
 270       (forward-char -1))
 271     (if (not found)
 272         (progn
 273           (message "No previous link")
 274           (goto-char start))
 275       ;; Put point at the start of the link.
 276       (while (and (not (bobp))
 277                   (get-text-property (point) 'help-echo))
 278         (forward-char -1))
 279       (forward-char 1)
 280       (message "%s" (get-text-property (point) 'help-echo)))))
 281
 282 (defun shr-show-alt-text ()
 283   "Show the ALT text of the image under point."
 284   (interactive)
 285   (let ((text (get-text-property (point) 'shr-alt)))
 286     (if (not text)
 287         (message "No image under point")
 288       (message "%s" text))))
 289
 290 (defun shr-browse-image (&optional copy-url)
 291   "Browse the image under point.
 292 If COPY-URL (the prefix if called interactively) is non-nil, copy
 293 the URL of the image to the kill buffer instead."
 294   (interactive "P")
 295   (let ((url (get-text-property (point) 'image-url)))
 296     (cond
 297      ((not url)
 298       (message "No image under point"))
 299      (copy-url
 300       (with-temp-buffer
 301         (insert url)
 302         (copy-region-as-kill (point-min) (point-max))
 303         (message "Copied %s" url)))
 304      (t
 305       (message "Browsing %s..." url)
 306       (browse-url url)))))
 307
 308 (defun shr-insert-image ()
 309   "Insert the image under point into the buffer."
 310   (interactive)
 311   (let ((url (get-text-property (point) 'image-url)))
 312     (if (not url)
 313         (message "No image under point")
 314       (message "Inserting %s..." url)
 315       (url-retrieve url 'shr-image-fetched
 316                     (list (current-buffer) (1- (point)) (point-marker))
 317                     t t))))
 318
 319 (defun shr-zoom-image ()
 320   "Toggle the image size.
 321 The size will be rotated between the default size, the original
 322 size, and full-buffer size."
 323   (interactive)
 324   (let ((url (get-text-property (point) 'image-url))
 325         (size (get-text-property (point) 'image-size))
 326         (buffer-read-only nil))
 327     (if (not url)
 328         (message "No image under point")
 329       ;; Delete the old picture.
 330       (while (get-text-property (point) 'image-url)
 331         (forward-char -1))
 332       (forward-char 1)
 333       (let ((start (point)))
 334         (while (get-text-property (point) 'image-url)
 335           (forward-char 1))
 336         (forward-char -1)
 337         (put-text-property start (point) 'display nil)
 338         (when (> (- (point) start) 2)
 339           (delete-region start (1- (point)))))
 340       (message "Inserting %s..." url)
 341       (url-retrieve url 'shr-image-fetched
 342                     (list (current-buffer) (1- (point)) (point-marker)
 343                           (list (cons 'size
 344                                       (cond ((or (eq size 'default)
 345                                                  (null size))
 346                                              'original)
 347                                             ((eq size 'original)
 348                                              'full)
 349                                             ((eq size 'full)
 350                                              'default)))))
 351                     t))))
 352
 353 ;;; Utility functions.
 354
 355 (defun shr-transform-dom (dom)
 356   (let ((result (list (pop dom))))
 357     (dolist (arg (pop dom))
 358       (push (cons (intern (concat ":" (symbol-name (car arg))) obarray)
 359                   (cdr arg))
 360             result))
 361     (dolist (sub dom)
 362       (if (stringp sub)
 363           (push (cons 'text sub) result)
 364         (push (shr-transform-dom sub) result)))
 365     (nreverse result)))
 366
 367 (defun shr-descend (dom)
 368   (let ((function
 369          (or
 370           ;; Allow other packages to override (or provide) rendering
 371           ;; of elements.
 372           (cdr (assq (car dom) shr-external-rendering-functions))
 373           (intern (concat "shr-tag-" (symbol-name (car dom))) obarray)))
 374         (style (cdr (assq :style (cdr dom))))
 375         (shr-stylesheet shr-stylesheet)
 376         (start (point)))
 377     (when style
 378       (if (string-match "color\\|display\\|border-collapse" style)
 379           (setq shr-stylesheet (nconc (shr-parse-style style)
 380                                       shr-stylesheet))
 381         (setq style nil)))
 382     ;; If we have a display:none, then just ignore this part of the
 383     ;; DOM.
 384     (unless (equal (cdr (assq 'display shr-stylesheet)) "none")
 385       (if (fboundp function)
 386           (funcall function (cdr dom))
 387         (shr-generic (cdr dom)))
 388       (when (and shr-target-id
 389                  (equal (cdr (assq :id (cdr dom))) shr-target-id))
 390         (put-text-property start (1+ start) 'shr-target-id shr-target-id))
 391       ;; If style is set, then this node has set the color.
 392       (when style
 393         (shr-colorize-region start (point)
 394                              (cdr (assq 'color shr-stylesheet))
 395                              (cdr (assq 'background-color shr-stylesheet)))))))
 396
 397 (defun shr-generic (cont)
 398   (dolist (sub cont)
 399     (cond
 400      ((eq (car sub) 'text)
 401       (shr-insert (cdr sub)))
 402      ((listp (cdr sub))
 403       (shr-descend sub)))))
 404
 405 (defmacro shr-char-breakable-p (char)
 406   "Return non-nil if a line can be broken before and after CHAR."
 407   `(aref fill-find-break-point-function-table ,char))
 408 (defmacro shr-char-nospace-p (char)
 409   "Return non-nil if no space is required before and after CHAR."
 410   `(aref fill-nospace-between-words-table ,char))
 411
 412 ;; KINSOKU is a Japanese word meaning a rule that should not be violated.
 413 ;; In Emacs, it is a term used for characters, e.g. punctuation marks,
 414 ;; parentheses, and so on, that should not be placed in the beginning
 415 ;; of a line or the end of a line.
 416 (defmacro shr-char-kinsoku-bol-p (char)
 417   "Return non-nil if a line ought not to begin with CHAR."
 418   `(aref (char-category-set ,char) ?>))
 419 (defmacro shr-char-kinsoku-eol-p (char)
 420   "Return non-nil if a line ought not to end with CHAR."
 421   `(aref (char-category-set ,char) ?<))
 422 (unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35))
 423   (load "kinsoku" nil t))
 424
 425 (defun shr-insert (text)
 426   (when (and (eq shr-state 'image)
 427              (not (bolp))
 428              (not (string-match "\\`[ \t\n]+\\'" text)))
 429     (insert "\n")
 430     (setq shr-state nil))
 431   (cond
 432    ((eq shr-folding-mode 'none)
 433     (insert text))
 434    (t
 435     (when (and (string-match "\\`[ \t\n ]" text)
 436                (not (bolp))
 437                (not (eq (char-after (1- (point))) ? )))
 438       (insert " "))
 439     (dolist (elem (split-string text "[ \f\t\n\r\v ]+" t))
 440       (when (and (bolp)
 441                  (> shr-indentation 0))
 442         (shr-indent))
 443       ;; No space is needed behind a wide character categorized as
 444       ;; kinsoku-bol, between characters both categorized as nospace,
 445       ;; or at the beginning of a line.
 446       (let (prev)
 447         (when (and (> (current-column) shr-indentation)
 448                    (eq (preceding-char) ? )
 449                    (or (= (line-beginning-position) (1- (point)))
 450                        (and (shr-char-breakable-p
 451                              (setq prev (char-after (- (point) 2))))
 452                             (shr-char-kinsoku-bol-p prev))
 453                        (and (shr-char-nospace-p prev)
 454                             (shr-char-nospace-p (aref elem 0)))))
 455           (delete-char -1)))
 456       ;; The shr-start is a special variable that is used to pass
 457       ;; upwards the first point in the buffer where the text really
 458       ;; starts.
 459       (unless shr-start
 460         (setq shr-start (point)))
 461       (insert elem)
 462       (setq shr-state nil)
 463       (let (found)
 464         (while (and (> (current-column) shr-width)
 465                     (progn
 466                       (setq found (shr-find-fill-point))
 467                       (not (eolp))))
 468           (when (eq (preceding-char) ? )
 469             (delete-char -1))
 470           (insert "\n")
 471           (unless found
 472             ;; No space is needed at the beginning of a line.
 473             (when (eq (following-char) ? )
 474               (delete-char 1)))
 475           (when (> shr-indentation 0)
 476             (shr-indent))
 477           (end-of-line))
 478         (insert " ")))
 479     (unless (string-match "[ \t\r\n ]\\'" text)
 480       (delete-char -1)))))
 481
 482 (defun shr-find-fill-point ()
 483   (when (> (move-to-column shr-width) shr-width)
 484     (backward-char 1))
 485   (let ((bp (point))
 486         failed)
 487     (while (not (or (setq failed (= (current-column) shr-indentation))
 488                     (eq (preceding-char) ? )
 489                     (eq (following-char) ? )
 490                     (shr-char-breakable-p (preceding-char))
 491                     (shr-char-breakable-p (following-char))
 492                     (if (eq (preceding-char) ?')
 493                         (not (memq (char-after (- (point) 2))
 494                                    (list nil ?\n ? )))
 495                       (and (shr-char-kinsoku-bol-p (preceding-char))
 496                            (shr-char-breakable-p (following-char))
 497                            (not (shr-char-kinsoku-bol-p (following-char)))))
 498                     (shr-char-kinsoku-eol-p (following-char))))
 499       (backward-char 1))
 500     (if (and (not (or failed (eolp)))
 501              (eq (preceding-char) ?'))
 502         (while (not (or (setq failed (eolp))
 503                         (eq (following-char) ? )
 504                         (shr-char-breakable-p (following-char))
 505                         (shr-char-kinsoku-eol-p (following-char))))
 506           (forward-char 1)))
 507     (if failed
 508         ;; There's no breakable point, so we give it up.
 509         (let (found)
 510           (goto-char bp)
 511           (unless shr-kinsoku-shorten
 512             (while (and (setq found (re-search-forward
 513                                      "\\(\\c>\\)\\| \\|\\c<\\|\\c|"
 514                                      (line-end-position) 'move))
 515                         (eq (preceding-char) ?')))
 516             (if (and found (not (match-beginning 1)))
 517                 (goto-char (match-beginning 0)))))
 518       (or
 519        (eolp)
 520        ;; Don't put kinsoku-bol characters at the beginning of a line,
 521        ;; or kinsoku-eol characters at the end of a line.
 522        (cond
 523         (shr-kinsoku-shorten
 524          (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
 525                      (shr-char-kinsoku-eol-p (preceding-char)))
 526            (backward-char 1))
 527          (when (setq failed (= (current-column) shr-indentation))
 528            ;; There's no breakable point that doesn't violate kinsoku,
 529            ;; so we look for the second best position.
 530            (while (and (progn
 531                          (forward-char 1)
 532                          (<= (current-column) shr-width))
 533                        (progn
 534                          (setq bp (point))
 535                          (shr-char-kinsoku-eol-p (following-char)))))
 536            (goto-char bp)))
 537         ((shr-char-kinsoku-eol-p (preceding-char))
 538          ;; Find backward the point where kinsoku-eol characters begin.
 539          (let ((count 4))
 540            (while
 541                (progn
 542                  (backward-char 1)
 543                  (and (> (setq count (1- count)) 0)
 544                       (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
 545                       (or (shr-char-kinsoku-eol-p (preceding-char))
 546                           (shr-char-kinsoku-bol-p (following-char)))))))
 547          (if (setq failed (= (current-column) shr-indentation))
 548              ;; There's no breakable point that doesn't violate kinsoku,
 549              ;; so we go to the second best position.
 550              (if (looking-at "\\(\\c<+\\)\\c<")
 551                  (goto-char (match-end 1))
 552                (forward-char 1))))
 553         ((shr-char-kinsoku-bol-p (following-char))
 554          ;; Find forward the point where kinsoku-bol characters end.
 555          (let ((count 4))
 556            (while (progn
 557                     (forward-char 1)
 558                     (and (>= (setq count (1- count)) 0)
 559                          (shr-char-kinsoku-bol-p (following-char))
 560                          (shr-char-breakable-p (following-char))))))))
 561        (when (eq (following-char) ? )
 562          (forward-char 1))))
 563     (not failed)))
 564
 565 (defun shr-parse-base (url)
 566   ;; Always chop off anchors.
 567   (when (string-match "#.*" url)
 568     (setq url (substring url 0 (match-beginning 0))))
 569   (let* ((parsed (url-generic-parse-url url))
 570          (local (url-filename parsed)))
 571     (setf (url-filename parsed) "")
 572     ;; Chop off the bit after the last slash.
 573     (when (string-match "\\`\\(.*/\\)[^/]+\\'" local)
 574       (setq local (match-string 1 local)))
 575     ;; Always make the local bit end with a slash.
 576     (when (and (not (zerop (length local)))
 577                (not (eq (aref local (1- (length local))) ?/)))
 578       (setq local (concat local "/")))
 579     (list (url-recreate-url parsed)
 580           local
 581           (url-type parsed)
 582           url)))
 583
 584 (defun shr-expand-url (url &optional base)
 585   (setq base
 586         (if base
 587             (shr-parse-base base)
 588           ;; Bound by the parser.
 589           shr-base))
 590   (when (zerop (length url))
 591     (setq url nil))
 592   (cond ((or (not url)
 593              (not base)
 594              (string-match "\\`[a-z]*:" url))
 595          ;; Absolute URL.
 596          (or url (car base)))
 597         ((eq (aref url 0) ?/)
 598          (if (and (> (length url) 1)
 599                   (eq (aref url 1) ?/))
 600              ;; //host...; just use the protocol
 601              (concat (nth 2 base) ":" url)
 602            ;; Just use the host name part.
 603            (concat (car base) url)))
 604         ((eq (aref url 0) ?#)
 605          ;; A link to an anchor.
 606          (concat (nth 3 base) url))
 607         (t
 608          ;; Totally relative.
 609          (concat (car base) (cadr base) url))))
 610
 611 (defun shr-ensure-newline ()
 612   (unless (zerop (current-column))
 613     (insert "\n")))
 614
 615 (defun shr-ensure-paragraph ()
 616   (unless (bobp)
 617     (if (<= (current-column) shr-indentation)
 618         (unless (save-excursion
 619                   (forward-line -1)
 620                   (looking-at " *$"))
 621           (insert "\n"))
 622       (if (save-excursion
 623             (beginning-of-line)
 624             ;; If the current line is totally blank, and doesn't even
 625             ;; have any face properties set, then delete the blank
 626             ;; space.
 627             (and (looking-at " *$")
 628                  (not (get-text-property (point) 'face))
 629                  (not (= (next-single-property-change (point) 'face nil
 630                                                       (line-end-position))
 631                          (line-end-position)))))
 632           (delete-region (match-beginning 0) (match-end 0))
 633         (insert "\n\n")))))
 634
 635 (defun shr-indent ()
 636   (when (> shr-indentation 0)
 637     (insert (make-string shr-indentation ? ))))
 638
 639 (defun shr-fontize-cont (cont &rest types)
 640   (let (shr-start)
 641     (shr-generic cont)
 642     (dolist (type types)
 643       (shr-add-font (or shr-start (point)) (point) type))))
 644
 645 ;; Add face to the region, but avoid putting the font properties on
 646 ;; blank text at the start of the line, and the newline at the end, to
 647 ;; avoid ugliness.
 648 (defun shr-add-font (start end type)
 649   (unless shr-inhibit-decoration
 650     (save-excursion
 651       (goto-char start)
 652       (while (< (point) end)
 653         (when (bolp)
 654           (skip-chars-forward " "))
 655         (add-face-text-property (point) (min (line-end-position) end) type t)
 656         (if (< (line-end-position) end)
 657             (forward-line 1)
 658           (goto-char end))))))
 659
 660 (defun shr-browse-url (&optional external)
 661   "Browse the URL under point.
 662 If EXTERNAL, browse the URL using `shr-external-browser'."
 663   (interactive "P")
 664   (let ((url (get-text-property (point) 'shr-url)))
 665     (cond
 666      ((not url)
 667       (message "No link under point"))
 668      ((string-match "^mailto:" url)
 669       (browse-url-mail url))
 670      (t
 671       (if external
 672           (funcall shr-external-browser url)
 673         (browse-url url))))))
 674
 675 (defun shr-save-contents (directory)
 676   "Save the contents from URL in a file."
 677   (interactive "DSave contents of URL to directory: ")
 678   (let ((url (get-text-property (point) 'shr-url)))
 679     (if (not url)
 680         (message "No link under point")
 681       (url-retrieve (shr-encode-url url)
 682                     'shr-store-contents (list url directory)
 683                     nil t))))
 684
 685 (defun shr-store-contents (status url directory)
 686   (unless (plist-get status :error)
 687     (when (or (search-forward "\n\n" nil t)
 688               (search-forward "\r\n\r\n" nil t))
 689       (write-region (point) (point-max)
 690                     (expand-file-name (file-name-nondirectory url)
 691                                       directory)))))
 692
 693 (defun shr-image-fetched (status buffer start end &optional flags)
 694   (let ((image-buffer (current-buffer)))
 695     (when (and (buffer-name buffer)
 696                (not (plist-get status :error)))
 697       (url-store-in-cache image-buffer)
 698       (when (or (search-forward "\n\n" nil t)
 699                 (search-forward "\r\n\r\n" nil t))
 700         (let ((data (buffer-substring (point) (point-max))))
 701           (with-current-buffer buffer
 702             (save-excursion
 703               (let ((alt (buffer-substring start end))
 704                     (properties (text-properties-at start))
 705                     (inhibit-read-only t))
 706                 (delete-region start end)
 707                 (goto-char start)
 708                 (funcall shr-put-image-function data alt flags)
 709                 (while properties
 710                   (let ((type (pop properties))
 711                         (value (pop properties)))
 712                     (unless (memq type '(display image-size))
 713                       (put-text-property start (point) type value))))))))))
 714     (kill-buffer image-buffer)))
 715
 716 (defun shr-image-from-data (data)
 717   "Return an image from the data: URI content DATA."
 718   (when (string-match
 719          "\\(\\([^/;,]+\\(/[^;,]+\\)?\\)\\(;[^;,]+\\)*\\)?,\\(.*\\)"
 720          data)
 721     (let ((param (match-string 4 data))
 722           (payload (url-unhex-string (match-string 5 data))))
 723       (when (string-match "^.*\\(;[ \t]*base64\\)$" param)
 724         (setq payload (base64-decode-string payload)))
 725       payload)))
 726
 727 (defun shr-put-image (data alt &optional flags)
 728   "Put image DATA with a string ALT.  Return image."
 729   (if (display-graphic-p)
 730       (let* ((size (cdr (assq 'size flags)))
 731              (start (point))
 732              (image (cond
 733                      ((eq size 'original)
 734                       (create-image data nil t :ascent 100))
 735                      ((eq size 'full)
 736                       (ignore-errors
 737                         (shr-rescale-image data t)))
 738                      (t
 739                       (ignore-errors
 740                         (shr-rescale-image data))))))
 741         (when image
 742           ;; When inserting big-ish pictures, put them at the
 743           ;; beginning of the line.
 744           (when (and (> (current-column) 0)
 745                      (> (car (image-size image t)) 400))
 746             (insert "\n"))
 747           (if (eq size 'original)
 748               (insert-sliced-image image (or alt "*") nil 20 1)
 749             (insert-image image (or alt "*")))
 750           (put-text-property start (point) 'image-size size)
 751           (when (cond ((fboundp 'image-multi-frame-p)
 752                        ;; Only animate multi-frame things that specify a
 753                        ;; delay; eg animated gifs as opposed to
 754                        ;; multi-page tiffs.  FIXME?
 755                        (cdr (image-multi-frame-p image)))
 756                       ((fboundp 'image-animated-p)
 757                        (image-animated-p image)))
 758             (image-animate image nil 60)))
 759         image)
 760     (insert alt)))
 761
 762 (defun shr-rescale-image (data &optional force)
 763   "Rescale DATA, if too big, to fit the current buffer.
 764 If FORCE, rescale the image anyway."
 765   (if (or (not (fboundp 'imagemagick-types))
 766           (eq (image-type-from-data data) 'gif)
 767           (not (get-buffer-window (current-buffer))))
 768       (create-image data nil t :ascent 100)
 769     (let ((edges (window-inside-pixel-edges
 770                   (get-buffer-window (current-buffer)))))
 771       (create-image
 772        data 'imagemagick t
 773        :ascent 100
 774        :max-width (truncate (* shr-max-image-proportion
 775                                (- (nth 2 edges) (nth 0 edges))))
 776        :max-height (truncate (* shr-max-image-proportion
 777                                 (- (nth 3 edges) (nth 1 edges))))))))
 778
 779 ;; url-cache-extract autoloads url-cache.
 780 (declare-function url-cache-create-filename "url-cache" (url))
 781 (autoload 'mm-disable-multibyte "mm-util")
 782 (autoload 'browse-url-mail "browse-url")
 783
 784 (defun shr-get-image-data (url)
 785   "Get image data for URL.
 786 Return a string with image data."
 787   (with-temp-buffer
 788     (mm-disable-multibyte)
 789     (when (ignore-errors
 790             (url-cache-extract (url-cache-create-filename (shr-encode-url url)))
 791             t)
 792       (when (or (search-forward "\n\n" nil t)
 793                 (search-forward "\r\n\r\n" nil t))
 794         (buffer-substring (point) (point-max))))))
 795
 796 (defun shr-image-displayer (content-function)
 797   "Return a function to display an image.
 798 CONTENT-FUNCTION is a function to retrieve an image for a cid url that
 799 is an argument.  The function to be returned takes three arguments URL,
 800 START, and END.  Note that START and END should be markers."
 801   `(lambda (url start end)
 802      (when url
 803        (if (string-match "\\`cid:" url)
 804            ,(when content-function
 805               `(let ((image (funcall ,content-function
 806                                      (substring url (match-end 0)))))
 807                  (when image
 808                    (goto-char start)
 809                    (funcall shr-put-image-function
 810                             image (buffer-substring start end))
 811                    (delete-region (point) end))))
 812          (url-retrieve url 'shr-image-fetched
 813                        (list (current-buffer) start end)
 814                        t t)))))
 815
 816 (defun shr-heading (cont &rest types)
 817   (shr-ensure-paragraph)
 818   (apply #'shr-fontize-cont cont types)
 819   (shr-ensure-paragraph))
 820
 821 (defun shr-urlify (start url &optional title)
 822   (when (and title (string-match "ctx" title)) (debug))
 823   (shr-add-font start (point) 'shr-link)
 824   (add-text-properties
 825    start (point)
 826    (list 'shr-url url
 827          'help-echo (if title (format "%s (%s)" url title) url)
 828          'keymap shr-map)))
 829
 830 (defun shr-encode-url (url)
 831   "Encode URL."
 832   (browse-url-url-encode-chars url "[)$ ]"))
 833
 834 (autoload 'shr-color-visible "shr-color")
 835 (autoload 'shr-color->hexadecimal "shr-color")
 836
 837 (defun shr-color-check (fg bg)
 838   "Check that FG is visible on BG.
 839 Returns (fg bg) with corrected values.
 840 Returns nil if the colors that would be used are the default
 841 ones, in case fg and bg are nil."
 842   (when (or fg bg)
 843     (let ((fixed (cond ((null fg) 'fg)
 844                        ((null bg) 'bg))))
 845       ;; Convert colors to hexadecimal, or set them to default.
 846       (let ((fg (or (shr-color->hexadecimal fg)
 847                     (frame-parameter nil 'foreground-color)))
 848             (bg (or (shr-color->hexadecimal bg)
 849                     (frame-parameter nil 'background-color))))
 850         (cond ((eq fixed 'bg)
 851                ;; Only return the new fg
 852                (list nil (cadr (shr-color-visible bg fg t))))
 853               ((eq fixed 'fg)
 854                ;; Invert args and results and return only the new bg
 855                (list (cadr (shr-color-visible fg bg t)) nil))
 856               (t
 857                (shr-color-visible bg fg)))))))
 858
 859 (defun shr-colorize-region (start end fg &optional bg)
 860   (when (and (not shr-inhibit-decoration)
 861              (or fg bg))
 862     (let ((new-colors (shr-color-check fg bg)))
 863       (when new-colors
 864         (when fg
 865           (add-face-text-property start end
 866                                   (list :foreground (cadr new-colors))
 867                                   t))
 868         (when bg
 869           (add-face-text-property start end
 870                                   (list :background (car new-colors))
 871                                   t)))
 872       new-colors)))
 873
 874 (defun shr-expand-newlines (start end color)
 875   (save-restriction
 876     ;; Skip past all white space at the start and ends.
 877     (goto-char start)
 878     (skip-chars-forward " \t\n")
 879     (beginning-of-line)
 880     (setq start (point))
 881     (goto-char end)
 882     (skip-chars-backward " \t\n")
 883     (forward-line 1)
 884     (setq end (point))
 885     (narrow-to-region start end)
 886     (let ((width (shr-buffer-width))
 887           column)
 888       (goto-char (point-min))
 889       (while (not (eobp))
 890         (end-of-line)
 891         (when (and (< (setq column (current-column)) width)
 892                    (< (setq column (shr-previous-newline-padding-width column))
 893                       width))
 894           (let ((overlay (make-overlay (point) (1+ (point)))))
 895             (overlay-put overlay 'before-string
 896                          (concat
 897                           (mapconcat
 898                            (lambda (overlay)
 899                              (let ((string (plist-get
 900                                             (overlay-properties overlay)
 901                                             'before-string)))
 902                                (if (not string)
 903                                    ""
 904                                  (overlay-put overlay 'before-string "")
 905                                  string)))
 906                            (overlays-at (point))
 907                            "")
 908                           (propertize (make-string (- width column) ? )
 909                                       'face (list :background color))))))
 910         (forward-line 1)))))
 911
 912 (defun shr-previous-newline-padding-width (width)
 913   (let ((overlays (overlays-at (point)))
 914         (previous-width 0))
 915     (if (null overlays)
 916         width
 917       (dolist (overlay overlays)
 918         (setq previous-width
 919               (+ previous-width
 920                  (length (plist-get (overlay-properties overlay)
 921                                     'before-string)))))
 922       (+ width previous-width))))
 923
 924 ;;; Tag-specific rendering rules.
 925
 926 (defun shr-tag-body (cont)
 927   (let* ((start (point))
 928          (fgcolor (cdr (or (assq :fgcolor cont)
 929                            (assq :text cont))))
 930          (bgcolor (cdr (assq :bgcolor cont)))
 931          (shr-stylesheet (list (cons 'color fgcolor)
 932                                (cons 'background-color bgcolor))))
 933     (shr-generic cont)
 934     (shr-colorize-region start (point) fgcolor bgcolor)))
 935
 936 (defun shr-tag-style (cont)
 937   )
 938
 939 (defun shr-tag-script (cont)
 940   )
 941
 942 (defun shr-tag-comment (cont)
 943   )
 944
 945 (defun shr-dom-to-xml (dom)
 946   "Convert DOM into a string containing the xml representation."
 947   (let ((arg " ")
 948         (text ""))
 949     (dolist (sub (cdr dom))
 950       (cond
 951        ((listp (cdr sub))
 952         (setq text (concat text (shr-dom-to-xml sub))))
 953        ((eq (car sub) 'text)
 954         (setq text (concat text (cdr sub))))
 955        (t
 956         (setq arg (concat arg (format "%s=\"%s\" "
 957                                       (substring (symbol-name (car sub)) 1)
 958                                       (cdr sub)))))))
 959     (format "<%s%s>%s</%s>"
 960             (car dom)
 961             (substring arg 0 (1- (length arg)))
 962             text
 963             (car dom))))
 964
 965 (defun shr-tag-svg (cont)
 966   (when (image-type-available-p 'svg)
 967     (funcall shr-put-image-function
 968              (shr-dom-to-xml (cons 'svg cont))
 969              "SVG Image")))
 970
 971 (defun shr-tag-sup (cont)
 972   (let ((start (point)))
 973     (shr-generic cont)
 974     (put-text-property start (point) 'display '(raise 0.5))))
 975
 976 (defun shr-tag-sub (cont)
 977   (let ((start (point)))
 978     (shr-generic cont)
 979     (put-text-property start (point) 'display '(raise -0.5))))
 980
 981 (defun shr-tag-label (cont)
 982   (shr-generic cont)
 983   (shr-ensure-paragraph))
 984
 985 (defun shr-tag-p (cont)
 986   (shr-ensure-paragraph)
 987   (shr-indent)
 988   (shr-generic cont)
 989   (shr-ensure-paragraph))
 990
 991 (defun shr-tag-div (cont)
 992   (shr-ensure-newline)
 993   (shr-indent)
 994   (shr-generic cont)
 995   (shr-ensure-newline))
 996
 997 (defun shr-tag-s (cont)
 998   (shr-fontize-cont cont 'shr-strike-through))
 999
1000 (defun shr-tag-del (cont)
1001   (shr-fontize-cont cont 'shr-strike-through))
1002
1003 (defun shr-tag-b (cont)
1004   (shr-fontize-cont cont 'bold))
1005
1006 (defun shr-tag-i (cont)
1007   (shr-fontize-cont cont 'italic))
1008
1009 (defun shr-tag-em (cont)
1010   (shr-fontize-cont cont 'italic))
1011
1012 (defun shr-tag-strong (cont)
1013   (shr-fontize-cont cont 'bold))
1014
1015 (defun shr-tag-u (cont)
1016   (shr-fontize-cont cont 'underline))
1017
1018 (defun shr-parse-style (style)
1019   (when style
1020     (save-match-data
1021       (when (string-match "\n" style)
1022         (setq style (replace-match " " t t style))))
1023     (let ((plist nil))
1024       (dolist (elem (split-string style ";"))
1025         (when elem
1026           (setq elem (split-string elem ":"))
1027           (when (and (car elem)
1028                      (cadr elem))
1029             (let ((name (replace-regexp-in-string "^ +\\| +$" "" (car elem)))
1030                   (value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem))))
1031               (when (string-match " *!important\\'" value)
1032                 (setq value (substring value 0 (match-beginning 0))))
1033               (push (cons (intern name obarray)
1034                           value)
1035                     plist)))))
1036       plist)))
1037
1038 (defun shr-tag-base (cont)
1039   (let ((base (cdr (assq :href cont))))
1040     (when base
1041       (setq shr-base (shr-parse-base base))))
1042   (shr-generic cont))
1043
1044 (defun shr-tag-a (cont)
1045   (let ((url (cdr (assq :href cont)))
1046         (title (cdr (assq :title cont)))
1047         (start (point))
1048         shr-start)
1049     (shr-generic cont)
1050     (when (and url
1051                (not shr-inhibit-decoration))
1052       (shr-urlify (or shr-start start) (shr-expand-url url) title))))
1053
1054 (defun shr-tag-object (cont)
1055   (let ((start (point))
1056         url)
1057     (dolist (elem cont)
1058       (when (eq (car elem) 'embed)
1059         (setq url (or url (cdr (assq :src (cdr elem))))))
1060       (when (and (eq (car elem) 'param)
1061                  (equal (cdr (assq :name (cdr elem))) "movie"))
1062         (setq url (or url (cdr (assq :value (cdr elem)))))))
1063     (when url
1064       (shr-insert " [multimedia] ")
1065       (shr-urlify start (shr-expand-url url)))
1066     (shr-generic cont)))
1067
1068 (defun shr-tag-video (cont)
1069   (let ((image (cdr (assq :poster cont)))
1070         (url (cdr (assq :src cont)))
1071         (start (point)))
1072     (shr-tag-img nil image)
1073     (shr-urlify start (shr-expand-url url))))
1074
1075 (defun shr-tag-img (cont &optional url)
1076   (when (or url
1077             (and cont
1078                  (cdr (assq :src cont))))
1079     (when (and (> (current-column) 0)
1080                (not (eq shr-state 'image)))
1081       (insert "\n"))
1082     (let ((alt (cdr (assq :alt cont)))
1083           (url (shr-expand-url (or url (cdr (assq :src cont))))))
1084       (let ((start (point-marker)))
1085         (when (zerop (length alt))
1086           (setq alt "*"))
1087         (cond
1088          ((or (member (cdr (assq :height cont)) '("0" "1"))
1089               (member (cdr (assq :width cont)) '("0" "1")))
1090           ;; Ignore zero-sized or single-pixel images.
1091           )
1092          ((and (not shr-inhibit-images)
1093                (string-match "\\`data:" url))
1094           (let ((image (shr-image-from-data (substring url (match-end 0)))))
1095             (if image
1096                 (funcall shr-put-image-function image alt)
1097               (insert alt))))
1098          ((and (not shr-inhibit-images)
1099                (string-match "\\`cid:" url))
1100           (let ((url (substring url (match-end 0)))
1101                 image)
1102             (if (or (not shr-content-function)
1103                     (not (setq image (funcall shr-content-function url))))
1104                 (insert alt)
1105               (funcall shr-put-image-function image alt))))
1106          ((or shr-inhibit-images
1107               (and shr-blocked-images
1108                    (string-match shr-blocked-images url)))
1109           (setq shr-start (point))
1110           (let ((shr-state 'space))
1111             (if (> (string-width alt) 8)
1112                 (shr-insert (truncate-string-to-width alt 8))
1113               (shr-insert alt))))
1114          ((and (not shr-ignore-cache)
1115                (url-is-cached (shr-encode-url url)))
1116           (funcall shr-put-image-function (shr-get-image-data url) alt))
1117          (t
1118           (insert alt " ")
1119           (when (and shr-ignore-cache
1120                      (url-is-cached (shr-encode-url url)))
1121             (let ((file (url-cache-create-filename (shr-encode-url url))))
1122               (when (file-exists-p file)
1123                 (delete-file file))))
1124           (url-queue-retrieve
1125            (shr-encode-url url) 'shr-image-fetched
1126            (list (current-buffer) start (set-marker (make-marker) (1- (point))))
1127            t t)))
1128         (when (zerop shr-table-depth) ;; We are not in a table.
1129           (put-text-property start (point) 'keymap shr-map)
1130           (put-text-property start (point) 'shr-alt alt)
1131           (put-text-property start (point) 'image-url url)
1132           (put-text-property start (point) 'image-displayer
1133                              (shr-image-displayer shr-content-function))
1134           (put-text-property start (point) 'help-echo alt))
1135         (setq shr-state 'image)))))
1136
1137 (defun shr-tag-pre (cont)
1138   (let ((shr-folding-mode 'none))
1139     (shr-ensure-newline)
1140     (shr-indent)
1141     (shr-generic cont)
1142     (shr-ensure-newline)))
1143
1144 (defun shr-tag-blockquote (cont)
1145   (shr-ensure-paragraph)
1146   (shr-indent)
1147   (let ((shr-indentation (+ shr-indentation 4)))
1148     (shr-generic cont))
1149   (shr-ensure-paragraph))
1150
1151 (defun shr-tag-dl (cont)
1152   (shr-ensure-paragraph)
1153   (shr-generic cont)
1154   (shr-ensure-paragraph))
1155
1156 (defun shr-tag-dt (cont)
1157   (shr-ensure-newline)
1158   (shr-generic cont)
1159   (shr-ensure-newline))
1160
1161 (defun shr-tag-dd (cont)
1162   (shr-ensure-newline)
1163   (let ((shr-indentation (+ shr-indentation 4)))
1164     (shr-generic cont)))
1165
1166 (defun shr-tag-ul (cont)
1167   (shr-ensure-paragraph)
1168   (let ((shr-list-mode 'ul))
1169     (shr-generic cont))
1170   (shr-ensure-paragraph))
1171
1172 (defun shr-tag-ol (cont)
1173   (shr-ensure-paragraph)
1174   (let ((shr-list-mode 1))
1175     (shr-generic cont))
1176   (shr-ensure-paragraph))
1177
1178 (defun shr-tag-li (cont)
1179   (shr-ensure-newline)
1180   (shr-indent)
1181   (let* ((bullet
1182           (if (numberp shr-list-mode)
1183               (prog1
1184                   (format "%d " shr-list-mode)
1185                 (setq shr-list-mode (1+ shr-list-mode)))
1186             shr-bullet))
1187          (shr-indentation (+ shr-indentation (length bullet))))
1188     (insert bullet)
1189     (shr-generic cont)))
1190
1191 (defun shr-tag-br (cont)
1192   (when (and (not (bobp))
1193              ;; Only add a newline if we break the current line, or
1194              ;; the previous line isn't a blank line.
1195              (or (not (bolp))
1196                  (and (> (- (point) 2) (point-min))
1197                       (not (= (char-after (- (point) 2)) ?\n)))))
1198     (insert "\n")
1199     (shr-indent))
1200   (shr-generic cont))
1201
1202 (defun shr-tag-span (cont)
1203   (shr-generic cont))
1204
1205 (defun shr-tag-h1 (cont)
1206   (shr-heading cont 'bold 'underline))
1207
1208 (defun shr-tag-h2 (cont)
1209   (shr-heading cont 'bold))
1210
1211 (defun shr-tag-h3 (cont)
1212   (shr-heading cont 'italic))
1213
1214 (defun shr-tag-h4 (cont)
1215   (shr-heading cont))
1216
1217 (defun shr-tag-h5 (cont)
1218   (shr-heading cont))
1219
1220 (defun shr-tag-h6 (cont)
1221   (shr-heading cont))
1222
1223 (defun shr-tag-hr (cont)
1224   (shr-ensure-newline)
1225   (insert (make-string shr-width shr-hr-line) "\n"))
1226
1227 (defun shr-tag-title (cont)
1228   (shr-heading cont 'bold 'underline))
1229
1230 (defun shr-tag-font (cont)
1231   (let* ((start (point))
1232          (color (cdr (assq :color cont)))
1233          (shr-stylesheet (nconc (list (cons 'color color))
1234                                 shr-stylesheet)))
1235     (shr-generic cont)
1236     (when color
1237       (shr-colorize-region start (point) color
1238                            (cdr (assq 'background-color shr-stylesheet))))))
1239
1240 ;;; Table rendering algorithm.
1241
1242 ;; Table rendering is the only complicated thing here.  We do this by
1243 ;; first counting how many TDs there are in each TR, and registering
1244 ;; how wide they think they should be ("width=45%", etc).  Then we
1245 ;; render each TD separately (this is done in temporary buffers, so
1246 ;; that we can use all the rendering machinery as if we were in the
1247 ;; main buffer).  Now we know how much space each TD really takes, so
1248 ;; we then render everything again with the new widths, and finally
1249 ;; insert all these boxes into the main buffer.
1250 (defun shr-tag-table-1 (cont)
1251   (setq cont (or (cdr (assq 'tbody cont))
1252                  cont))
1253   (let* ((shr-inhibit-images t)
1254          (shr-table-depth (1+ shr-table-depth))
1255          (shr-kinsoku-shorten t)
1256          ;; Find all suggested widths.
1257          (columns (shr-column-specs cont))
1258          ;; Compute how many characters wide each TD should be.
1259          (suggested-widths (shr-pro-rate-columns columns))
1260          ;; Do a "test rendering" to see how big each TD is (this can
1261          ;; be smaller (if there's little text) or bigger (if there's
1262          ;; unbreakable text).
1263          (sketch (shr-make-table cont suggested-widths))
1264          ;; Compute the "natural" width by setting each column to 500
1265          ;; characters and see how wide they really render.
1266          (natural (shr-make-table cont (make-vector (length columns) 500)))
1267          (sketch-widths (shr-table-widths sketch natural suggested-widths)))
1268     ;; This probably won't work very well.
1269     (when (> (+ (loop for width across sketch-widths
1270                       summing (1+ width))
1271                 shr-indentation 1)
1272              (frame-width))
1273       (setq truncate-lines t))
1274     ;; Then render the table again with these new "hard" widths.
1275     (shr-insert-table (shr-make-table cont sketch-widths t) sketch-widths)))
1276
1277 (defun shr-tag-table (cont)
1278   (shr-ensure-paragraph)
1279   (let* ((caption (cdr (assq 'caption cont)))
1280          (header (cdr (assq 'thead cont)))
1281          (body (or (cdr (assq 'tbody cont)) cont))
1282          (footer (cdr (assq 'tfoot cont)))
1283          (bgcolor (cdr (assq :bgcolor cont)))
1284          (start (point))
1285          (shr-stylesheet (nconc (list (cons 'background-color bgcolor))
1286                                 shr-stylesheet))
1287          (nheader (if header (shr-max-columns header)))
1288          (nbody (if body (shr-max-columns body)))
1289          (nfooter (if footer (shr-max-columns footer))))
1290     (if (and (not caption)
1291              (not header)
1292              (not (cdr (assq 'tbody cont)))
1293              (not (cdr (assq 'tr cont)))
1294              (not footer))
1295         ;; The table is totally invalid and just contains random junk.
1296         ;; Try to output it anyway.
1297         (shr-generic cont)
1298       ;; It's a real table, so render it.
1299       (shr-tag-table-1
1300        (nconc
1301         (if caption `((tr (td ,@caption))))
1302         (if header
1303             (if footer
1304                 ;; hader + body + footer
1305                 (if (= nheader nbody)
1306                     (if (= nbody nfooter)
1307                         `((tr (td (table (tbody ,@header ,@body ,@footer)))))
1308                       (nconc `((tr (td (table (tbody ,@header ,@body)))))
1309                              (if (= nfooter 1)
1310                                  footer
1311                                `((tr (td (table (tbody ,@footer))))))))
1312                   (nconc `((tr (td (table (tbody ,@header)))))
1313                          (if (= nbody nfooter)
1314                              `((tr (td (table (tbody ,@body ,@footer)))))
1315                            (nconc `((tr (td (table (tbody ,@body)))))
1316                                   (if (= nfooter 1)
1317                                       footer
1318                                     `((tr (td (table (tbody ,@footer))))))))))
1319               ;; header + body
1320               (if (= nheader nbody)
1321                   `((tr (td (table (tbody ,@header ,@body)))))
1322                 (if (= nheader 1)
1323                     `(,@header (tr (td (table (tbody ,@body)))))
1324                   `((tr (td (table (tbody ,@header))))
1325                     (tr (td (table (tbody ,@body))))))))
1326           (if footer
1327               ;; body + footer
1328               (if (= nbody nfooter)
1329                   `((tr (td (table (tbody ,@body ,@footer)))))
1330                 (nconc `((tr (td (table (tbody ,@body)))))
1331                        (if (= nfooter 1)
1332                            footer
1333                          `((tr (td (table (tbody ,@footer))))))))
1334             (if caption
1335                 `((tr (td (table (tbody ,@body)))))
1336               body))))))
1337     (when bgcolor
1338       (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet))
1339                            bgcolor))
1340     ;; Finally, insert all the images after the table.  The Emacs buffer
1341     ;; model isn't strong enough to allow us to put the images actually
1342     ;; into the tables.
1343     (when (zerop shr-table-depth)
1344       (dolist (elem (shr-find-elements cont 'img))
1345         (shr-tag-img (cdr elem))))))
1346
1347 (defun shr-find-elements (cont type)
1348   (let (result)
1349     (dolist (elem cont)
1350       (cond ((eq (car elem) type)
1351              (push elem result))
1352             ((consp (cdr elem))
1353              (setq result (nconc (shr-find-elements (cdr elem) type) result)))))
1354     (nreverse result)))
1355
1356 (defun shr-insert-table (table widths)
1357   (let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet))
1358                           "collapse"))
1359          (shr-table-separator-length (if collapse 0 1))
1360          (shr-table-vertical-line (if collapse "" shr-table-vertical-line)))
1361     (unless collapse
1362       (shr-insert-table-ruler widths))
1363     (dolist (row table)
1364       (let ((start (point))
1365             (height (let ((max 0))
1366                       (dolist (column row)
1367                         (setq max (max max (cadr column))))
1368                       max)))
1369         (dotimes (i height)
1370           (shr-indent)
1371           (insert shr-table-vertical-line "\n"))
1372         (dolist (column row)
1373           (goto-char start)
1374           (let ((lines (nth 2 column)))
1375             (dolist (line lines)
1376               (end-of-line)
1377               (insert line shr-table-vertical-line)
1378               (forward-line 1))
1379             ;; Add blank lines at padding at the bottom of the TD,
1380             ;; possibly.
1381             (dotimes (i (- height (length lines)))
1382               (end-of-line)
1383               (let ((start (point)))
1384                 (insert (make-string (string-width (car lines)) ? )
1385                         shr-table-vertical-line)
1386                 (when (nth 4 column)
1387                   (shr-add-font start (1- (point))
1388                                 (list :background (nth 4 column)))))
1389               (forward-line 1)))))
1390       (unless collapse
1391         (shr-insert-table-ruler widths)))))
1392
1393 (defun shr-insert-table-ruler (widths)
1394   (when shr-table-horizontal-line
1395     (when (and (bolp)
1396                (> shr-indentation 0))
1397       (shr-indent))
1398     (insert shr-table-corner)
1399     (dotimes (i (length widths))
1400       (insert (make-string (aref widths i) shr-table-horizontal-line)
1401               shr-table-corner))
1402     (insert "\n")))
1403
1404 (defun shr-table-widths (table natural-table suggested-widths)
1405   (let* ((length (length suggested-widths))
1406          (widths (make-vector length 0))
1407          (natural-widths (make-vector length 0)))
1408     (dolist (row table)
1409       (let ((i 0))
1410         (dolist (column row)
1411           (aset widths i (max (aref widths i) column))
1412           (setq i (1+ i)))))
1413     (dolist (row natural-table)
1414       (let ((i 0))
1415         (dolist (column row)
1416           (aset natural-widths i (max (aref natural-widths i) column))
1417           (setq i (1+ i)))))
1418     (let ((extra (- (apply '+ (append suggested-widths nil))
1419                     (apply '+ (append widths nil))))
1420           (expanded-columns 0))
1421       ;; We have extra, unused space, so divide this space amongst the
1422       ;; columns.
1423       (when (> extra 0)
1424         ;; If the natural width is wider than the rendered width, we
1425         ;; want to allow the column to expand.
1426         (dotimes (i length)
1427           (when (> (aref natural-widths i) (aref widths i))
1428             (setq expanded-columns (1+ expanded-columns))))
1429         (dotimes (i length)
1430           (when (> (aref natural-widths i) (aref widths i))
1431             (aset widths i (min
1432                             (aref natural-widths i)
1433                             (+ (/ extra expanded-columns)
1434                                (aref widths i))))))))
1435     widths))
1436
1437 (defun shr-make-table (cont widths &optional fill)
1438   (or (cadr (assoc (list cont widths fill) shr-content-cache))
1439       (let ((data (shr-make-table-1 cont widths fill)))
1440         (push (list (list cont widths fill) data)
1441               shr-content-cache)
1442         data)))
1443
1444 (defun shr-make-table-1 (cont widths &optional fill)
1445   (let ((trs nil)
1446         (shr-inhibit-decoration (not fill))
1447         (rowspans (make-vector (length widths) 0))
1448         width colspan)
1449     (dolist (row cont)
1450       (when (eq (car row) 'tr)
1451         (let ((tds nil)
1452               (columns (cdr row))
1453               (i 0)
1454               (width-column 0)
1455               column)
1456           (while (< i (length widths))
1457             ;; If we previously had a rowspan definition, then that
1458             ;; means that we now have a "missing" td/th element here.
1459             ;; So just insert a dummy, empty one to (sort of) emulate
1460             ;; rowspan.
1461             (setq column
1462                   (if (zerop (aref rowspans i))
1463                       (pop columns)
1464                     (aset rowspans i (1- (aref rowspans i)))
1465                     '(td)))
1466             (when (or (memq (car column) '(td th))
1467                       (not column))
1468               (when (cdr (assq :rowspan (cdr column)))
1469                 (aset rowspans i (+ (aref rowspans i)
1470                                     (1- (string-to-number
1471                                          (cdr (assq :rowspan (cdr column))))))))
1472               ;; Sanity check for invalid column-spans.
1473               (when (>= width-column (length widths))
1474                 (setq width-column 0))
1475               (setq width
1476                     (if column
1477                         (aref widths width-column)
1478                       10))
1479               ;; Sanity check for degenerate tables.
1480               (when (zerop width)
1481                 (setq width 10))
1482               (when (and fill
1483                          (setq colspan (cdr (assq :colspan (cdr column)))))
1484                 (setq colspan (string-to-number colspan))
1485                 (dotimes (j (1- colspan))
1486                   (if (> (+ i 1 j) (1- (length widths)))
1487                       (setq width (aref widths (1- (length widths))))
1488                     (setq width (+ width
1489                                    shr-table-separator-length
1490                                    (aref widths (+ i 1 j))))))
1491                 (setq width-column (+ width-column (1- colspan))))
1492               (when (or column
1493                         (not fill))
1494                 (push (shr-render-td (cdr column) width fill)
1495                       tds))
1496               (setq i (1+ i)
1497                     width-column (1+ width-column))))
1498           (push (nreverse tds) trs))))
1499     (nreverse trs)))
1500
1501 (defun shr-render-td (cont width fill)
1502   (with-temp-buffer
1503     (let ((bgcolor (cdr (assq :bgcolor cont)))
1504           (fgcolor (cdr (assq :fgcolor cont)))
1505           (style (cdr (assq :style cont)))
1506           (shr-stylesheet shr-stylesheet)
1507           actual-colors)
1508       (when style
1509         (setq style (and (string-match "color" style)
1510                          (shr-parse-style style))))
1511       (when bgcolor
1512         (setq style (nconc (list (cons 'background-color bgcolor)) style)))
1513       (when fgcolor
1514         (setq style (nconc (list (cons 'color fgcolor)) style)))
1515       (when style
1516         (setq shr-stylesheet (append style shr-stylesheet)))
1517       (let ((shr-width width)
1518             (shr-indentation 0))
1519         (shr-descend (cons 'td cont)))
1520       ;; Delete padding at the bottom of the TDs.
1521       (delete-region
1522        (point)
1523        (progn
1524          (skip-chars-backward " \t\n")
1525          (end-of-line)
1526          (point)))
1527       (goto-char (point-min))
1528       (let ((max 0))
1529         (while (not (eobp))
1530           (end-of-line)
1531           (setq max (max max (current-column)))
1532           (forward-line 1))
1533         (when fill
1534           (goto-char (point-min))
1535           ;; If the buffer is totally empty, then put a single blank
1536           ;; line here.
1537           (if (zerop (buffer-size))
1538               (insert (make-string width ? ))
1539             ;; Otherwise, fill the buffer.
1540             (let ((align (cdr (assq :align cont)))
1541                   length)
1542               (while (not (eobp))
1543                 (end-of-line)
1544                 (setq length (- width (current-column)))
1545                 (when (> length 0)
1546                   (cond
1547                    ((equal align "right")
1548                     (beginning-of-line)
1549                     (insert (make-string length ? )))
1550                    ((equal align "center")
1551                     (insert (make-string (/ length 2) ? ))
1552                     (beginning-of-line)
1553                     (insert (make-string (- length (/ length 2)) ? )))
1554                    (t
1555                     (insert (make-string length ? )))))
1556                 (forward-line 1))))
1557           (when style
1558             (setq actual-colors
1559                   (shr-colorize-region
1560                    (point-min) (point-max)
1561                    (cdr (assq 'color shr-stylesheet))
1562                    (cdr (assq 'background-color shr-stylesheet))))))
1563         (if fill
1564             (list max
1565                   (count-lines (point-min) (point-max))
1566                   (split-string (buffer-string) "\n")
1567                   nil
1568                   (car actual-colors))
1569           max)))))
1570
1571 (defun shr-buffer-width ()
1572   (goto-char (point-min))
1573   (let ((max 0))
1574     (while (not (eobp))
1575       (end-of-line)
1576       (setq max (max max (current-column)))
1577       (forward-line 1))
1578     max))
1579
1580 (defun shr-pro-rate-columns (columns)
1581   (let ((total-percentage 0)
1582         (widths (make-vector (length columns) 0)))
1583     (dotimes (i (length columns))
1584       (setq total-percentage (+ total-percentage (aref columns i))))
1585     (setq total-percentage (/ 1.0 total-percentage))
1586     (dotimes (i (length columns))
1587       (aset widths i (max (truncate (* (aref columns i)
1588                                        total-percentage
1589                                        (- shr-width (1+ (length columns)))))
1590                           10)))
1591     widths))
1592
1593 ;; Return a summary of the number and shape of the TDs in the table.
1594 (defun shr-column-specs (cont)
1595   (let ((columns (make-vector (shr-max-columns cont) 1)))
1596     (dolist (row cont)
1597       (when (eq (car row) 'tr)
1598         (let ((i 0))
1599           (dolist (column (cdr row))
1600             (when (memq (car column) '(td th))
1601               (let ((width (cdr (assq :width (cdr column)))))
1602                 (when (and width
1603                            (string-match "\\([0-9]+\\)%" width)
1604                            (not (zerop (setq width (string-to-number
1605                                                     (match-string 1 width))))))
1606                   (aset columns i (/ width 100.0))))
1607               (setq i (1+ i)))))))
1608     columns))
1609
1610 (defun shr-count (cont elem)
1611   (let ((i 0))
1612     (dolist (sub cont)
1613       (when (eq (car sub) elem)
1614         (setq i (1+ i))))
1615     i))
1616
1617 (defun shr-max-columns (cont)
1618   (let ((max 0))
1619     (dolist (row cont)
1620       (when (eq (car row) 'tr)
1621         (setq max (max max (+ (shr-count (cdr row) 'td)
1622                               (shr-count (cdr row) 'th))))))
1623     max))
1624
1625 (provide 'shr)
1626
1627 ;; Local Variables:
1628 ;; coding: utf-8
1629 ;; End:
1630
1631 ;;; shr.el ends here