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