Commit | Line | Data |
---|---|---|
367f7f81 LMI |
1 | ;;; shr.el --- Simple HTML Renderer |
2 | ||
7e67562f | 3 | ;; Copyright (C) 2010-2012 Free Software Foundation, Inc. |
367f7f81 LMI |
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 | ||
3d319c8f | 33 | (eval-when-compile (require 'cl)) |
71e691a5 G |
34 | (require 'browse-url) |
35 | ||
870409d4 G |
36 | (defgroup shr nil |
37 | "Simple HTML Renderer" | |
2bed3f04 | 38 | :version "24.1" |
870409d4 G |
39 | :group 'mail) |
40 | ||
41 | (defcustom shr-max-image-proportion 0.9 | |
42 | "How big pictures displayed are in relation to the window they're in. | |
43 | A value of 0.7 means that they are allowed to take up 70% of the | |
44 | width and height of the window. If they are larger than this, | |
45 | and Emacs supports it, then the images will be rescaled down to | |
46 | fit these criteria." | |
47 | :version "24.1" | |
48 | :group 'shr | |
49 | :type 'float) | |
50 | ||
51 | (defcustom shr-blocked-images nil | |
52 | "Images that have URLs matching this regexp will be blocked." | |
53 | :version "24.1" | |
54 | :group 'shr | |
55 | :type 'regexp) | |
56 | ||
e37df674 | 57 | (defcustom shr-table-horizontal-line ?\s |
d3098750 LMI |
58 | "Character used to draw horizontal table lines." |
59 | :group 'shr | |
60 | :type 'character) | |
61 | ||
e37df674 | 62 | (defcustom shr-table-vertical-line ?\s |
d3098750 | 63 | "Character used to draw vertical table lines." |
afba0c4b | 64 | :group 'shr |
030158f3 | 65 | :type 'character) |
afba0c4b | 66 | |
e37df674 | 67 | (defcustom shr-table-corner ?\s |
d3098750 | 68 | "Character used to draw table corners." |
6b7df8d3 | 69 | :group 'shr |
030158f3 | 70 | :type 'character) |
6b7df8d3 G |
71 | |
72 | (defcustom shr-hr-line ?- | |
d3098750 | 73 | "Character used to draw hr lines." |
afba0c4b | 74 | :group 'shr |
030158f3 | 75 | :type 'character) |
afba0c4b | 76 | |
d0e0de31 | 77 | (defcustom shr-width fill-column |
bb7f5cbc G |
78 | "Frame width to use for rendering. |
79 | May either be an integer specifying a fixed width in characters, | |
80 | or nil, meaning that the full width of the window should be | |
81 | used." | |
82 | :type '(choice (integer :tag "Fixed width in characters") | |
83 | (const :tag "Use the width of the window" nil)) | |
d0e0de31 JD |
84 | :group 'shr) |
85 | ||
130e977f LMI |
86 | (defvar shr-content-function nil |
87 | "If bound, this should be a function that will return the content. | |
88 | This is used for cid: URLs, and the function is called with the | |
89 | cid: URL as the argument.") | |
90 | ||
b9bdaf74 KY |
91 | (defvar shr-put-image-function 'shr-put-image |
92 | "Function called to put image and alt string.") | |
93 | ||
6eee2678 LMI |
94 | (defface shr-strike-through '((t (:strike-through t))) |
95 | "Font for <s> elements." | |
96 | :group 'shr) | |
97 | ||
f8774e35 | 98 | (defface shr-link |
7ef1d634 | 99 | '((t (:inherit link))) |
df26ce09 | 100 | "Font for link elements." |
c2f51e23 G |
101 | :group 'shr) |
102 | ||
66627fa9 G |
103 | ;;; Internal variables. |
104 | ||
870409d4 G |
105 | (defvar shr-folding-mode nil) |
106 | (defvar shr-state nil) | |
107 | (defvar shr-start nil) | |
a41c2e6d | 108 | (defvar shr-indentation 0) |
130e977f | 109 | (defvar shr-inhibit-images nil) |
66627fa9 | 110 | (defvar shr-list-mode nil) |
3d319c8f | 111 | (defvar shr-content-cache nil) |
83ffd571 | 112 | (defvar shr-kinsoku-shorten nil) |
99e65b2d | 113 | (defvar shr-table-depth 0) |
04db63bc | 114 | (defvar shr-stylesheet nil) |
dbd5ffad | 115 | (defvar shr-base nil) |
728518c3 | 116 | (defvar shr-ignore-cache nil) |
870409d4 | 117 | |
71e691a5 G |
118 | (defvar shr-map |
119 | (let ((map (make-sparse-keymap))) | |
120 | (define-key map "a" 'shr-show-alt-text) | |
121 | (define-key map "i" 'shr-browse-image) | |
89b163db | 122 | (define-key map "z" 'shr-zoom-image) |
71e691a5 G |
123 | (define-key map "I" 'shr-insert-image) |
124 | (define-key map "u" 'shr-copy-url) | |
125 | (define-key map "v" 'shr-browse-url) | |
cdf1fca4 | 126 | (define-key map "o" 'shr-save-contents) |
71e691a5 G |
127 | (define-key map "\r" 'shr-browse-url) |
128 | map)) | |
129 | ||
66627fa9 G |
130 | ;; Public functions and commands. |
131 | ||
7b953864 SM |
132 | (defun shr-render-buffer (buffer) |
133 | "Display the HTML rendering of the current buffer." | |
134 | (interactive (list (current-buffer))) | |
1518e4f0 G |
135 | (pop-to-buffer "*html*") |
136 | (erase-buffer) | |
137 | (shr-insert-document | |
7b953864 | 138 | (with-current-buffer buffer |
edd9679c LMI |
139 | (libxml-parse-html-region (point-min) (point-max)))) |
140 | (goto-char (point-min))) | |
1518e4f0 | 141 | |
7b953864 SM |
142 | (defun shr-visit-file (file) |
143 | "Parse FILE as an HTML document, and render it in a new buffer." | |
144 | (interactive "fHTML file name: ") | |
145 | (with-temp-buffer | |
146 | (insert-file-contents file) | |
147 | (shr-render-buffer (current-buffer)))) | |
148 | ||
66627fa9 G |
149 | ;;;###autoload |
150 | (defun shr-insert-document (dom) | |
9ed5a258 LI |
151 | "Render the parsed document DOM into the current buffer. |
152 | DOM should be a parse tree as generated by | |
153 | `libxml-parse-html-region' or similar." | |
3d319c8f | 154 | (setq shr-content-cache nil) |
9ed5a258 LI |
155 | (let ((start (point)) |
156 | (shr-state nil) | |
bb7f5cbc | 157 | (shr-start nil) |
dbd5ffad | 158 | (shr-base nil) |
bb7f5cbc | 159 | (shr-width (or shr-width (window-width)))) |
9ed5a258 LI |
160 | (shr-descend (shr-transform-dom dom)) |
161 | (shr-remove-trailing-whitespace start (point)))) | |
162 | ||
163 | (defun shr-remove-trailing-whitespace (start end) | |
7c4bbb69 LI |
164 | (let ((width (window-width))) |
165 | (save-restriction | |
166 | (narrow-to-region start end) | |
167 | (goto-char start) | |
168 | (while (not (eobp)) | |
169 | (end-of-line) | |
888ab661 | 170 | (when (> (shr-previous-newline-padding-width (current-column)) width) |
7c4bbb69 LI |
171 | (dolist (overlay (overlays-at (point))) |
172 | (when (overlay-get overlay 'before-string) | |
173 | (overlay-put overlay 'before-string nil)))) | |
174 | (forward-line 1))))) | |
66627fa9 G |
175 | |
176 | (defun shr-copy-url () | |
177 | "Copy the URL under point to the kill ring. | |
178 | If called twice, then try to fetch the URL and see whether it | |
179 | redirects somewhere else." | |
180 | (interactive) | |
181 | (let ((url (get-text-property (point) 'shr-url))) | |
182 | (cond | |
183 | ((not url) | |
184 | (message "No URL under point")) | |
185 | ;; Resolve redirected URLs. | |
186 | ((equal url (car kill-ring)) | |
187 | (url-retrieve | |
188 | url | |
189 | (lambda (a) | |
190 | (when (and (consp a) | |
191 | (eq (car a) :redirect)) | |
192 | (with-temp-buffer | |
193 | (insert (cadr a)) | |
194 | (goto-char (point-min)) | |
195 | ;; Remove common tracking junk from the URL. | |
196 | (when (re-search-forward ".utm_.*" nil t) | |
197 | (replace-match "" t t)) | |
198 | (message "Copied %s" (buffer-string)) | |
038b3495 LI |
199 | (copy-region-as-kill (point-min) (point-max))))) |
200 | nil t)) | |
66627fa9 G |
201 | ;; Copy the URL to the kill ring. |
202 | (t | |
203 | (with-temp-buffer | |
204 | (insert url) | |
205 | (copy-region-as-kill (point-min) (point-max)) | |
206 | (message "Copied %s" url)))))) | |
207 | ||
208 | (defun shr-show-alt-text () | |
209 | "Show the ALT text of the image under point." | |
210 | (interactive) | |
211 | (let ((text (get-text-property (point) 'shr-alt))) | |
212 | (if (not text) | |
213 | (message "No image under point") | |
214 | (message "%s" text)))) | |
215 | ||
2da9c605 G |
216 | (defun shr-browse-image (&optional copy-url) |
217 | "Browse the image under point. | |
218 | If COPY-URL (the prefix if called interactively) is non-nil, copy | |
219 | the URL of the image to the kill buffer instead." | |
220 | (interactive "P") | |
8b6f6573 | 221 | (let ((url (get-text-property (point) 'image-url))) |
2da9c605 G |
222 | (cond |
223 | ((not url) | |
224 | (message "No image under point")) | |
225 | (copy-url | |
226 | (with-temp-buffer | |
227 | (insert url) | |
228 | (copy-region-as-kill (point-min) (point-max)) | |
229 | (message "Copied %s" url))) | |
230 | (t | |
66627fa9 | 231 | (message "Browsing %s..." url) |
2da9c605 | 232 | (browse-url url))))) |
66627fa9 | 233 | |
3d319c8f LMI |
234 | (defun shr-insert-image () |
235 | "Insert the image under point into the buffer." | |
236 | (interactive) | |
8b6f6573 | 237 | (let ((url (get-text-property (point) 'image-url))) |
3d319c8f LMI |
238 | (if (not url) |
239 | (message "No image under point") | |
240 | (message "Inserting %s..." url) | |
241 | (url-retrieve url 'shr-image-fetched | |
242 | (list (current-buffer) (1- (point)) (point-marker)) | |
038b3495 | 243 | t t)))) |
3d319c8f | 244 | |
89b163db G |
245 | (defun shr-zoom-image () |
246 | "Toggle the image size. | |
247 | The size will be rotated between the default size, the original | |
248 | size, and full-buffer size." | |
249 | (interactive) | |
250 | (let ((url (get-text-property (point) 'image-url)) | |
251 | (size (get-text-property (point) 'image-size)) | |
252 | (buffer-read-only nil)) | |
253 | (if (not url) | |
254 | (message "No image under point") | |
255 | ;; Delete the old picture. | |
256 | (while (get-text-property (point) 'image-url) | |
257 | (forward-char -1)) | |
258 | (forward-char 1) | |
259 | (let ((start (point))) | |
260 | (while (get-text-property (point) 'image-url) | |
261 | (forward-char 1)) | |
262 | (forward-char -1) | |
263 | (put-text-property start (point) 'display nil) | |
264 | (when (> (- (point) start) 2) | |
265 | (delete-region start (1- (point))))) | |
266 | (message "Inserting %s..." url) | |
267 | (url-retrieve url 'shr-image-fetched | |
268 | (list (current-buffer) (1- (point)) (point-marker) | |
269 | (list (cons 'size | |
270 | (cond ((or (eq size 'default) | |
271 | (null size)) | |
272 | 'original) | |
273 | ((eq size 'original) | |
274 | 'full) | |
275 | ((eq size 'full) | |
276 | 'default))))) | |
277 | t)))) | |
278 | ||
66627fa9 G |
279 | ;;; Utility functions. |
280 | ||
870409d4 G |
281 | (defun shr-transform-dom (dom) |
282 | (let ((result (list (pop dom)))) | |
283 | (dolist (arg (pop dom)) | |
284 | (push (cons (intern (concat ":" (symbol-name (car arg))) obarray) | |
285 | (cdr arg)) | |
286 | result)) | |
287 | (dolist (sub dom) | |
288 | (if (stringp sub) | |
953d41c4 | 289 | (push (cons 'text sub) result) |
870409d4 G |
290 | (push (shr-transform-dom sub) result))) |
291 | (nreverse result))) | |
292 | ||
870409d4 | 293 | (defun shr-descend (dom) |
ebe79557 LMI |
294 | (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray)) |
295 | (style (cdr (assq :style (cdr dom)))) | |
04db63bc | 296 | (shr-stylesheet shr-stylesheet) |
ebe79557 | 297 | (start (point))) |
b31b26b4 G |
298 | (when style |
299 | (if (string-match "color" style) | |
300 | (setq shr-stylesheet (nconc (shr-parse-style style) | |
301 | shr-stylesheet)) | |
302 | (setq style nil))) | |
870409d4 G |
303 | (if (fboundp function) |
304 | (funcall function (cdr dom)) | |
ebe79557 | 305 | (shr-generic (cdr dom))) |
b31b26b4 G |
306 | ;; If style is set, then this node has set the color. |
307 | (when style | |
308 | (shr-colorize-region start (point) | |
309 | (cdr (assq 'color shr-stylesheet)) | |
310 | (cdr (assq 'background-color shr-stylesheet)))))) | |
870409d4 G |
311 | |
312 | (defun shr-generic (cont) | |
313 | (dolist (sub cont) | |
314 | (cond | |
953d41c4 | 315 | ((eq (car sub) 'text) |
870409d4 | 316 | (shr-insert (cdr sub))) |
a41c2e6d | 317 | ((listp (cdr sub)) |
870409d4 G |
318 | (shr-descend sub))))) |
319 | ||
ed797193 G |
320 | (defmacro shr-char-breakable-p (char) |
321 | "Return non-nil if a line can be broken before and after CHAR." | |
322 | `(aref fill-find-break-point-function-table ,char)) | |
323 | (defmacro shr-char-nospace-p (char) | |
324 | "Return non-nil if no space is required before and after CHAR." | |
325 | `(aref fill-nospace-between-words-table ,char)) | |
326 | ||
327 | ;; KINSOKU is a Japanese word meaning a rule that should not be violated. | |
328 | ;; In Emacs, it is a term used for characters, e.g. punctuation marks, | |
329 | ;; parentheses, and so on, that should not be placed in the beginning | |
330 | ;; of a line or the end of a line. | |
331 | (defmacro shr-char-kinsoku-bol-p (char) | |
332 | "Return non-nil if a line ought not to begin with CHAR." | |
333 | `(aref (char-category-set ,char) ?>)) | |
334 | (defmacro shr-char-kinsoku-eol-p (char) | |
335 | "Return non-nil if a line ought not to end with CHAR." | |
336 | `(aref (char-category-set ,char) ?<)) | |
337 | (unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35)) | |
338 | (load "kinsoku" nil t)) | |
339 | ||
66627fa9 | 340 | (defun shr-insert (text) |
6b7df8d3 | 341 | (when (and (eq shr-state 'image) |
89b163db | 342 | (not (bolp)) |
6b7df8d3 | 343 | (not (string-match "\\`[ \t\n]+\\'" text))) |
66627fa9 G |
344 | (insert "\n") |
345 | (setq shr-state nil)) | |
346 | (cond | |
347 | ((eq shr-folding-mode 'none) | |
348 | (insert text)) | |
349 | (t | |
89b163db | 350 |