cgit.sxemacs.org Git - gnus/blob - lisp/shr.el

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