(browse-url): Required.
[gnus] / 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 (require 'browse-url)
34
35 (defgroup shr nil
36   "Simple HTML Renderer"
37   :group 'mail)
38
39 (defcustom shr-max-image-proportion 0.9
40   "How big pictures displayed are in relation to the window they're in.
41 A value of 0.7 means that they are allowed to take up 70% of the
42 width and height of the window.  If they are larger than this,
43 and Emacs supports it, then the images will be rescaled down to
44 fit these criteria."
45   :version "24.1"
46   :group 'shr
47   :type 'float)
48
49 (defcustom shr-blocked-images nil
50   "Images that have URLs matching this regexp will be blocked."
51   :version "24.1"
52   :group 'shr
53   :type 'regexp)
54
55 (defvar shr-folding-mode nil)
56 (defvar shr-state nil)
57 (defvar shr-start nil)
58 (defvar shr-indentation 0)
59
60 (defvar shr-width 70)
61
62 (defun shr-transform-dom (dom)
63   (let ((result (list (pop dom))))
64     (dolist (arg (pop dom))
65       (push (cons (intern (concat ":" (symbol-name (car arg))) obarray)
66                   (cdr arg))
67             result))
68     (dolist (sub dom)
69       (if (stringp sub)
70           (push (cons :text sub) result)
71         (push (shr-transform-dom sub) result)))
72     (nreverse result)))
73
74 ;;;###autoload
75 (defun shr-insert-document (dom)
76   (let ((shr-state nil)
77         (shr-start nil))
78     (shr-descend (shr-transform-dom dom))))
79
80 (defun shr-descend (dom)
81   (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray)))
82     (if (fboundp function)
83         (funcall function (cdr dom))
84       (shr-generic (cdr dom)))))
85
86 (defun shr-generic (cont)
87   (dolist (sub cont)
88     (cond
89      ((eq (car sub) :text)
90       (shr-insert (cdr sub)))
91      ((listp (cdr sub))
92       (shr-descend sub)))))
93
94 (defun shr-tag-p (cont)
95   (shr-ensure-paragraph)
96   (shr-generic cont)
97   (shr-ensure-paragraph))
98
99 (defun shr-ensure-paragraph ()
100   (unless (bobp)
101     (if (bolp)
102         (unless (eql (char-after (- (point) 2)) ?\n)
103           (insert "\n"))
104       (if (save-excursion
105             (beginning-of-line)
106             (looking-at " *$"))
107           (insert "\n")
108         (insert "\n\n")))))
109
110 (defun shr-tag-b (cont)
111   (shr-fontize-cont cont 'bold))
112
113 (defun shr-tag-i (cont)
114   (shr-fontize-cont cont 'italic))
115
116 (defun shr-tag-u (cont)
117   (shr-fontize-cont cont 'underline))
118
119 (defun shr-tag-s (cont)
120   (shr-fontize-cont cont 'strike-through))
121
122 (defun shr-fontize-cont (cont &rest types)
123   (let (shr-start)
124     (shr-generic cont)
125     (dolist (type types)
126       (shr-add-font (or shr-start (point)) (point) type))))
127
128 (defun shr-add-font (start end type)
129   (let ((overlay (make-overlay start end)))
130     (overlay-put overlay 'face type)))
131
132 (defun shr-tag-a (cont)
133   (let ((url (cdr (assq :href cont)))
134         shr-start)
135     (shr-generic cont)
136     (widget-convert-button
137      'link shr-start (point)
138      :action 'shr-browse-url
139      :url url
140      :keymap widget-keymap
141      :help-echo url)))
142
143 (defun shr-browse-url (widget &rest stuff)
144   (browse-url (widget-get widget :url)))
145
146 (defun shr-tag-img (cont)
147   (when (and (> (current-column) 0)
148              (not (eq shr-state 'image)))
149     (insert "\n"))
150   (let ((start (point-marker)))
151     (let ((alt (cdr (assq :alt cont)))
152           (url (cdr (assq :src cont))))
153       (when (zerop (length alt))
154         (setq alt "[img]"))
155       (cond
156        ((and shr-blocked-images
157              (string-match shr-blocked-images url))
158         (insert alt))
159        ((url-is-cached (browse-url-url-encode-chars url "[&)$ ]"))
160         (shr-put-image (shr-get-image-data url) (point) alt))
161        (t
162         (insert alt)
163         (url-retrieve url 'shr-image-fetched
164                       (list (current-buffer) start (point-marker))
165                       t)))
166       (insert " ")
167       (setq shr-state 'image))))
168
169 (defun shr-image-fetched (status buffer start end)
170   (when (and (buffer-name buffer)
171              (not (plist-get status :error)))
172     (url-store-in-cache (current-buffer))
173     (when (or (search-forward "\n\n" nil t)
174               (search-forward "\r\n\r\n" nil t))
175       (let ((data (buffer-substring (point) (point-max))))
176         (with-current-buffer buffer
177           (let ((alt (buffer-substring start end))
178                 (inhibit-read-only t))
179             (delete-region start end)
180             (shr-put-image data start alt))))))
181   (kill-buffer (current-buffer)))
182
183 (defun shr-put-image (data point alt)
184   (if (not (display-graphic-p))
185       (insert alt)
186     (let ((image (ignore-errors
187                    (shr-rescale-image data))))
188       (when image
189         (put-image image point alt)))))
190
191 (defun shr-rescale-image (data)
192   (if (or (not (fboundp 'imagemagick-types))
193           (not (get-buffer-window (current-buffer))))
194       (create-image data nil t)
195     (let* ((image (create-image data nil t))
196            (size (image-size image t))
197            (width (car size))
198            (height (cdr size))
199            (edges (window-inside-pixel-edges
200                    (get-buffer-window (current-buffer))))
201            (window-width (truncate (* shr-max-image-proportion
202                                       (- (nth 2 edges) (nth 0 edges)))))
203            (window-height (truncate (* shr-max-image-proportion
204                                        (- (nth 3 edges) (nth 1 edges)))))
205            scaled-image)
206       (when (> height window-height)
207         (setq image (or (create-image data 'imagemagick t
208                                       :height window-height)
209                         image))
210         (setq size (image-size image t)))
211       (when (> (car size) window-width)
212         (setq image (or
213                      (create-image data 'imagemagick t
214                                    :width window-width)
215                      image)))
216       image)))
217
218 (defun shr-tag-pre (cont)
219   (let ((shr-folding-mode 'none))
220     (shr-ensure-newline)
221     (shr-generic cont)
222     (shr-ensure-newline)))
223
224 (defun shr-tag-blockquote (cont)
225   (shr-ensure-paragraph)
226   (let ((shr-indentation (+ shr-indentation 4)))
227     (shr-generic cont)))
228
229 (defun shr-ensure-newline ()
230   (unless (zerop (current-column))
231     (insert "\n")))
232
233 (defun shr-insert (text)
234   (when (eq shr-state 'image)
235     (insert "\n")
236     (setq shr-state nil))
237   (cond
238    ((eq shr-folding-mode 'none)
239     (insert text))
240    (t
241     (let ((first t)
242           column)
243       (when (and (string-match "\\`[ \t\n]" text)
244                  (not (bolp)))
245         (insert " "))
246       (dolist (elem (split-string text))
247         (setq column (current-column))
248         (when (> column 0)
249           (cond
250            ((and (or (not first)
251                      (eq shr-state 'space))
252                  (> (+ column (length elem) 1) shr-width))
253             (insert "\n"))
254            ((not first)
255             (insert " "))))
256         (setq first nil)
257         (when (and (bolp)
258                    (> shr-indentation 0))
259           (shr-indent))
260         ;; The shr-start is a special variable that is used to pass
261         ;; upwards the first point in the buffer where the text really
262         ;; starts.
263         (unless shr-start
264           (setq shr-start (point)))
265         (insert elem))
266       (setq shr-state nil)
267       (when (and (string-match "[ \t\n]\\'" text)
268                  (not (bolp)))
269         (insert " ")
270         (setq shr-state 'space))))))
271
272 (defun shr-indent ()
273   (insert (make-string shr-indentation ? )))
274
275 (defun shr-get-image-data (url)
276   "Get image data for URL.
277 Return a string with image data."
278   (with-temp-buffer
279     (mm-disable-multibyte)
280     (url-cache-extract (url-cache-create-filename url))
281     (when (or (search-forward "\n\n" nil t)
282               (search-forward "\r\n\r\n" nil t))
283       (buffer-substring (point) (point-max)))))
284
285 (defvar shr-list-mode nil)
286
287 (defun shr-tag-ul (cont)
288   (shr-ensure-paragraph)
289   (let ((shr-list-mode 'ul))
290     (shr-generic cont)))
291
292 (defun shr-tag-ol (cont)
293   (let ((shr-list-mode 1))
294     (shr-generic cont)))
295
296 (defun shr-tag-li (cont)
297   (shr-ensure-newline)
298   (let* ((bullet
299           (if (numberp shr-list-mode)
300               (prog1
301                   (format "%d " shr-list-mode)
302                 (setq shr-list-mode (1+ shr-list-mode)))
303             "* "))
304          (shr-indentation (+ shr-indentation (length bullet))))
305     (insert bullet)
306     (shr-generic cont)))
307
308 (defun shr-tag-br (cont)
309   (unless (bobp)
310     (insert "\n"))
311   (shr-generic cont))
312
313 (defun shr-tag-h1 (cont)
314   (shr-heading cont 'bold 'underline))
315
316 (defun shr-tag-h2 (cont)
317   (shr-heading cont 'bold))
318
319 (defun shr-tag-h3 (cont)
320   (shr-heading cont 'italic))
321
322 (defun shr-tag-h4 (cont)
323   (shr-heading cont))
324
325 (defun shr-tag-h5 (cont)
326   (shr-heading cont))
327
328 (defun shr-tag-h6 (cont)
329   (shr-heading cont))
330
331 (defun shr-heading (cont &rest types)
332   (shr-ensure-paragraph)
333   (apply #'shr-fontize-cont cont types)
334   (shr-ensure-paragraph))
335
336 (defun shr-tag-table (cont)
337   (shr-ensure-paragraph)
338   (setq cont (or (cdr (assq 'tbody cont))
339                  cont))
340   (let* ((columns (shr-column-specs cont))
341          (suggested-widths (shr-pro-rate-columns columns))
342          (sketch (shr-make-table cont suggested-widths))
343          (sketch-widths (shr-table-widths sketch (length suggested-widths))))
344     (shr-insert-table (shr-make-table cont sketch-widths t) sketch-widths)))
345
346 (defun shr-insert-table (table widths)
347   (shr-insert-table-ruler widths)
348   (dolist (row table)
349     (let ((start (point))
350           (height (let ((max 0))
351                     (dolist (column row)
352                       (setq max (max max (cadr column))))
353                     max)))
354       (dotimes (i height)
355         (shr-indent)
356         (insert "|\n"))
357       (dolist (column row)
358         (goto-char start)
359         (let ((lines (split-string (nth 2 column) "\n")))
360           (dolist (line lines)
361             (when (> (length line) 0)
362               (end-of-line)
363               (insert line "|")
364               (forward-line 1)))
365           ;; Add blank lines at padding at the bottom of the TD,
366           ;; possibly.
367           (dotimes (i (- height (length lines)))
368             (end-of-line)
369             (insert (make-string (length (car lines)) ? ) "|")
370             (forward-line 1)))))
371     (shr-insert-table-ruler widths)))
372
373 (defun shr-insert-table-ruler (widths)
374   (shr-indent)
375   (insert "+")
376   (dotimes (i (length widths))
377     (insert (make-string (aref widths i) ?-) ?+))
378   (insert "\n"))
379
380 (defun shr-table-widths (table length)
381   (let ((widths (make-vector length 0)))
382     (dolist (row table)
383       (let ((i 0))
384         (dolist (column row)
385           (aset widths i (max (aref widths i)
386                               (car column)))
387           (incf i))))
388     widths))
389
390 (defun shr-make-table (cont widths &optional fill)
391   (let ((trs nil))
392     (dolist (row cont)
393       (when (eq (car row) 'tr)
394         (let ((i 0)
395               (tds nil))
396           (dolist (column (cdr row))
397             (when (memq (car column) '(td th))
398               (push (shr-render-td (cdr column) (aref widths i) fill)
399                     tds)
400               (setq i (1+ i))))
401           (push (nreverse tds) trs))))
402     (nreverse trs)))
403
404 (defun shr-render-td (cont width fill)
405   (with-temp-buffer
406     (let ((shr-width width))
407       (shr-generic cont))
408     (while (re-search-backward "\n *$" nil t)
409       (delete-region (match-beginning 0) (match-end 0)))
410     (goto-char (point-min))
411     (let ((max 0))
412       (while (not (eobp))
413         (end-of-line)
414         (setq max (max max (current-column)))
415         (forward-line 1))
416       (when fill
417         (goto-char (point-min))
418         (while (not (eobp))
419           (end-of-line)
420           (insert (make-string (- width (current-column)) ? ))
421           (forward-line 1)))
422       (list max (count-lines (point-min) (point-max)) (buffer-string)))))
423
424 (defun shr-pro-rate-columns (columns)
425   (let ((total-percentage 0)
426         (widths (make-vector (length columns) 0)))
427     (dotimes (i (length columns))
428       (incf total-percentage (aref columns i)))
429     (setq total-percentage (/ 1.0 total-percentage))
430     (dotimes (i (length columns))
431       (aset widths i (max (truncate (* (aref columns i)
432                                        total-percentage
433                                        shr-width))
434                           10)))
435     widths))
436
437 ;; Return a summary of the number and shape of the TDs in the table.
438 (defun shr-column-specs (cont)
439   (let ((columns (make-vector (shr-max-columns cont) 1)))
440     (dolist (row cont)
441       (when (eq (car row) 'tr)
442         (let ((i 0))
443           (dolist (column (cdr row))
444             (when (memq (car column) '(td th))
445               (let ((width (cdr (assq :width (cdr column)))))
446                 (when (and width
447                            (string-match "\\([0-9]+\\)%" width))
448                   (aset columns i
449                         (/ (string-to-number (match-string 1 width))
450                            100.0)))))
451             (setq i (1+ i))))))
452     columns))
453
454 (defun shr-count (cont elem)
455   (let ((i 0))
456     (dolist (sub cont)
457       (when (eq (car sub) elem)
458         (setq i (1+ i))))
459     i))
460
461 (defun shr-max-columns (cont)
462   (let ((max 0))
463     (dolist (row cont)
464       (when (eq (car row) 'tr)
465         (setq max (max max (shr-count (cdr row) 'td)))))
466     max))
467
468 (provide 'shr)
469
470 ;;; shr.el ends here