lisp/gnus/shr.el

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