Try to get the rescaling logic right for images that are just wide and not tall.
[gnus] / lisp / gnus-html.el
1 ;;; gnus-html.el --- Quoted-Printable functions
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 (require 'mm-url)
34
35 (defcustom gnus-html-cache-directory (nnheader-concat gnus-directory "html-cache/")
36   "Where Gnus will cache images it downloads from the web."
37   :version "24.1"
38   :group 'gnus-art
39   :type 'directory)
40
41 (defcustom gnus-html-cache-size 500000000
42   "The size of the Gnus image cache."
43   :version "24.1"
44   :group 'gnus-art
45   :type 'integer)
46
47 (defcustom gnus-html-frame-width 70
48   "What width to use when rendering HTML."
49   :version "24.1"
50   :group 'gnus-art
51   :type 'integer)
52
53 (defcustom gnus-blocked-images "."
54   "Images that have URLs matching this regexp will be blocked."
55   :version "24.1"
56   :group 'gnus-art
57   :type 'regexp)
58
59 (defcustom gnus-max-image-proportion 0.7
60   "How big pictures displayed are in relation to the window they're in.
61 A value of 0.7 means that they are allowed to take up 70% of the
62 width and height of the window.  If they are larger than this,
63 and Emacs supports it, then the images will be rescaled down to
64 fit these criteria."
65   :version "24.1"
66   :group 'gnus-art
67   :type 'float)
68
69 ;;;###autoload
70 (defun gnus-article-html (handle)
71   (let ((article-buffer (current-buffer)))
72     (save-restriction
73       (narrow-to-region (point) (point))
74       (save-excursion
75         (mm-with-part handle
76           (let* ((coding-system-for-read 'utf-8)
77                  (coding-system-for-write 'utf-8)
78                  (default-process-coding-system
79                    (cons coding-system-for-read coding-system-for-write))
80                  (charset (mail-content-type-get (mm-handle-type handle)
81                                                  'charset)))
82             (when (and charset
83                        (setq charset (mm-charset-to-coding-system charset))
84                        (not (eq charset 'ascii)))
85               (mm-decode-coding-region (point-min) (point-max) charset))
86             (call-process-region (point-min) (point-max)
87                                  "w3m" 
88                                  nil article-buffer nil
89                                  "-halfdump"
90                                  "-no-cookie"
91                                  "-I" "UTF-8"
92                                  "-O" "UTF-8"
93                                  "-o" "ext_halfdump=1"
94                                  "-o" "pre_conv=1"
95                                  "-t" (format "%s" tab-width)
96                                  "-cols" (format "%s" gnus-html-frame-width)
97                                  "-o" "display_image=off"
98                                  "-T" "text/html"))))
99       (gnus-html-wash-tags))))
100
101 (defvar gnus-article-mouse-face)
102
103 (defun gnus-html-wash-tags ()
104   (let (tag parameters string start end images url)
105     (mm-url-decode-entities)
106     (goto-char (point-min))
107     (while (re-search-forward "<\\([^ />]+\\)\\([^>]*\\)>" nil t)
108       (setq tag (match-string 1)
109             parameters (match-string 2)
110             start (match-beginning 0))
111       (when (plusp (length parameters))
112         (set-text-properties 0 (1- (length parameters)) nil parameters))
113       (delete-region start (point))
114       (when (search-forward (concat "</" tag ">") nil t)
115         (delete-region (match-beginning 0) (match-end 0)))
116       (setq end (point))
117       (cond
118        ;; Fetch and insert a picture.
119        ((equal tag "img_alt")
120         (when (string-match "src=\"\\([^\"]+\\)" parameters)
121           (setq url (match-string 1 parameters))
122           (gnus-message 8 "Fetching image URL %s" url)
123           (if (string-match "^cid:\\(.*\\)" url)
124               ;; URLs with cid: have their content stashed in other
125               ;; parts of the MIME structure, so just insert them
126               ;; immediately.
127               (let ((handle (mm-get-content-id
128                              (setq url (match-string 1 url))))
129                     image)
130                 (when handle
131                   (mm-with-part handle
132                     (setq image (gnus-create-image (buffer-string)
133                                                    nil t))))
134                 (when image
135                   (let ((string (buffer-substring start end)))
136                     (delete-region start end)
137                     (gnus-put-image image (gnus-string-or string "*")))))
138             ;; Normal, external URL.
139             (when (or (null gnus-blocked-images)
140                       (not (string-match gnus-blocked-images url)))
141               (let ((file (gnus-html-image-id url)))
142                 (if (file-exists-p file)
143                     ;; It's already cached, so just insert it.
144                     (let ((string (buffer-substring start end)))
145                       ;; Delete the ALT text.
146                       (delete-region start end)
147                       (gnus-html-put-image file (point) string))
148                   ;; We don't have it, so schedule it for fetching
149                   ;; asynchronously.
150                   (push (list url
151                               (set-marker (make-marker) start)
152                               (point-marker))
153                         images)))))))
154        ;; Add a link.
155        ((equal tag "a")
156         (when (string-match "href=\"\\([^\"]+\\)" parameters)
157           (setq url (match-string 1 parameters))
158           (gnus-message 8 "Fetching link URL %s" url)
159           (gnus-article-add-button start end
160                                    'browse-url url
161                                    url)
162           (let ((overlay (gnus-make-overlay start end)))
163             (gnus-overlay-put overlay 'evaporate t)
164             (gnus-overlay-put overlay 'gnus-button-url url)
165             (when gnus-article-mouse-face
166               (gnus-overlay-put overlay 'mouse-face gnus-article-mouse-face)))))
167        ;; The upper-case IMG_ALT is apparently just an artifact that
168        ;; should be deleted.
169        ((equal tag "IMG_ALT")
170         (delete-region start end))
171        ;; Whatever.  Just ignore the tag.
172        (t
173         ))
174       (goto-char start))
175     (goto-char (point-min))
176     ;; The output from -halfdump isn't totally regular, so strip
177     ;; off any </pre_int>s that were left over.
178     (while (re-search-forward "</pre_int>" nil t)
179       (replace-match "" t t))
180     (when images
181       (gnus-html-schedule-image-fetching (current-buffer) (nreverse images)))))
182
183 (defun gnus-html-schedule-image-fetching (buffer images)
184   (gnus-message 8 "Scheduling image fetching in buffer %s, images %s" buffer images)
185   (let* ((url (caar images))
186          (process (start-process
187                    "images" nil "curl"
188                    "-s" "--create-dirs"
189                    "--location"
190                    "--max-time" "60"
191                    "-o" (gnus-html-image-id url)
192                    url)))
193     (process-kill-without-query process)
194     (set-process-sentinel process 'gnus-html-curl-sentinel)
195     (gnus-set-process-plist process (list 'images images
196                                           'buffer buffer))))
197
198 (defun gnus-html-image-id (url)
199   (expand-file-name (sha1 url) gnus-html-cache-directory))
200
201 (defun gnus-html-curl-sentinel (process event)
202   (when (string-match "finished" event)
203     (let* ((images (gnus-process-get process 'images))
204            (buffer (gnus-process-get process 'buffer))
205            (spec (pop images))
206            (file (gnus-html-image-id (car spec))))
207       (when (and (buffer-live-p buffer)
208                  ;; If the position of the marker is 1, then that
209                  ;; means that the text it was in has been deleted;
210                  ;; i.e., that the user has selected a different
211                  ;; article before the image arrived.
212                  (not (= (marker-position (cadr spec)) (point-min))))
213         (with-current-buffer buffer
214           (let ((inhibit-read-only t)
215                 (string (buffer-substring (cadr spec) (caddr spec))))
216             (delete-region (cadr spec) (caddr spec))
217             (gnus-html-put-image file (cadr spec) string))))
218       (when images
219         (gnus-html-schedule-image-fetching buffer images)))))
220
221 (defun gnus-html-put-image (file point string)
222   (when (display-graphic-p)
223     (let ((image (ignore-errors
224                    (gnus-create-image file))))
225       (save-excursion
226         (goto-char point)
227         (if (and image
228                  ;; Kludge to avoid displaying 30x30 gif images, which
229                  ;; seems to be a signal of a broken image.
230                  (not (and (listp image)
231                            (eq (plist-get (cdr image) :type) 'gif)
232                            (= (car (image-size image t)) 30)
233                            (= (cdr (image-size image t)) 30))))
234             (progn
235               (gnus-put-image (gnus-html-rescale-image image)
236                               (gnus-string-or string "*"))
237               t)
238           (insert string)
239           (when (fboundp 'find-image)
240             (gnus-put-image (find-image
241                              '((:type xpm :file "lock-broken.xpm")))
242                             (gnus-string-or string "*")))
243           nil)))))
244
245 (defun gnus-html-rescale-image (image)
246   (if (not (fboundp 'imagemagick-types))
247       image
248     (let* ((width (car (image-size image t)))
249            (height (cdr (image-size image t)))
250            (edges (window-pixel-edges))
251            (window-width (truncate (* gnus-max-image-proportion
252                                       (- (nth 2 edges) (nth 0 edges)))))
253            (window-height (truncate (* gnus-max-image-proportion
254                                        (- (nth 3 edges) (nth 1 edges)))))
255            scaled-image)
256       (when (> width window-width)
257         (setq window-height (truncate (* window-height
258                                          (/ (* 1.0 window-width) width)))))
259       (or
260        (cond ((> height window-height)
261               (create-image file 'imagemagick nil
262                             :height window-height))
263              ((> width window-width)
264               (create-image file 'imagemagick nil
265                             :width window-width)))
266        image))))
267
268 (defun gnus-html-prune-cache ()
269   (let ((total-size 0)
270         files)
271     (dolist (file (directory-files gnus-html-cache-directory t nil t))
272       (let ((attributes (file-attributes file)))
273         (unless (nth 0 attributes)
274           (incf total-size (nth 7 attributes))
275           (push (list (time-to-seconds (nth 5 attributes))
276                       (nth 7 attributes) file)
277                 files))))
278     (when (> total-size gnus-html-cache-size)
279       (setq files (sort files (lambda (f1 f2)
280                                 (< (car f1) (car f2)))))
281       (dolist (file files)
282         (when (> total-size gnus-html-cache-size)
283           (decf total-size (cadr file))
284           (delete-file (nth 2 file)))))))
285
286 ;;;###autoload
287 (defun gnus-html-prefetch-images (summary)
288   (let (blocked-images urls)
289     (when (buffer-live-p summary)
290       (with-current-buffer summary
291         (setq blocked-images gnus-blocked-images))
292       (save-match-data
293         (while (re-search-forward "<img.*src=[\"']\\([^\"']+\\)" nil t)
294           (let ((url (match-string 1)))
295             (if (or (null blocked-images)
296                     (not (string-match blocked-images url)))
297                 (unless (file-exists-p (gnus-html-image-id url))
298                   (push url urls)
299                   (push (gnus-html-image-id url) urls)
300                   (push "-o" urls))
301               (gnus-message 8 "Image URL %s is blocked" url))))
302         (let ((process
303                (apply 'start-process 
304                       "images" nil "curl"
305                       "-s" "--create-dirs"
306                       "--location"
307                       "--max-time" "60"
308                       urls)))
309           (process-kill-without-query process))))))
310
311 (provide 'gnus-html)
312
313 ;;; gnus-html.el ends here