Commit | Line | Data |
---|---|---|
367f7f81 LMI |
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 | ||
870409d4 G |
33 | (defgroup shr nil |
34 | "Simple HTML Renderer" | |
35 | :group 'mail) | |
36 | ||
37 | (defcustom shr-max-image-proportion 0.9 | |
38 | "How big pictures displayed are in relation to the window they're in. | |
39 | A value of 0.7 means that they are allowed to take up 70% of the | |
40 | width and height of the window. If they are larger than this, | |
41 | and Emacs supports it, then the images will be rescaled down to | |
42 | fit these criteria." | |
43 | :version "24.1" | |
44 | :group 'shr | |
45 | :type 'float) | |
46 | ||
47 | (defcustom shr-blocked-images nil | |
48 | "Images that have URLs matching this regexp will be blocked." | |
49 | :version "24.1" | |
50 | :group 'shr | |
51 | :type 'regexp) | |
52 | ||
53 | (defvar shr-folding-mode nil) | |
54 | (defvar shr-state nil) | |
55 | (defvar shr-start nil) | |
56 | ||
57 | (defvar shr-width 70) | |
58 | ||
59 | (defun shr-transform-dom (dom) | |
60 | (let ((result (list (pop dom)))) | |
61 | (dolist (arg (pop dom)) | |
62 | (push (cons (intern (concat ":" (symbol-name (car arg))) obarray) | |
63 | (cdr arg)) | |
64 | result)) | |
65 | (dolist (sub dom) | |
66 | (if (stringp sub) | |
67 | (push (cons :text sub) result) | |
68 | (push (shr-transform-dom sub) result))) | |
69 | (nreverse result))) | |
70 | ||
71 | ;;;###autoload | |
72 | (defun shr-insert-document (dom) | |
73 | (let ((shr-state nil) | |
74 | (shr-start nil)) | |
75 | (shr-descend (shr-transform-dom dom)))) | |
76 | ||
77 | (defun shr-descend (dom) | |
78 | (let ((function (intern (concat "shr-" (symbol-name (car dom))) obarray))) | |
79 | (if (fboundp function) | |
80 | (funcall function (cdr dom)) | |
81 | (shr-generic (cdr dom))))) | |
82 | ||
83 | (defun shr-generic (cont) | |
84 | (dolist (sub cont) | |
85 | (cond | |
86 | ((eq (car sub) :text) | |
87 | (shr-insert (cdr sub))) | |
88 | ((consp (cdr sub)) | |
89 | (shr-descend sub))))) | |
90 | ||
91 | (defun shr-p (cont) | |
92 | (shr-ensure-newline) | |
93 | (insert "\n") | |
94 | (shr-generic cont) | |
95 | (insert "\n")) | |
96 | ||
97 | (defun shr-b (cont) | |
98 | (shr-fontize-cont cont 'bold)) | |
99 | ||
100 | (defun shr-i (cont) | |
101 | (shr-fontize-cont cont 'italic)) | |
102 | ||
103 | (defun shr-u (cont) | |
104 | (shr-fontize-cont cont 'underline)) | |
105 | ||
106 | (defun shr-s (cont) | |
107 | (shr-fontize-cont cont 'strikethru)) | |
108 | ||
109 | (defun shr-fontize-cont (cont type) | |
110 | (let (shr-start) | |
111 | (shr-generic cont) | |
112 | (shr-add-font shr-start (point) type))) | |
113 | ||
114 | (defun shr-add-font (start end type) | |
115 | (let ((overlay (make-overlay start end))) | |
116 | (overlay-put overlay 'face type))) | |
117 | ||
118 | (defun shr-a (cont) | |
119 | (let ((url (cdr (assq :href cont))) | |
120 | shr-start) | |
121 | (shr-generic cont) | |
122 | (widget-convert-button | |
123 | 'link shr-start (point) | |
124 | :action 'shr-browse-url | |
125 | :url url | |
126 | :keymap widget-keymap | |
127 | :help-echo url))) | |
128 | ||
129 | (defun shr-browse-url (widget &rest stuff) | |
130 | (browse-url (widget-get widget :url))) | |
131 | ||
132 | (defun shr-img (cont) | |
133 | (let ((start (point-marker))) | |
134 | (let ((alt (cdr (assq :alt cont))) | |
135 | (url (cdr (assq :src cont)))) | |
136 | (when (zerop (length alt)) | |
137 | (setq alt "[img]")) | |
138 | (cond | |
139 | ((and shr-blocked-images | |
140 | (string-match shr-blocked-images url)) | |
141 | (insert alt)) | |
142 | ((url-is-cached (browse-url-url-encode-chars url "[&)$ ]")) | |
143 | (shr-put-image (shr-get-image-data url) (point) alt)) | |
144 | (t | |
145 | (insert alt) | |
146 | (url-retrieve url 'shr-image-fetched | |
147 | (list (current-buffer) start (point-marker)) | |
148 | t))) | |
149 | (insert " ") | |
150 | (setq shr-state 'image)))) | |
151 | ||
152 | (defun shr-image-fetched (status buffer start end) | |
153 | (when (and (buffer-name buffer) | |
154 | (not (plist-get status :error))) | |
155 | (url-store-in-cache (current-buffer)) | |
156 | (when (or (search-forward "\n\n" nil t) | |
157 | (search-forward "\r\n\r\n" nil t)) | |
158 | (let ((data (buffer-substring (point) (point-max)))) | |
159 | (with-current-buffer buffer | |
160 | (let ((alt (buffer-substring start end)) | |
161 | (inhibit-read-only t)) | |
162 | (delete-region start end) | |
163 | (shr-put-image data start alt)))))) | |
164 | (kill-buffer (current-buffer))) | |
165 | ||
166 | (defun shr-put-image (data point alt) | |
167 | (if (not (display-graphic-p)) | |
168 | (insert alt) | |
169 | (let ((image (shr-rescale-image data))) | |
170 | (put-image image point alt)))) | |
171 | ||
172 | (defun shr-rescale-image (data) | |
173 | (if (or (not (fboundp 'imagemagick-types)) | |
174 | (not (get-buffer-window (current-buffer)))) | |
175 | (create-image data nil t) | |
176 | (let* ((image (create-image data nil t)) | |
177 | (size (image-size image)) | |
178 | (width (car size)) | |
179 | (height (cdr size)) | |
180 | (edges (window-inside-pixel-edges | |
181 | (get-buffer-window (current-buffer)))) | |
182 | (window-width (truncate (* shr-max-image-proportion | |
183 | (- (nth 2 edges) (nth 0 edges))))) | |
184 | (window-height (truncate (* shr-max-image-proportion | |
185 | (- (nth 3 edges) (nth 1 edges))))) | |
186 | scaled-image) | |
187 | (when (> height window-height) | |
188 | (setq image (or (create-image data 'imagemagick t | |
189 | :height window-height) | |
190 | image)) | |
191 | (setq size (image-size image t))) | |
192 | (when (> (car size) window-width) | |
193 | (setq image (or | |
194 | (create-image data 'imagemagick t | |
195 | :width window-width) | |
196 | image))) | |
197 | image))) | |
198 | ||
199 | (defun shr-pre (cont) | |
200 | (let ((shr-folding-mode nil)) | |
201 | (shr-ensure-newline) | |
202 | (shr-generic cont) | |
203 | (shr-ensure-newline))) | |
204 | ||
205 | (defun shr-blockquote (cont) | |
206 | (shr-pre cont)) | |
207 | ||
208 | (defun shr-ensure-newline () | |
209 | (unless (zerop (current-column)) | |
210 | (insert "\n"))) | |
211 | ||
212 | (defun shr-insert (text) | |
213 | (when (eq shr-state 'image) | |
214 | (insert "\n") | |
215 | (setq shr-state nil)) | |
216 | (cond | |
217 | ((eq shr-folding-mode 'none) | |
218 | (insert t)) | |
219 | (t | |
220 | (let (column) | |
221 | (dolist (elem (split-string text)) | |
222 | (setq column (current-column)) | |
223 | (when (plusp column) | |
224 | (if (> (+ column (length elem) 1) shr-width) | |
225 | (insert "\n") | |
226 | (insert " "))) | |
227 | ;; The shr-start is a special variable that is used to pass | |
228 | ;; upwards the first point in the buffer where the text really | |
229 | ;; starts. | |
230 | (unless shr-start | |
231 | (setq shr-start (point))) | |
232 | (insert elem)))))) | |
233 | ||
234 | (defun shr-get-image-data (url) | |
235 | "Get image data for URL. | |
236 | Return a string with image data." | |
237 | (with-temp-buffer | |
238 | (mm-disable-multibyte) | |
239 | (url-cache-extract (url-cache-create-filename url)) | |
240 | (when (or (search-forward "\n\n" nil t) | |
241 | (search-forward "\r\n\r\n" nil t)) | |
242 | (buffer-substring (point) (point-max))))) | |
243 | ||
f3fd95db | 244 | (provide 'shr) |
367f7f81 LMI |
245 | |
246 | ;;; shr.el ends here |