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

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