shr.el 42.4 KB
Newer Older
1 2
;;; shr.el --- Simple HTML Renderer

3
;; Copyright (C) 2010-2012 Free Software Foundation, Inc.
4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32

;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: html

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This package takes a HTML parse tree (as provided by
;; libxml-parse-html-region) and renders it in the current buffer.  It
;; does not do CSS, JavaScript or anything advanced: It's geared
;; towards rendering typical short snippets of HTML, like what you'd
;; find in HTML email and the like.

;;; Code:

33
(eval-when-compile (require 'cl))
34 35
(require 'browse-url)

36 37
(defgroup shr nil
  "Simple HTML Renderer"
38
  :version "24.1"
39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56
  :group 'mail)

(defcustom shr-max-image-proportion 0.9
  "How big pictures displayed are in relation to the window they're in.
A value of 0.7 means that they are allowed to take up 70% of the
width and height of the window.  If they are larger than this,
and Emacs supports it, then the images will be rescaled down to
fit these criteria."
  :version "24.1"
  :group 'shr
  :type 'float)

(defcustom shr-blocked-images nil
  "Images that have URLs matching this regexp will be blocked."
  :version "24.1"
  :group 'shr
  :type 'regexp)

57
(defcustom shr-table-horizontal-line ?\s
58 59 60 61
  "Character used to draw horizontal table lines."
  :group 'shr
  :type 'character)

62
(defcustom shr-table-vertical-line ?\s
63
  "Character used to draw vertical table lines."
64
  :group 'shr
65
  :type 'character)
66

67
(defcustom shr-table-corner ?\s
68
  "Character used to draw table corners."
69
  :group 'shr
70
  :type 'character)
71 72

(defcustom shr-hr-line ?-
73
  "Character used to draw hr lines."
74
  :group 'shr
75
  :type 'character)
76

77
(defcustom shr-width fill-column
78 79 80 81 82 83
  "Frame width to use for rendering.
May either be an integer specifying a fixed width in characters,
or nil, meaning that the full width of the window should be
used."
  :type '(choice (integer :tag "Fixed width in characters")
		 (const   :tag "Use the width of the window" nil))
84 85
  :group 'shr)

86 87 88 89 90
(defvar shr-content-function nil
  "If bound, this should be a function that will return the content.
This is used for cid: URLs, and the function is called with the
cid: URL as the argument.")

91 92 93
(defvar shr-put-image-function 'shr-put-image
  "Function called to put image and alt string.")

94 95 96 97
(defface shr-strike-through '((t (:strike-through t)))
  "Font for <s> elements."
  :group 'shr)

98
(defface shr-link
99
  '((t (:inherit link)))
100
  "Font for link elements."
101 102
  :group 'shr)

103 104
;;; Internal variables.

105 106 107
(defvar shr-folding-mode nil)
(defvar shr-state nil)
(defvar shr-start nil)
108
(defvar shr-indentation 0)
109
(defvar shr-inhibit-images nil)
110
(defvar shr-list-mode nil)
111
(defvar shr-content-cache nil)
112
(defvar shr-kinsoku-shorten nil)
113
(defvar shr-table-depth 0)
114
(defvar shr-stylesheet nil)
115
(defvar shr-base nil)
116
(defvar shr-ignore-cache nil)
117

118 119 120 121 122 123 124
(defvar shr-map
  (let ((map (make-sparse-keymap)))
    (define-key map "a" 'shr-show-alt-text)
    (define-key map "i" 'shr-browse-image)
    (define-key map "I" 'shr-insert-image)
    (define-key map "u" 'shr-copy-url)
    (define-key map "v" 'shr-browse-url)
125
    (define-key map "o" 'shr-save-contents)
126 127 128
    (define-key map "\r" 'shr-browse-url)
    map))

129 130
;; Public functions and commands.

131
(defun shr-visit-file (file)
132
  "Parse FILE as an HTML document, and render it in a new buffer."
133 134 135 136 137 138
  (interactive "fHTML file name: ")
  (pop-to-buffer "*html*")
  (erase-buffer)
  (shr-insert-document
   (with-temp-buffer
     (insert-file-contents file)
139 140
     (libxml-parse-html-region (point-min) (point-max))))
  (goto-char (point-min)))
141

142 143
;;;###autoload
(defun shr-insert-document (dom)
144 145 146
  "Render the parsed document DOM into the current buffer.
DOM should be a parse tree as generated by
`libxml-parse-html-region' or similar."
147
  (setq shr-content-cache nil)
148 149
  (let ((start (point))
	(shr-state nil)
150
	(shr-start nil)
151
	(shr-base nil)
152
	(shr-width (or shr-width (window-width))))
153 154 155 156
    (shr-descend (shr-transform-dom dom))
    (shr-remove-trailing-whitespace start (point))))

(defun shr-remove-trailing-whitespace (start end)
157 158 159 160 161 162
  (let ((width (window-width)))
    (save-restriction
      (narrow-to-region start end)
      (goto-char start)
      (while (not (eobp))
	(end-of-line)
163
	(when (> (shr-previous-newline-padding-width (current-column)) width)
164 165 166 167
	  (dolist (overlay (overlays-at (point)))
	    (when (overlay-get overlay 'before-string)
	      (overlay-put overlay 'before-string nil))))
	(forward-line 1)))))
168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191

(defun shr-copy-url ()
  "Copy the URL under point to the kill ring.
If called twice, then try to fetch the URL and see whether it
redirects somewhere else."
  (interactive)
  (let ((url (get-text-property (point) 'shr-url)))
    (cond
     ((not url)
      (message "No URL under point"))
     ;; Resolve redirected URLs.
     ((equal url (car kill-ring))
      (url-retrieve
       url
       (lambda (a)
	 (when (and (consp a)
		    (eq (car a) :redirect))
	   (with-temp-buffer
	     (insert (cadr a))
	     (goto-char (point-min))
	     ;; Remove common tracking junk from the URL.
	     (when (re-search-forward ".utm_.*" nil t)
	       (replace-match "" t t))
	     (message "Copied %s" (buffer-string))
192 193
	     (copy-region-as-kill (point-min) (point-max)))))
       nil t))
194 195 196 197 198 199 200 201 202 203 204 205 206 207 208
     ;; Copy the URL to the kill ring.
     (t
      (with-temp-buffer
	(insert url)
	(copy-region-as-kill (point-min) (point-max))
	(message "Copied %s" url))))))

(defun shr-show-alt-text ()
  "Show the ALT text of the image under point."
  (interactive)
  (let ((text (get-text-property (point) 'shr-alt)))
    (if (not text)
	(message "No image under point")
      (message "%s" text))))

209 210 211 212 213
(defun shr-browse-image (&optional copy-url)
  "Browse the image under point.
If COPY-URL (the prefix if called interactively) is non-nil, copy
the URL of the image to the kill buffer instead."
  (interactive "P")
214
  (let ((url (get-text-property (point) 'image-url)))
215 216 217 218 219 220 221 222 223
    (cond
     ((not url)
      (message "No image under point"))
     (copy-url
      (with-temp-buffer
	(insert url)
	(copy-region-as-kill (point-min) (point-max))
	(message "Copied %s" url)))
     (t
224
      (message "Browsing %s..." url)
225
      (browse-url url)))))
226

227 228 229
(defun shr-insert-image ()
  "Insert the image under point into the buffer."
  (interactive)
230
  (let ((url (get-text-property (point) 'image-url)))
231 232 233 234 235
    (if (not url)
	(message "No image under point")
      (message "Inserting %s..." url)
      (url-retrieve url 'shr-image-fetched
		    (list (current-buffer) (1- (point)) (point-marker))
236
		    t t))))
237

238 239
;;; Utility functions.

240 241 242 243 244 245 246 247
(defun shr-transform-dom (dom)
  (let ((result (list (pop dom))))
    (dolist (arg (pop dom))
      (push (cons (intern (concat ":" (symbol-name (car arg))) obarray)
		  (cdr arg))
	    result))
    (dolist (sub dom)
      (if (stringp sub)
248
	  (push (cons 'text sub) result)
249 250 251 252
	(push (shr-transform-dom sub) result)))
    (nreverse result)))

(defun shr-descend (dom)
253 254
  (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray))
	(style (cdr (assq :style (cdr dom))))
255
	(shr-stylesheet shr-stylesheet)
256
	(start (point)))
257 258 259 260 261
    (when style
      (if (string-match "color" style)
	  (setq shr-stylesheet (nconc (shr-parse-style style)
				      shr-stylesheet))
	(setq style nil)))
262 263
    (if (fboundp function)
	(funcall function (cdr dom))
264
      (shr-generic (cdr dom)))
265 266 267 268 269
    ;; If style is set, then this node has set the color.
    (when style
      (shr-colorize-region start (point)
			   (cdr (assq 'color shr-stylesheet))
			   (cdr (assq 'background-color shr-stylesheet))))))
270 271 272 273

(defun shr-generic (cont)
  (dolist (sub cont)
    (cond
274
     ((eq (car sub) 'text)
275
      (shr-insert (cdr sub)))
276
     ((listp (cdr sub))
277 278
      (shr-descend sub)))))

279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298
(defmacro shr-char-breakable-p (char)
  "Return non-nil if a line can be broken before and after CHAR."
  `(aref fill-find-break-point-function-table ,char))
(defmacro shr-char-nospace-p (char)
  "Return non-nil if no space is required before and after CHAR."
  `(aref fill-nospace-between-words-table ,char))

;; KINSOKU is a Japanese word meaning a rule that should not be violated.
;; In Emacs, it is a term used for characters, e.g. punctuation marks,
;; parentheses, and so on, that should not be placed in the beginning
;; of a line or the end of a line.
(defmacro shr-char-kinsoku-bol-p (char)
  "Return non-nil if a line ought not to begin with CHAR."
  `(aref (char-category-set ,char) ?>))
(defmacro shr-char-kinsoku-eol-p (char)
  "Return non-nil if a line ought not to end with CHAR."
  `(aref (char-category-set ,char) ?<))
(unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35))
  (load "kinsoku" nil t))

299
(defun shr-insert (text)
300 301
  (when (and (eq shr-state 'image)
	     (not (string-match "\\`[ \t\n]+\\'" text)))
302 303 304 305 306 307
    (insert "\n")
    (setq shr-state nil))
  (cond
   ((eq shr-folding-mode 'none)
    (insert text))
   (t
308 309 310 311 312 313 314 315 316
    (when (and (string-match "\\`[ \t\n]" text)
	       (not (bolp))
	       (not (eq (char-after (1- (point))) ? )))
      (insert " "))
    (dolist (elem (split-string text))
      (when (and (bolp)
		 (> shr-indentation 0))
	(shr-indent))
      ;; No space is needed behind a wide character categorized as
317 318
      ;; kinsoku-bol, between characters both categorized as nospace,
      ;; or at the beginning of a line.
319
      (let (prev)
320 321
	(when (and (> (current-column) shr-indentation)
		   (eq (preceding-char) ? )
322
		   (or (= (line-beginning-position) (1- (point)))
323 324 325 326 327
		       (and (shr-char-breakable-p
			     (setq prev (char-after (- (point) 2))))
			    (shr-char-kinsoku-bol-p prev))
		       (and (shr-char-nospace-p prev)
			    (shr-char-nospace-p (aref elem 0)))))
328
	  (delete-char -1)))
329 330 331 332 333
      ;; The shr-start is a special variable that is used to pass
      ;; upwards the first point in the buffer where the text really
      ;; starts.
      (unless shr-start
	(setq shr-start (point)))
334
      (insert elem)
335 336 337 338
      (let (found)
	(while (and (> (current-column) shr-width)
		    (progn
		      (setq found (shr-find-fill-point))
339
		      (not (eolp))))
340 341 342 343
	  (when (eq (preceding-char) ? )
	    (delete-char -1))
	  (insert "\n")
	  (unless found
344 345 346 347 348 349 350 351
	    (put-text-property (1- (point)) (point) 'shr-break t)
	    ;; No space is needed at the beginning of a line.
	    (when (eq (following-char) ? )
	      (delete-char 1)))
	  (when (> shr-indentation 0)
	    (shr-indent))
	  (end-of-line))
	(insert " ")))
352 353
    (unless (string-match "[ \t\n]\\'" text)
      (delete-char -1)))))
354

355
(defun shr-find-fill-point ()
356 357
  (when (> (move-to-column shr-width) shr-width)
    (backward-char 1))
358 359 360 361 362 363 364
  (let ((bp (point))
	failed)
    (while (not (or (setq failed (= (current-column) shr-indentation))
		    (eq (preceding-char) ? )
		    (eq (following-char) ? )
		    (shr-char-breakable-p (preceding-char))
		    (shr-char-breakable-p (following-char))
365 366 367 368
		    (if (eq (preceding-char) ?')
			(not (memq (char-after (- (point) 2))
				   (list nil ?\n ? )))
		      (and (shr-char-kinsoku-bol-p (preceding-char))
369
			   (shr-char-breakable-p (following-char))
370
			   (not (shr-char-kinsoku-bol-p (following-char)))))
371
		    (shr-char-kinsoku-eol-p (following-char))))
372
      (backward-char 1))
373 374 375 376 377 378 379
    (if (and (not (or failed (eolp)))
	     (eq (preceding-char) ?'))
	(while (not (or (setq failed (eolp))
			(eq (following-char) ? )
			(shr-char-breakable-p (following-char))
			(shr-char-kinsoku-eol-p (following-char))))
	  (forward-char 1)))
380
    (if failed
381
	;; There's no breakable point, so we give it up.
382 383 384 385 386 387 388 389 390
	(let (found)
	  (goto-char bp)
	  (unless shr-kinsoku-shorten
	    (while (and (setq found (re-search-forward
				     "\\(\\c>\\)\\| \\|\\c<\\|\\c|"
				     (line-end-position) 'move))
			(eq (preceding-char) ?')))
	    (if (and found (not (match-beginning 1)))
		(goto-char (match-beginning 0)))))
391 392
      (or
       (eolp)
393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422
       ;; Don't put kinsoku-bol characters at the beginning of a line,
       ;; or kinsoku-eol characters at the end of a line.
       (cond
	(shr-kinsoku-shorten
	 (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
		     (shr-char-kinsoku-eol-p (preceding-char)))
	   (backward-char 1))
	 (when (setq failed (= (current-column) shr-indentation))
	   ;; There's no breakable point that doesn't violate kinsoku,
	   ;; so we look for the second best position.
	   (while (and (progn
			 (forward-char 1)
			 (<= (current-column) shr-width))
		       (progn
			 (setq bp (point))
			 (shr-char-kinsoku-eol-p (following-char)))))
	   (goto-char bp)))
	((shr-char-kinsoku-eol-p (preceding-char))
	 (if (shr-char-kinsoku-eol-p (following-char))
	     ;; There are consecutive kinsoku-eol characters.
	     (setq failed t)
	   (let ((count 4))
	     (while
		 (progn
		   (backward-char 1)
		   (and (> (setq count (1- count)) 0)
			(not (memq (preceding-char) (list ?\C-@ ?\n ? )))
			(or (shr-char-kinsoku-eol-p (preceding-char))
			    (shr-char-kinsoku-bol-p (following-char)))))))
	   (if (setq failed (= (current-column) shr-indentation))
423
	       ;; There's no breakable point that doesn't violate kinsoku,
424 425 426 427 428 429 430 431
	       ;; so we go to the second best position.
	       (if (looking-at "\\(\\c<+\\)\\c<")
		   (goto-char (match-end 1))
		 (forward-char 1)))))
	(t
	 (if (shr-char-kinsoku-bol-p (preceding-char))
	     ;; There are consecutive kinsoku-bol characters.
	     (setq failed t)
432 433
	   (let ((count 4))
	     (while (and (>= (setq count (1- count)) 0)
434 435 436 437 438 439
			 (shr-char-kinsoku-bol-p (following-char))
			 (shr-char-breakable-p (following-char)))
	       (forward-char 1))))))
       (when (eq (following-char) ? )
	 (forward-char 1))))
    (not failed)))
440

441 442 443
(defun shr-expand-url (url)
  (cond
   ;; Absolute URL.
444 445
   ((or (not url)
	(string-match "\\`[a-z]*:" url)
446 447 448
	(not shr-base))
    url)
   ((and (not (string-match "/\\'" shr-base))
449
	 (not (string-match "\\`/" url)))
450 451 452 453
    (concat shr-base "/" url))
   (t
    (concat shr-base url))))

454 455 456
(defun shr-ensure-newline ()
  (unless (zerop (current-column))
    (insert "\n")))
457 458 459

(defun shr-ensure-paragraph ()
  (unless (bobp)
460
    (if (<= (current-column) shr-indentation)
461 462 463
	(unless (save-excursion
		  (forward-line -1)
		  (looking-at " *$"))
464 465 466
	  (insert "\n"))
      (if (save-excursion
	    (beginning-of-line)
467
	    (looking-at " *$"))
468 469 470
	  (insert "\n")
	(insert "\n\n")))))

471
(defun shr-indent ()
472 473
  (when (> shr-indentation 0)
    (insert (make-string shr-indentation ? ))))
474

475
(defun shr-fontize-cont (cont &rest types)
476 477
  (let (shr-start)
    (shr-generic cont)
478 479
    (dolist (type types)
      (shr-add-font (or shr-start (point)) (point) type))))
480

481 482 483
;; Add an overlay in the region, but avoid putting the font properties
;; on blank text at the start of the line, and the newline at the end,
;; to avoid ugliness.
484
(defun shr-add-font (start end type)
485 486 487 488 489 490 491 492 493 494
  (save-excursion
    (goto-char start)
    (while (< (point) end)
      (when (bolp)
	(skip-chars-forward " "))
      (let ((overlay (make-overlay (point) (min (line-end-position) end))))
	(overlay-put overlay 'face type))
      (if (< (line-end-position) end)
	  (forward-line 1)
	(goto-char end)))))
495

496 497 498 499
(defun shr-browse-url ()
  "Browse the URL under point."
  (interactive)
  (let ((url (get-text-property (point) 'shr-url)))
500 501 502 503
    (cond
     ((not url)
      (message "No link under point"))
     ((string-match "^mailto:" url)
504
      (browse-url-mail url))
505 506
     (t
      (browse-url url)))))
507

508 509 510 511 512 513 514
(defun shr-save-contents (directory)
  "Save the contents from URL in a file."
  (interactive "DSave contents of URL to directory: ")
  (let ((url (get-text-property (point) 'shr-url)))
    (if (not url)
	(message "No link under point")
      (url-retrieve (shr-encode-url url)
515 516
		    'shr-store-contents (list url directory)
		    nil t))))
517 518 519 520 521 522 523 524 525

(defun shr-store-contents (status url directory)
  (unless (plist-get status :error)
    (when (or (search-forward "\n\n" nil t)
	      (search-forward "\r\n\r\n" nil t))
      (write-region (point) (point-max)
		    (expand-file-name (file-name-nondirectory url)
				      directory)))))

526 527 528 529 530 531 532 533
(defun shr-image-fetched (status buffer start end)
  (when (and (buffer-name buffer)
	     (not (plist-get status :error)))
    (url-store-in-cache (current-buffer))
    (when (or (search-forward "\n\n" nil t)
	      (search-forward "\r\n\r\n" nil t))
      (let ((data (buffer-substring (point) (point-max))))
        (with-current-buffer buffer
534 535 536 537 538
	  (save-excursion
	    (let ((alt (buffer-substring start end))
		  (inhibit-read-only t))
	      (delete-region start end)
	      (goto-char start)
539
	      (funcall shr-put-image-function data alt)))))))
540 541
  (kill-buffer (current-buffer)))

542
(defun shr-put-image (data alt)
543
  "Put image DATA with a string ALT.  Return image."
544 545 546 547
  (if (display-graphic-p)
      (let ((image (ignore-errors
                     (shr-rescale-image data))))
        (when image
548 549 550 551 552
	  ;; When inserting big-ish pictures, put them at the
	  ;; beginning of the line.
	  (when (and (> (current-column) 0)
		     (> (car (image-size image t)) 400))
	    (insert "\n"))
553 554 555
	  (insert-image image (or alt "*"))
	  (when (image-animated-p image)
	    (image-animate image nil 60)))
556
	image)
557
    (insert alt)))
558 559

(defun shr-rescale-image (data)
560
  (let ((image (create-image data nil t :ascent 100)))
561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586
    (if (or (not (fboundp 'imagemagick-types))
	    (not (get-buffer-window (current-buffer))))
	image
      (let* ((size (image-size image t))
	     (width (car size))
	     (height (cdr size))
	     (edges (window-inside-pixel-edges
		     (get-buffer-window (current-buffer))))
	     (window-width (truncate (* shr-max-image-proportion
					(- (nth 2 edges) (nth 0 edges)))))
	     (window-height (truncate (* shr-max-image-proportion
					 (- (nth 3 edges) (nth 1 edges)))))
	     scaled-image)
	(when (> height window-height)
	  (setq image (or (create-image data 'imagemagick t
					:height window-height
					:ascent 100)
			  image))
	  (setq size (image-size image t)))
	(when (> (car size) window-width)
	  (setq image (or
		       (create-image data 'imagemagick t
				     :width window-width
				     :ascent 100)
		       image)))
	image))))
587

Glenn Morris's avatar
Glenn Morris committed
588 589 590
;; url-cache-extract autoloads url-cache.
(declare-function url-cache-create-filename "url-cache" (url))
(autoload 'mm-disable-multibyte "mm-util")
591
(autoload 'browse-url-mail "browse-url")
Glenn Morris's avatar
Glenn Morris committed
592

593 594 595 596 597
(defun shr-get-image-data (url)
  "Get image data for URL.
Return a string with image data."
  (with-temp-buffer
    (mm-disable-multibyte)
598
    (when (ignore-errors
599
	    (url-cache-extract (url-cache-create-filename (shr-encode-url url)))
600 601 602 603
	    t)
      (when (or (search-forward "\n\n" nil t)
		(search-forward "\r\n\r\n" nil t))
	(buffer-substring (point) (point-max))))))
604

605 606 607 608
(defun shr-image-displayer (content-function)
  "Return a function to display an image.
CONTENT-FUNCTION is a function to retrieve an image for a cid url that
is an argument.  The function to be returned takes three arguments URL,
Paul Eggert's avatar
Paul Eggert committed
609
START, and END.  Note that START and END should be markers."
610
  `(lambda (url start end)
611 612 613 614 615 616 617
     (when url
       (if (string-match "\\`cid:" url)
	   ,(when content-function
	      `(let ((image (funcall ,content-function
				     (substring url (match-end 0)))))
		 (when image
		   (goto-char start)
618
		   (funcall shr-put-image-function
619
			    image (buffer-substring start end))
620
		   (delete-region (point) end))))
621 622
	 (url-retrieve url 'shr-image-fetched
		       (list (current-buffer) start end)
623
		       t t)))))
624

625 626 627 628 629
(defun shr-heading (cont &rest types)
  (shr-ensure-paragraph)
  (apply #'shr-fontize-cont cont types)
  (shr-ensure-paragraph))

Glenn Morris's avatar
Glenn Morris committed
630 631
(autoload 'widget-convert-button "wid-edit")

632
(defun shr-urlify (start url &optional title)
633 634
  (widget-convert-button
   'url-link start (point)
635
   :help-echo (if title (format "%s (%s)" url title) url)
636 637
   :keymap shr-map
   url)
638
  (shr-add-font start (point) 'shr-link)
639 640 641 642 643 644
  (put-text-property start (point) 'shr-url url))

(defun shr-encode-url (url)
  "Encode URL."
  (browse-url-url-encode-chars url "[)$ ]"))

645 646
(autoload 'shr-color-visible "shr-color")
(autoload 'shr-color->hexadecimal "shr-color")
647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669

(defun shr-color-check (fg bg)
  "Check that FG is visible on BG.
Returns (fg bg) with corrected values.
Returns nil if the colors that would be used are the default
ones, in case fg and bg are nil."
  (when (or fg bg)
    (let ((fixed (cond ((null fg) 'fg)
                       ((null bg) 'bg))))
      ;; Convert colors to hexadecimal, or set them to default.
      (let ((fg (or (shr-color->hexadecimal fg)
                    (frame-parameter nil 'foreground-color)))
            (bg (or (shr-color->hexadecimal bg)
                    (frame-parameter nil 'background-color))))
        (cond ((eq fixed 'bg)
               ;; Only return the new fg
               (list nil (cadr (shr-color-visible bg fg t))))
              ((eq fixed 'fg)
               ;; Invert args and results and return only the new bg
               (list (cadr (shr-color-visible fg bg t)) nil))
              (t
               (shr-color-visible bg fg)))))))

670
(defun shr-colorize-region (start end fg &optional bg)
671
  (when (or fg bg)
672
    (let ((new-colors (shr-color-check fg bg)))
673
      (when new-colors
674 675
	(when fg
	  (shr-put-color start end :foreground (cadr new-colors)))
676
	(when bg
677 678
	  (shr-put-color start end :background (car new-colors))))
      new-colors)))
679

U. Ser's avatar
U. Ser committed
680
;; Put a color in the region, but avoid putting colors on blank
681 682 683 684 685 686 687 688
;; text at the start of the line, and the newline at the end, to avoid
;; ugliness.  Also, don't overwrite any existing color information,
;; since this can be called recursively, and we want the "inner" color
;; to win.
(defun shr-put-color (start end type color)
  (save-excursion
    (goto-char start)
    (while (< (point) end)
689 690
      (when (and (bolp)
		 (not (eq type :background)))
691 692 693 694 695
	(skip-chars-forward " "))
      (when (> (line-end-position) (point))
	(shr-put-color-1 (point) (min (line-end-position) end) type color))
      (if (< (line-end-position) end)
	  (forward-line 1)
696
	(goto-char end)))
697 698
    (when (and (eq type :background)
	       (= shr-table-depth 0))
699 700 701 702
      (shr-expand-newlines start end color))))

(defun shr-expand-newlines (start end color)
  (save-restriction
703 704 705 706 707 708 709 710 711
    ;; Skip past all white space at the start and ends.
    (goto-char start)
    (skip-chars-forward " \t\n")
    (beginning-of-line)
    (setq start (point))
    (goto-char end)
    (skip-chars-backward " \t\n")
    (forward-line 1)
    (setq end (point))
712 713 714 715 716 717
    (narrow-to-region start end)
    (let ((width (shr-natural-width))
	  column)
      (goto-char (point-min))
      (while (not (eobp))
	(end-of-line)
718 719
	(when (and (< (setq column (current-column)) width)
		   (< (setq column (shr-previous-newline-padding-width column))
720
		      width))
721 722
	  (let ((overlay (make-overlay (point) (1+ (point)))))
	    (overlay-put overlay 'before-string
723 724 725
			 (concat
			  (mapconcat
			   (lambda (overlay)
726 727 728
			     (let ((string (plist-get
					    (overlay-properties overlay)
					    'before-string)))
729 730 731 732 733 734
			       (if (not string)
				   ""
				 (overlay-put overlay 'before-string "")
				 string)))
			   (overlays-at (point))
			   "")
735
			  (propertize (make-string (- width column) ? )
736
				      'face (list :background color))))))
737
	(forward-line 1)))))
738

739 740 741 742 743 744 745 746
(defun shr-previous-newline-padding-width (width)
  (let ((overlays (overlays-at (point)))
	(previous-width 0))
    (if (null overlays)
	width
      (dolist (overlay overlays)
	(setq previous-width
	      (+ previous-width
747 748
		 (length (plist-get (overlay-properties overlay)
				    'before-string)))))
749 750
      (+ width previous-width))))

751 752
(defun shr-put-color-1 (start end type color)
  (let* ((old-props (get-text-property start 'face))
753 754
	 (do-put (and (listp old-props)
                      (not (memq type old-props))))
755 756 757 758 759 760 761
	 change)
    (while (< start end)
      (setq change (next-single-property-change start 'face nil end))
      (when do-put
	(put-text-property start change 'face
			   (nconc (list type color) old-props)))
      (setq old-props (get-text-property change 'face))
762 763
      (setq do-put (and (listp old-props)
                        (not (memq type old-props))))
764 765 766 767 768
      (setq start change))
    (when (and do-put
	       (> end start))
      (put-text-property start end 'face
			 (nconc (list type color old-props))))))
769

770 771
;;; Tag-specific rendering rules.

772
(defun shr-tag-body (cont)
773
  (let* ((start (point))
774 775
	 (fgcolor (cdr (or (assq :fgcolor cont)
                           (assq :text cont))))
776
	 (bgcolor (cdr (assq :bgcolor cont)))
777 778
	 (shr-stylesheet (list (cons 'color fgcolor)
			       (cons 'background-color bgcolor))))
779
    (shr-generic cont)
780
    (shr-colorize-region start (point) fgcolor bgcolor)))
781

782 783 784
(defun shr-tag-style (cont)
  )

785 786 787
(defun shr-tag-script (cont)
  )

788 789 790
(defun shr-tag-comment (cont)
  )

791 792 793 794 795 796 797 798 799 800
(defun shr-tag-sup (cont)
  (let ((start (point)))
    (shr-generic cont)
    (put-text-property start (point) 'display '(raise 0.5))))

(defun shr-tag-sub (cont)
  (let ((start (point)))
    (shr-generic cont)
    (put-text-property start (point) 'display '(raise -0.5))))

801 802 803 804
(defun shr-tag-label (cont)
  (shr-generic cont)
  (shr-ensure-paragraph))

805 806
(defun shr-tag-p (cont)
  (shr-ensure-paragraph)
807
  (shr-indent)
808 809 810
  (shr-generic cont)
  (shr-ensure-paragraph))

Katsumi Yamaoka's avatar
Katsumi Yamaoka committed
811 812 813 814 815 816
(defun shr-tag-div (cont)
  (shr-ensure-newline)
  (shr-indent)
  (shr-generic cont)
  (shr-ensure-newline))

817 818 819
(defun shr-tag-s (cont)
  (shr-fontize-cont cont 'shr-strike-through))

820 821 822
(defun shr-tag-del (cont)
  (shr-fontize-cont cont 'shr-strike-through))

823 824 825 826 827 828 829 830 831
(defun shr-tag-b (cont)
  (shr-fontize-cont cont 'bold))

(defun shr-tag-i (cont)
  (shr-fontize-cont cont 'italic))

(defun shr-tag-em (cont)
  (shr-fontize-cont cont 'bold))

832 833 834
(defun shr-tag-strong (cont)
  (shr-fontize-cont cont 'bold))

835 836 837
(defun shr-tag-u (cont)
  (shr-fontize-cont cont 'underline))

838 839
(defun shr-parse-style (style)
  (when style
840 841 842
    (save-match-data
      (when (string-match "\n" style)
        (setq style (replace-match " " t t style))))
843 844 845 846 847 848 849 850
    (let ((plist nil))
      (dolist (elem (split-string style ";"))
	(when elem
	  (setq elem (split-string elem ":"))
	  (when (and (car elem)
		     (cadr elem))
	    (let ((name (replace-regexp-in-string "^ +\\| +$" "" (car elem)))
		  (value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem))))
851 852
	      (when (string-match " *!important\\'" value)
		(setq value (substring value 0 (match-beginning 0))))
853 854 855 856 857
	      (push (cons (intern name obarray)
			  value)
		    plist)))))
      plist)))

858 859 860
(defun shr-tag-base (cont)
  (setq shr-base (cdr (assq :href cont))))

861 862
(defun shr-tag-a (cont)
  (let ((url (cdr (assq :href cont)))
863
        (title (cdr (assq :title cont)))
864 865 866
	(start (point))
	shr-start)
    (shr-generic cont)
867
    (shr-urlify (or shr-start start) (shr-expand-url url) title)))
868 869

(defun shr-tag-object (cont)
870 871 872 873 874 875 876 877
  (let ((start (point))
	url)
    (dolist (elem cont)
      (when (eq (car elem) 'embed)
	(setq url (or url (cdr (assq :src (cdr elem))))))
      (when (and (eq (car elem) 'param)
		 (equal (cdr (assq :name (cdr elem))) "movie"))
	(setq url (or url (cdr (assq :value (cdr elem)))))))
878 879
    (when url
      (shr-insert " [multimedia] ")
880
      (shr-urlify start (shr-expand-url url)))
881 882 883 884 885 886 887
    (shr-generic cont)))

(defun shr-tag-video (cont)
  (let ((image (cdr (assq :poster cont)))
	(url (cdr (assq :src cont)))
	(start (point)))
    (shr-tag-img nil image)
888
    (shr-urlify start (shr-expand-url url))))
889

890 891 892 893
(defun shr-tag-img (cont &optional url)
  (when (or url
	    (and cont
		 (cdr (assq :src cont))))
894 895 896 897
    (when (and (> (current-column) 0)
	       (not (eq shr-state 'image)))
      (insert "\n"))
    (let ((alt (cdr (assq :alt cont)))
898
	  (url (shr-expand-url (or url (cdr (assq :src cont))))))
899 900
      (let ((start (point-marker)))
	(when (zerop (length alt))
901
	  (setq alt "*"))
902
	(cond
903 904 905 906
	 ((or (member (cdr (assq :height cont)) '("0" "1"))
	      (member (cdr (assq :width cont)) '("0" "1")))
	  ;; Ignore zero-sized or single-pixel images.
	  )
907 908 909 910 911 912 913
	 ((and (not shr-inhibit-images)
	       (string-match "\\`cid:" url))
	  (let ((url (substring url (match-end 0)))
		image)
	    (if (or (not shr-content-function)
		    (not (setq image (funcall shr-content-function url))))
		(insert alt)
914
	      (funcall shr-put-image-function image alt))))
915 916 917 918 919
	 ((or shr-inhibit-images
	      (and shr-blocked-images
		   (string-match shr-blocked-images url)))
	  (setq shr-start (point))
	  (let ((shr-state 'space))
920 921
	    (if (> (string-width alt) 8)
		(shr-insert (truncate-string-to-width alt 8))
922
	      (shr-insert alt))))
923 924
	 ((and (not shr-ignore-cache)
	       (url-is-cached (shr-encode-url url)))
925
	  (funcall shr-put-image-function (shr-get-image-data url) alt))
926
	 (t
927
	  (insert alt " ")
928 929 930 931 932
	  (when (and shr-ignore-cache
		     (url-is-cached (shr-encode-url url)))
	    (let ((file (url-cache-create-filename (shr-encode-url url))))
	      (when (file-exists-p file)
		(delete-file file))))
933
	  (url-queue-retrieve
934
	   (shr-encode-url url) 'shr-image-fetched
935
	   (list (current-buffer) start (set-marker (make-marker) (1- (point))))
936
	   t t)))
937 938 939 940 941 942 943
	(when (zerop shr-table-depth) ;; We are not in a table.
	  (put-text-property start (point) 'keymap shr-map)
	  (put-text-property start (point) 'shr-alt alt)
	  (put-text-property start (point) 'image-url url)
	  (put-text-property start (point) 'image-displayer
			     (shr-image-displayer shr-content-function))
	  (put-text-property start (point) 'help-echo alt))
944
	(setq shr-state 'image)))))
945 946 947 948

(defun shr-tag-pre (cont)
  (let ((shr-folding-mode 'none))
    (shr-ensure-newline)
949
    (shr-indent)
950 951 952 953 954
    (shr-generic cont)
    (shr-ensure-newline)))

(defun shr-tag-blockquote (cont)
  (shr-ensure-paragraph)
955
  (shr-indent)
956 957 958
  (let ((shr-indentation (+ shr-indentation 4)))
    (shr-generic cont))
  (shr-ensure-paragraph))
959 960 961 962

(defun shr-tag-ul (cont)
  (shr-ensure-paragraph)
  (let ((shr-list-mode 'ul))
963 964
    (shr-generic cont))
  (shr-ensure-paragraph))
965 966

(defun shr-tag-ol (cont)
967
  (shr-ensure-paragraph)
968
  (let ((shr-list-mode 1))
969 970
    (shr-generic cont))
  (shr-ensure-paragraph))
971 972

(defun shr-tag-li (cont)
973 974
  (shr-ensure-paragraph)
  (shr-indent)
975 976 977 978 979 980 981 982 983
  (let* ((bullet
	  (if (numberp shr-list-mode)
	      (prog1
		  (format "%d " shr-list-mode)
		(setq shr-list-mode (1+ shr-list-mode)))
	    "* "))
	 (shr-indentation (+ shr-indentation (length bullet))))
    (insert bullet)
    (shr-generic cont)))
984 985

(defun shr-tag-br (cont)
986
  (unless (bobp)
987 988
    (insert "\n")
    (shr-indent))
989 990 991
  (shr-generic cont))

(defun shr-tag-h1 (cont)
992
  (shr-heading cont 'bold 'underline))
993 994

(defun shr-tag-h2 (cont)
995
  (shr-heading cont 'bold))
996 997

(defun shr-tag-h3 (cont)
998
  (shr-heading cont 'italic))
999 1000

(defun shr-tag-h4 (cont)
1001
  (shr-heading cont))
1002 1003

(defun shr-tag-h5 (cont)
1004
  (shr-heading cont))
1005 1006

(defun shr-tag-h6 (cont)
1007
  (shr-heading cont<