819a6d6f31a3abe883e6e37713469d61480ae68c
[gnus] / lisp / gnus-html.el
1 ;;; gnus-html.el --- Render HTML in a buffer.
2
3 ;; Copyright (C) 2010  Free Software Foundation, Inc.
4
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Keywords: html, web
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 ;; The idea is to provide a simple, fast and pretty minimal way to
26 ;; render HTML (including links and images) in a buffer, based on an
27 ;; external HTML renderer (i.e., w3m).
28
29 ;;; Code:
30
31 (eval-when-compile (require 'cl))
32 (eval-when-compile (require 'mm-decode))
33
34 (require 'gnus-art)
35 (require 'mm-url)
36 (require 'url)
37
38 (defcustom gnus-html-cache-directory (nnheader-concat gnus-directory "html-cache/")
39   "Where Gnus will cache images it downloads from the web."
40   :version "24.1"
41   :group 'gnus-art
42   :type 'directory)
43
44 (defcustom gnus-html-cache-size 500000000
45   "The size of the Gnus image cache."
46   :version "24.1"
47   :group 'gnus-art
48   :type 'integer)
49
50 (defcustom gnus-html-frame-width 70
51   "What width to use when rendering HTML."
52   :version "24.1"
53   :group 'gnus-art
54   :type 'integer)
55
56 (defcustom gnus-blocked-images "."
57   "Images that have URLs matching this regexp will be blocked."
58   :version "24.1"
59   :group 'gnus-art
60   :type 'regexp)
61
62 (defcustom gnus-max-image-proportion 0.7
63   "How big pictures displayed are in relation to the window they're in.
64 A value of 0.7 means that they are allowed to take up 70% of the
65 width and height of the window.  If they are larger than this,
66 and Emacs supports it, then the images will be rescaled down to
67 fit these criteria."
68   :version "24.1"
69   :group 'gnus-art
70   :type 'float)
71
72 (defvar gnus-html-image-map
73   (let ((map (make-sparse-keymap)))
74     (define-key map "u" 'gnus-article-copy-string)
75     (define-key map "i" 'gnus-html-insert-image)
76     map))
77
78 (defvar gnus-html-displayed-image-map
79   (let ((map (make-sparse-keymap)))
80     (define-key map "a" 'gnus-html-show-alt-text)
81     (define-key map "i" 'gnus-html-browse-image)
82     (define-key map "\r" 'gnus-html-browse-url)
83     (define-key map "u" 'gnus-article-copy-string)
84     (define-key map [tab] 'widget-forward)
85     map))
86
87 ;;;###autoload
88 (defun gnus-article-html (&optional handle)
89   (let ((article-buffer (current-buffer)))
90     (unless handle
91       (setq handle (mm-dissect-buffer t)))
92     (save-restriction
93       (narrow-to-region (point) (point))
94       (save-excursion
95         (mm-with-part handle
96           (let* ((coding-system-for-read 'utf-8)
97                  (coding-system-for-write 'utf-8)
98                  (default-process-coding-system
99                    (cons coding-system-for-read coding-system-for-write))
100                  (charset (mail-content-type-get (mm-handle-type handle)
101                                                  'charset)))
102             (when (and charset
103                        (setq charset (mm-charset-to-coding-system charset))
104                        (not (eq charset 'ascii)))
105               (insert (prog1
106                           (mm-decode-coding-string (buffer-string) charset)
107                         (erase-buffer)
108                         (mm-enable-multibyte))))
109             (call-process-region (point-min) (point-max)
110                                  "w3m"
111                                  nil article-buffer nil
112                                  "-halfdump"
113                                  "-no-cookie"
114                                  "-I" "UTF-8"
115                                  "-O" "UTF-8"
116                                  "-o" "ext_halfdump=1"
117                                  "-o" "display_ins_del=2"
118                                  "-o" "pre_conv=1"
119                                  "-t" (format "%s" tab-width)
120                                  "-cols" (format "%s" gnus-html-frame-width)
121                                  "-o" "display_image=on"
122                                  "-T" "text/html"))))
123       (gnus-html-wash-tags))))
124
125 (defvar gnus-article-mouse-face)
126
127 (defun gnus-html-pre-wash ()
128   (goto-char (point-min))
129   (while (re-search-forward " *<pre_int> *</pre_int> *\n" nil t)
130     (replace-match "" t t))
131   (goto-char (point-min))
132   (while (re-search-forward "<a name[^\n>]+>" nil t)
133     (replace-match "" t t)))
134
135 (defun gnus-html-wash-images ()
136   (let (tag parameters string start end images url)
137     (goto-char (point-min))
138     ;; Search for all the images first.
139     (while (re-search-forward "<img_alt \\([^>]*\\)>" nil t)
140       (setq parameters (match-string 1)
141             start (match-beginning 0))
142       (delete-region start (point))
143       (when (search-forward "</img_alt>" (line-end-position) t)
144         (delete-region (match-beginning 0) (match-end 0)))
145       (setq end (point))
146       (when (string-match "src=\"\\([^\"]+\\)" parameters)
147         (setq url (match-string 1 parameters))
148         (gnus-message 8 "gnus-html-wash-tags: fetching image URL %s" url)
149         (if (string-match "^cid:\\(.*\\)" url)
150             ;; URLs with cid: have their content stashed in other
151             ;; parts of the MIME structure, so just insert them
152             ;; immediately.
153             (let ((handle (mm-get-content-id
154                            (setq url (match-string 1 url))))
155                   image)
156               (when handle
157                 (mm-with-part handle
158                   (setq image (gnus-create-image (buffer-string)
159                                                  nil t))))
160               (when image
161                 (let ((string (buffer-substring start end)))
162                   (delete-region start end)
163                   (gnus-put-image image (gnus-string-or string "*") 'cid)
164                   (gnus-add-image 'cid image))))
165           ;; Normal, external URL.
166           (if (gnus-html-image-url-blocked-p
167                url
168                (if (buffer-live-p gnus-summary-buffer)
169                    (with-current-buffer gnus-summary-buffer
170                      gnus-blocked-images)
171                  gnus-blocked-images))
172               (progn
173                 (widget-convert-button
174                  'link start end
175                  :action 'gnus-html-insert-image
176                  :help-echo url
177                  :keymap gnus-html-image-map
178                  :button-keymap gnus-html-image-map)
179                 (let ((overlay (gnus-make-overlay start end))
180                       (spec (list url
181                                   (set-marker (make-marker) start)
182                                   (set-marker (make-marker) end))))
183                   (gnus-overlay-put overlay 'local-map gnus-html-image-map)
184                   (gnus-overlay-put overlay 'gnus-image spec)
185                   (gnus-put-text-property
186                    start end
187                    'gnus-image spec)))
188             (let ((file (gnus-html-image-id url))
189                   width height alt-text)
190               (when (string-match "height=\"?\\([0-9]+\\)" parameters)
191                 (setq height (string-to-number (match-string 1 parameters))))
192               (when (string-match "width=\"?\\([0-9]+\\)" parameters)
193                 (setq width (string-to-number (match-string 1 parameters))))
194               (when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)"
195                                   parameters)
196                 (setq alt-text (match-string 2 parameters)))
197               ;; Don't fetch images that are really small.  They're
198               ;; probably tracking pictures.
199               (when (and (or (null height)
200                              (> height 4))
201                          (or (null width)
202                              (> width 4)))
203                 (if (file-exists-p file)
204                     ;; It's already cached, so just insert it.
205                     (let ((string (buffer-substring start end)))
206                       ;; Delete the IMG text.
207                       (delete-region start end)
208                       (gnus-html-put-image file (point) string url alt-text))
209                   ;; We don't have it, so schedule it for fetching
210                   ;; asynchronously.
211                   (push (list url
212                               (set-marker (make-marker) start)
213                               (point-marker))
214                         images))))))))
215     (when images
216       (gnus-html-schedule-image-fetching (current-buffer) (nreverse images)))))
217
218 (defun gnus-html-wash-tags ()
219   (let (tag parameters string start end images url)
220     (gnus-html-pre-wash)
221     (gnus-html-wash-images)
222
223     (goto-char (point-min))
224     ;; Then do the other tags.
225     (while (re-search-forward "<\\([^ />]+\\)\\([^>]*\\)>" nil t)
226       (setq tag (match-string 1)
227             parameters (match-string 2)
228             start (match-beginning 0))
229       (when (plusp (length parameters))
230         (set-text-properties 0 (1- (length parameters)) nil parameters))
231       (delete-region start (point))
232       (when (search-forward (concat "</" tag ">") nil t)
233         (delete-region (match-beginning 0) (match-end 0)))
234       (setq end (point))
235       (cond
236        ;; Fetch and insert a picture.
237        ((equal tag "img_alt"))
238        ;; Add a link.
239        ((or (equal tag "a")
240             (equal tag "A"))
241         (when (string-match "href=\"\\([^\"]+\\)" parameters)
242           (setq url (match-string 1 parameters))
243           (gnus-message 8 "gnus-html-wash-tags: fetching link URL %s" url)
244           (gnus-article-add-button start end
245                                    'browse-url url
246                                    url)
247           (let ((overlay (gnus-make-overlay start end)))
248             (gnus-overlay-put overlay 'evaporate t)
249             (gnus-overlay-put overlay 'gnus-button-url url)
250             (gnus-put-text-property start end 'gnus-string url)
251             (when gnus-article-mouse-face
252               (gnus-overlay-put overlay 'mouse-face gnus-article-mouse-face)))))
253        ;; The upper-case IMG_ALT is apparently just an artifact that
254        ;; should be deleted.
255        ((equal tag "IMG_ALT")
256         (delete-region start end))
257        ;; w3m does not normalize the case
258        ((or (equal tag "b")
259             (equal tag "B"))
260         (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-bold))
261        ((or (equal tag "u")
262             (equal tag "U"))
263         (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-underline))
264        ((or (equal tag "i")
265             (equal tag "I"))
266         (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-italic))
267        ((or (equal tag "s")
268             (equal tag "S"))
269         (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-strikethru))
270        ((or (equal tag "ins")
271             (equal tag "INS"))
272         (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-underline))
273        ;; Handle different UL types
274        ((equal tag "_SYMBOL")
275         (when (string-match "TYPE=\\(.+\\)" parameters)
276           (let ((type (string-to-number (match-string 1 parameters))))
277             (delete-region start end)
278             (cond ((= type 33) (insert " "))
279                   ((= type 34) (insert " "))
280                   ((= type 35) (insert " "))
281                   ((= type 36) (insert " "))
282                   ((= type 37) (insert " "))
283                   ((= type 38) (insert " "))
284                   ((= type 39) (insert " "))
285                   ((= type 40) (insert " "))
286                   ((= type 42) (insert " "))
287                   ((= type 43) (insert " "))
288                   (t (insert " "))))))
289        ;; Whatever.  Just ignore the tag.
290        (t
291         ))
292       (goto-char start))
293     (goto-char (point-min))
294     ;; The output from -halfdump isn't totally regular, so strip
295     ;; off any </pre_int>s that were left over.
296     (while (re-search-forward "</pre_int>\\|</internal>" nil t)
297       (replace-match "" t t))
298     (mm-url-decode-entities)))
299
300 (defun gnus-html-insert-image ()
301   "Fetch and insert the image under point."
302   (interactive)
303   (gnus-html-schedule-image-fetching
304    (current-buffer) (list (get-text-property (point) 'gnus-image))))
305
306 (defun gnus-html-show-alt-text ()
307   "Show the ALT text of the image under point."
308   (interactive)
309   (message "%s" (get-text-property (point) 'gnus-alt-text)))
310
311 (defun gnus-html-browse-image ()
312   "Browse the image under point."
313   (interactive)
314   (browse-url (get-text-property (point) 'gnus-image)))
315
316 (defun gnus-html-browse-url ()
317   "Browse the image under point."
318   (interactive)
319   (let ((url (get-text-property (point) 'gnus-string)))
320     (if (not url)
321         (message "No URL at point")
322       (browse-url url))))
323
324 (defun gnus-html-schedule-image-fetching (buffer images)
325   (gnus-message 8 "gnus-html-schedule-image-fetching: buffer %s, images %s"
326                 buffer images)
327   (dolist (image images)
328     (ignore-errors
329       (url-retrieve (car image)
330                     'gnus-html-image-fetched
331                     (list buffer image)))))
332
333 (defun gnus-html-image-id (url)
334   (expand-file-name (sha1 url) gnus-html-cache-directory))
335
336 (defun gnus-html-image-fetched (status buffer image)
337   (let ((file (gnus-html-image-id (car image))))
338     ;; Search the start of the image data
339     (when (search-forward "\n\n" nil t)
340       ;; Write region (image data) silently
341       (write-region (point) (point-max) file nil 1)
342       (kill-buffer)
343       (when (and (buffer-live-p buffer)
344                  ;; If the `image' has no marker, do not replace anything
345                  (cadr image)
346                  ;; If the position of the marker is 1, then that
347                  ;; means that the text it was in has been deleted;
348                  ;; i.e., that the user has selected a different
349                  ;; article before the image arrived.
350                  (not (= (marker-position (cadr image)) (point-min))))
351         (with-current-buffer buffer
352           (let ((inhibit-read-only t)
353                 (string (buffer-substring (cadr image) (caddr image))))
354             (delete-region (cadr image) (caddr image))
355             (gnus-html-put-image file (cadr image) (car image) string)))))))
356
357 (defun gnus-html-put-image (file point string &optional url alt-text)
358   (when (gnus-graphic-display-p)
359     (let* ((image (ignore-errors
360                    (gnus-create-image file)))
361           (size (and image
362                      (if (featurep 'xemacs)
363                          (cons (glyph-width image) (glyph-height image))
364                        (image-size image t)))))
365       (save-excursion
366         (goto-char point)
367         (if (and image
368                  ;; Kludge to avoid displaying 30x30 gif images, which
369                  ;; seems to be a signal of a broken image.
370                  (not (and (if (featurep 'xemacs)
371                                (glyphp image)
372                              (listp image))
373                            (eq (if (featurep 'xemacs)
374                                    (let ((data (cdadar (specifier-spec-list
375                                                         (glyph-image image)))))
376                                      (and (vectorp data)
377                                           (aref data 0)))
378                                  (plist-get (cdr image) :type))
379                                'gif)
380                            (= (car size) 30)
381                            (= (cdr size) 30))))
382             (let ((start (point)))
383               (setq image (gnus-html-rescale-image image file size))
384               (gnus-put-image image
385                               (gnus-string-or string "*")
386                               'external)
387               (let ((overlay (gnus-make-overlay start (point))))
388                 (gnus-overlay-put overlay 'local-map
389                                   gnus-html-displayed-image-map)
390                 (gnus-put-text-property start (point) 'gnus-alt-text alt-text)
391                 (when url
392                   (gnus-put-text-property start (point) 'gnus-image url)))
393               (gnus-add-image 'external image)
394               t)
395           (insert string)
396           (when (fboundp 'find-image)
397             (setq image (find-image '((:type xpm :file "lock-broken.xpm"))))
398             (gnus-put-image image
399                             (gnus-string-or string "*")
400                             'internal)
401             (gnus-add-image 'internal image))
402           nil)))))
403
404 (defun gnus-html-rescale-image (image file size)
405   (if (or (not (fboundp 'imagemagick-types))
406           (not (get-buffer-window (current-buffer))))
407       image
408     (let* ((width (car size))
409            (height (cdr size))
410            (edges (window-pixel-edges (get-buffer-window (current-buffer))))
411            (window-width (truncate (* gnus-max-image-proportion
412                                       (- (nth 2 edges) (nth 0 edges)))))
413            (window-height (truncate (* gnus-max-image-proportion
414                                        (- (nth 3 edges) (nth 1 edges)))))
415            scaled-image)
416       (when (> height window-height)
417         (setq image (or (create-image file 'imagemagick nil
418                                       :height window-height)
419                         image))
420         (setq size (image-size image t)))
421       (when (> (car size) window-width)
422         (setq image (or
423                      (create-image file 'imagemagick nil
424                                    :width window-width)
425                      image)))
426       image)))
427
428 (defun gnus-html-prune-cache ()
429   (let ((total-size 0)
430         files)
431     (dolist (file (directory-files gnus-html-cache-directory t nil t))
432       (let ((attributes (file-attributes file)))
433         (unless (nth 0 attributes)
434           (incf total-size (nth 7 attributes))
435           (push (list (time-to-seconds (nth 5 attributes))
436                       (nth 7 attributes) file)
437                 files))))
438     (when (> total-size gnus-html-cache-size)
439       (setq files (sort files (lambda (f1 f2)
440                                 (< (car f1) (car f2)))))
441       (dolist (file files)
442         (when (> total-size gnus-html-cache-size)
443           (decf total-size (cadr file))
444           (delete-file (nth 2 file)))))))
445
446 (defun gnus-html-image-url-blocked-p (url blocked-images)
447   "Find out if URL is blocked by BLOCKED-IMAGES."
448   (let ((ret (and blocked-images
449                   (string-match blocked-images url))))
450     (if ret
451         (gnus-message 8 "gnus-html-image-url-blocked-p: %s blocked by regex %s"
452                       url blocked-images)
453       (gnus-message 9 "gnus-html-image-url-blocked-p: %s passes regex %s"
454                     url blocked-images))
455     ret))
456
457 (defun gnus-html-show-images ()
458   "Show any images that are in the HTML-rendered article buffer.
459 This only works if the article in question is HTML."
460   (interactive)
461   (gnus-with-article-buffer
462     (let ((overlays (overlays-in (point-min) (point-max)))
463           overlay images)
464       (while (setq overlay (pop overlays))
465         (when (overlay-get overlay 'gnus-image)
466           (push (overlay-get overlay 'gnus-image) images)))
467       (if (not images)
468           (message "No images to show")
469         (gnus-html-schedule-image-fetching (current-buffer) images)))))
470
471 ;;;###autoload
472 (defun gnus-html-prefetch-images (summary)
473   (when (buffer-live-p summary)
474     (let ((blocked-images (with-current-buffer summary
475                             gnus-blocked-images)))
476       (save-match-data
477         (while (re-search-forward "<img.*src=[\"']\\([^\"']+\\)" nil t)
478           (let ((url (match-string 1)))
479             (unless (gnus-html-image-url-blocked-p url blocked-images)
480               (unless (file-exists-p (gnus-html-image-id url))
481                 (ignore-errors
482                   (url-retrieve (mm-url-decode-entities-string url)
483                                 'gnus-html-image-fetched
484                                 (list nil (list url))))))))))))
485
486 (provide 'gnus-html)
487
488 ;;; gnus-html.el ends here