Commit | Line | Data |
---|---|---|
dda00b2c BW |
1 | ;;; mh-xface.el --- MH-E X-Face and Face header field display |
2 | ||
ba318903 | 3 | ;; Copyright (C) 2002-2003, 2005-2014 Free Software Foundation, Inc. |
dda00b2c BW |
4 | |
5 | ;; Author: Bill Wohler <wohler@newt.com> | |
6 | ;; Maintainer: Bill Wohler <wohler@newt.com> | |
7 | ;; Keywords: mail | |
8 | ;; See: mh-e.el | |
9 | ||
10 | ;; This file is part of GNU Emacs. | |
11 | ||
5e809f55 | 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
dda00b2c | 13 | ;; it under the terms of the GNU General Public License as published by |
5e809f55 GM |
14 | ;; the Free Software Foundation, either version 3 of the License, or |
15 | ;; (at your option) any later version. | |
dda00b2c BW |
16 | |
17 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;; GNU General Public License for more details. | |
21 | ||
22 | ;; You should have received a copy of the GNU General Public License | |
5e809f55 | 23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
dda00b2c BW |
24 | |
25 | ;;; Commentary: | |
26 | ||
27 | ;;; Change Log: | |
28 | ||
29 | ;;; Code: | |
30 | ||
31 | (require 'mh-e) | |
32 | (mh-require-cl) | |
33 | ||
34 | (autoload 'message-fetch-field "message") | |
35 | ||
36 | (defvar mh-show-xface-function | |
a3269bc4 | 37 | (cond ((and (featurep 'xemacs) (locate-library "x-face") (not (featurep 'xface))) |
dda00b2c BW |
38 | (load "x-face" t t) |
39 | #'mh-face-display-function) | |
40 | ((>= emacs-major-version 21) | |
41 | #'mh-face-display-function) | |
42 | (t #'ignore)) | |
43 | "Determine at run time what function should be called to display X-Face.") | |
44 | ||
45 | (defvar mh-uncompface-executable | |
46 | (and (fboundp 'executable-find) (executable-find "uncompface"))) | |
47 | ||
48 | \f | |
49 | ||
50 | ;;; X-Face Display | |
51 | ||
52 | ;;;###mh-autoload | |
53 | (defun mh-show-xface () | |
54 | "Display X-Face." | |
55 | (when (and window-system mh-show-use-xface-flag | |
56 | (or mh-decode-mime-flag mh-mhl-format-file | |
57 | mh-clean-message-header-flag)) | |
58 | (funcall mh-show-xface-function))) | |
59 | ||
dda00b2c BW |
60 | (defun mh-face-display-function () |
61 | "Display a Face, X-Face, or X-Image-URL header field. | |
62 | If more than one of these are present, then the first one found | |
63 | in this order is used." | |
64 | (save-restriction | |
65 | (goto-char (point-min)) | |
66 | (re-search-forward "\n\n" (point-max) t) | |
67 | (narrow-to-region (point-min) (point)) | |
68 | (let* ((case-fold-search t) | |
dda00b2c BW |
69 | (face (message-fetch-field "face" t)) |
70 | (x-face (message-fetch-field "x-face" t)) | |
71 | (url (message-fetch-field "x-image-url" t)) | |
72 | raw type) | |
73 | (cond (face (setq raw (mh-face-to-png face) | |
74 | type 'png)) | |
75 | (x-face (setq raw (mh-uncompface x-face) | |
76 | type 'pbm)) | |
77 | (url (setq type 'url)) | |
86e1c36a | 78 | (t (multiple-value-setq (type raw) |
7c730dd6 | 79 | (values-list (mh-picon-get-image))))) |
dda00b2c BW |
80 | (when type |
81 | (goto-char (point-min)) | |
82 | (when (re-search-forward "^from:" (point-max) t) | |
83 | ;; GNU Emacs | |
84 | (mh-do-in-gnu-emacs | |
85 | (if (eq type 'url) | |
86 | (mh-x-image-url-display url) | |
87 | (mh-funcall-if-exists | |
88 | insert-image (create-image | |
89 | raw type t | |
90 | :foreground | |
06e7028b | 91 | (mh-face-foreground 'mh-show-xface nil t) |
dda00b2c | 92 | :background |
06e7028b | 93 | (mh-face-background 'mh-show-xface nil t)) |
dda00b2c BW |
94 | " "))) |
95 | ;; XEmacs | |
96 | (mh-do-in-xemacs | |
97 | (cond | |
98 | ((eq type 'url) | |
99 | (mh-x-image-url-display url)) | |
100 | ((eq type 'png) | |
101 | (when (featurep 'png) | |
102 | (set-extent-begin-glyph | |
103 | (make-extent (point) (point)) | |
104 | (make-glyph (vector 'png ':data (mh-face-to-png face)))))) | |
105 | ;; Try internal xface support if available... | |
106 | ((and (eq type 'pbm) (featurep 'xface)) | |
107 | (set-glyph-face | |
108 | (set-extent-begin-glyph | |
109 | (make-extent (point) (point)) | |
110 | (make-glyph (vector 'xface ':data (concat "X-Face: " x-face)))) | |
111 | 'mh-show-xface)) | |
112 | ;; Otherwise try external support with x-face... | |
113 | ((and (eq type 'pbm) | |
114 | (fboundp 'x-face-xmas-wl-display-x-face) | |
115 | (fboundp 'executable-find) (executable-find "uncompface")) | |
116 | (mh-funcall-if-exists x-face-xmas-wl-display-x-face)) | |
117 | ;; Picon display | |
118 | ((and raw (member type '(xpm xbm gif))) | |
119 | (when (featurep type) | |
120 | (set-extent-begin-glyph | |
121 | (make-extent (point) (point)) | |
122 | (make-glyph (vector type ':data raw)))))) | |
123 | (when raw (insert " ")))))))) | |
124 | ||
125 | (defun mh-face-to-png (data) | |
126 | "Convert base64 encoded DATA to png image." | |
127 | (with-temp-buffer | |
5a47220a BW |
128 | (if (fboundp 'set-buffer-multibyte) |
129 | (set-buffer-multibyte nil)) | |
dda00b2c BW |
130 | (insert data) |
131 | (ignore-errors (base64-decode-region (point-min) (point-max))) | |
132 | (buffer-string))) | |
133 | ||
134 | (defun mh-uncompface (data) | |
135 | "Run DATA through `uncompface' to generate bitmap." | |
136 | (with-temp-buffer | |
5a47220a BW |
137 | (if (fboundp 'set-buffer-multibyte) |
138 | (set-buffer-multibyte nil)) | |
dda00b2c BW |
139 | (insert data) |
140 | (when (and mh-uncompface-executable | |
141 | (equal (call-process-region (point-min) (point-max) | |
142 | mh-uncompface-executable t '(t nil)) | |
143 | 0)) | |
144 | (mh-icontopbm) | |
145 | (buffer-string)))) | |
146 | ||
147 | (defun mh-icontopbm () | |
148 | "Elisp substitute for `icontopbm'." | |
149 | (goto-char (point-min)) | |
150 | (let ((end (point-max))) | |
151 | (while (re-search-forward "0x\\(..\\)\\(..\\)," nil t) | |
152 | (save-excursion | |
153 | (goto-char (point-max)) | |
154 | (insert (string-to-number (match-string 1) 16)) | |
155 | (insert (string-to-number (match-string 2) 16)))) | |
156 | (delete-region (point-min) end) | |
157 | (goto-char (point-min)) | |
158 | (insert "P4\n48 48\n"))) | |
159 | ||
160 | \f | |
161 | ||
162 | ;;; Picon Display | |
163 | ||
164 | ;; XXX: This should be customizable. As a side-effect of setting this | |
165 | ;; variable, arrange to reset mh-picon-existing-directory-list to 'unset. | |
166 | (defvar mh-picon-directory-list | |
167 | '("~/.picons" "~/.picons/users" "~/.picons/usenix" "~/.picons/news" | |
168 | "~/.picons/domains" "~/.picons/misc" | |
169 | "/usr/share/picons/" "/usr/share/picons/users" "/usr/share/picons/usenix" | |
170 | "/usr/share/picons/news" "/usr/share/picons/domains" | |
171 | "/usr/share/picons/misc") | |
172 | "List of directories where picons reside. | |
173 | The directories are searched for in the order they appear in the list.") | |
174 | ||
175 | (defvar mh-picon-existing-directory-list 'unset | |
176 | "List of directories to search in.") | |
177 | ||
178 | (defvar mh-picon-cache (make-hash-table :test #'equal)) | |
179 | ||
180 | (defvar mh-picon-image-types | |
181 | (loop for type in '(xpm xbm gif) | |
182 | when (or (mh-do-in-gnu-emacs | |
183 | (ignore-errors | |
184 | (mh-funcall-if-exists image-type-available-p type))) | |
185 | (mh-do-in-xemacs (featurep type))) | |
186 | collect type)) | |
187 | ||
188 | (autoload 'message-tokenize-header "sendmail") | |
189 | ||
190 | (defun* mh-picon-get-image () | |
191 | "Find the best possible match and return contents." | |
192 | (mh-picon-set-directory-list) | |
193 | (save-restriction | |
194 | (let* ((from-field (ignore-errors (car (message-tokenize-header | |
195 | (mh-get-header-field "from:"))))) | |
196 | (from (car (ignore-errors | |
197 | (mh-funcall-if-exists ietf-drums-parse-address | |
198 | from-field)))) | |
199 | (host (and from | |
200 | (string-match "\\([^+]*\\)\\(+.*\\)?@\\(.*\\)" from) | |
201 | (downcase (match-string 3 from)))) | |
202 | (user (and host (downcase (match-string 1 from)))) | |
203 | (canonical-address (format "%s@%s" user host)) | |
204 | (cached-value (gethash canonical-address mh-picon-cache)) | |
205 | (host-list (and host (delete "" (split-string host "\\.")))) | |
206 | (match nil)) | |
207 | (cond (cached-value (return-from mh-picon-get-image cached-value)) | |
208 | ((not host-list) (return-from mh-picon-get-image nil))) | |
209 | (setq match | |
64450987 | 210 | (block loop |
dda00b2c BW |
211 | ;; u@h search |
212 | (loop for dir in mh-picon-existing-directory-list | |
213 | do (loop for type in mh-picon-image-types | |
214 | ;; [path]user@host | |
215 | for file1 = (format "%s/%s.%s" | |
216 | dir canonical-address type) | |
217 | when (file-exists-p file1) | |
64450987 | 218 | do (return-from loop file1) |
dda00b2c BW |
219 | ;; [path]user |
220 | for file2 = (format "%s/%s.%s" dir user type) | |
221 | when (file-exists-p file2) | |
64450987 | 222 | do (return-from loop file2) |
dda00b2c BW |
223 | ;; [path]host |
224 | for file3 = (format "%s/%s.%s" dir host type) | |
225 | when (file-exists-p file3) | |
64450987 | 226 | do (return-from loop file3))) |
dda00b2c BW |
227 | ;; facedb search |
228 | ;; Search order for user@foo.net: | |
229 | ;; [path]net/foo/user | |
230 | ;; [path]net/foo/user/face | |
231 | ;; [path]net/user | |
232 | ;; [path]net/user/face | |
233 | ;; [path]net/foo/unknown | |
234 | ;; [path]net/foo/unknown/face | |
235 | ;; [path]net/unknown | |
236 | ;; [path]net/unknown/face | |
237 | (loop for u in (list user "unknown") | |
238 | do (loop for dir in mh-picon-existing-directory-list | |
239 | do (loop for x on host-list by #'cdr | |
240 | for y = (mh-picon-generate-path x u dir) | |
241 | do (loop for type in mh-picon-image-types | |
242 | for z1 = (format "%s.%s" y type) | |
243 | when (file-exists-p z1) | |
64450987 | 244 | do (return-from loop z1) |
dda00b2c BW |
245 | for z2 = (format "%s/face.%s" |
246 | y type) | |
247 | when (file-exists-p z2) | |
64450987 | 248 | do (return-from loop z2))))))) |
dda00b2c BW |
249 | (setf (gethash canonical-address mh-picon-cache) |
250 | (mh-picon-file-contents match))))) | |
251 | ||
252 | (defun mh-picon-set-directory-list () | |
253 | "Update `mh-picon-existing-directory-list' if needed." | |
254 | (when (eq mh-picon-existing-directory-list 'unset) | |
255 | (setq mh-picon-existing-directory-list | |
256 | (loop for x in mh-picon-directory-list | |
257 | when (file-directory-p x) collect x)))) | |
258 | ||
259 | (defun mh-picon-generate-path (host-list user directory) | |
260 | "Generate the image file path. | |
261 | HOST-LIST is the parsed host address of the email address, USER | |
262 | the username and DIRECTORY is the directory relative to which the | |
263 | path is generated." | |
264 | (loop with acc = "" | |
265 | for elem in host-list | |
266 | do (setq acc (format "%s/%s" elem acc)) | |
267 | finally return (format "%s/%s%s" directory acc user))) | |
268 | ||
269 | (defun mh-picon-file-contents (file) | |
270 | "Return details about FILE. | |
271 | A list of consisting of a symbol for the type of the file and the | |
272 | file contents as a string is returned. If FILE is nil, then both | |
273 | elements of the list are nil." | |
274 | (if (stringp file) | |
275 | (with-temp-buffer | |
5a47220a BW |
276 | (if (fboundp 'set-buffer-multibyte) |
277 | (set-buffer-multibyte nil)) | |
dda00b2c BW |
278 | (let ((type (and (string-match ".*\\.\\(...\\)$" file) |
279 | (intern (match-string 1 file))))) | |
280 | (insert-file-contents-literally file) | |
7c730dd6 DG |
281 | (list type (buffer-string)))) |
282 | (list nil nil))) | |
dda00b2c BW |
283 | |
284 | \f | |
285 | ||
286 | ;;; X-Image-URL Display | |
287 | ||
288 | (defvar mh-x-image-scaling-function | |
289 | (cond ((executable-find "convert") | |
290 | 'mh-x-image-scale-with-convert) | |
291 | ((and (executable-find "anytopnm") (executable-find "pnmscale") | |
292 | (executable-find "pnmtopng")) | |
293 | 'mh-x-image-scale-with-pnm) | |
294 | (t 'ignore)) | |
295 | "Function to use to scale image to proper size.") | |
296 | ||
297 | (defun mh-x-image-scale-with-pnm (input output) | |
298 | "Scale image in INPUT file and write to OUTPUT file using pnm tools." | |
299 | (let ((res (shell-command-to-string | |
300 | (format "anytopnm < %s | pnmscale -xysize 96 48 | pnmtopng > %s" | |
301 | input output)))) | |
302 | (unless (equal res "") | |
303 | (delete-file output)))) | |
304 | ||
305 | (defun mh-x-image-scale-with-convert (input output) | |
306 | "Scale image in INPUT file and write to OUTPUT file using ImageMagick." | |
307 | (call-process "convert" nil nil nil "-geometry" "96x48" input output)) | |
308 | ||
309 | (defvar mh-wget-executable nil) | |
310 | (defvar mh-wget-choice | |
311 | (or (and (setq mh-wget-executable (executable-find "wget")) 'wget) | |
312 | (and (setq mh-wget-executable (executable-find "fetch")) 'fetch) | |
313 | (and (setq mh-wget-executable (executable-find "curl")) 'curl))) | |
314 | (defvar mh-wget-option | |
315 | (cdr (assoc mh-wget-choice '((curl . "-o") (fetch . "-o") (wget . "-O"))))) | |
316 | (defvar mh-x-image-temp-file nil) | |
317 | (defvar mh-x-image-url nil) | |
318 | (defvar mh-x-image-marker nil) | |
319 | (defvar mh-x-image-url-cache-file nil) | |
320 | ||
321 | (defun mh-x-image-url-display (url) | |
322 | "Display image from location URL. | |
323 | If the URL isn't present in the cache then it is fetched with wget." | |
324 | (let* ((cache-filename (mh-x-image-url-cache-canonicalize url)) | |
325 | (state (mh-x-image-get-download-state cache-filename)) | |
3544e11a | 326 | (marker (point-marker))) |
dda00b2c BW |
327 | (set (make-local-variable 'mh-x-image-marker) marker) |
328 | (cond ((not (mh-x-image-url-sane-p url))) | |
329 | ((eq state 'ok) | |
330 | (mh-x-image-display cache-filename marker)) | |
331 | ((or (not mh-wget-executable) | |
332 | (eq mh-x-image-scaling-function 'ignore))) | |
333 | ((eq state 'never)) | |
334 | ((not mh-fetch-x-image-url) | |
335 | (set-marker marker nil)) | |
336 | ((eq state 'try-again) | |
337 | (mh-x-image-set-download-state cache-filename nil) | |
338 | (mh-x-image-url-fetch-image url cache-filename marker | |
339 | 'mh-x-image-scale-and-display)) | |
340 | ((and (eq mh-fetch-x-image-url 'ask) | |
341 | (not (y-or-n-p (format "Fetch %s? " url)))) | |
342 | (mh-x-image-set-download-state cache-filename 'never)) | |
343 | ((eq state nil) | |
344 | (mh-x-image-url-fetch-image url cache-filename marker | |
345 | 'mh-x-image-scale-and-display))))) | |
346 | ||
347 | (defvar mh-x-image-cache-directory nil | |
348 | "Directory where X-Image-URL images are cached.") | |
349 | ||
350 | ;;;###mh-autoload | |
351 | (defun mh-set-x-image-cache-directory (directory) | |
352 | "Set the DIRECTORY where X-Image-URL images are cached. | |
353 | This is only done if `mh-x-image-cache-directory' is nil." | |
354 | ;; XXX This is the code that used to be in find-user-path. Is there | |
355 | ;; a good reason why the variable is set conditionally? Do we expect | |
356 | ;; the user to have set this variable directly? | |
357 | (unless mh-x-image-cache-directory | |
358 | (setq mh-x-image-cache-directory directory))) | |
359 | ||
360 | (defun mh-x-image-url-cache-canonicalize (url) | |
361 | "Canonicalize URL. | |
362 | Replace the ?/ character with a ?! character and append .png. | |
06e7028b | 363 | Also replaces special characters with `mh-url-hexify-string' |
cb5bf6ba JB |
364 | since not all characters, such as :, are valid within Windows |
365 | filenames. In addition, replaces * with %2a. See URL | |
ff4dd199 | 366 | `http://msdn.microsoft.com/library/default.asp?url=/library/en-us/shellcc/platform/shell/reference/ifaces/iitemnamelimits/GetValidCharacters.asp'." |
dda00b2c | 367 | (format "%s/%s.png" mh-x-image-cache-directory |
ff4dd199 BW |
368 | (mh-replace-regexp-in-string |
369 | "\*" "%2a" | |
370 | (mh-url-hexify-string | |
371 | (with-temp-buffer | |
372 | (insert url) | |
373 | (mh-replace-string "/" "!") | |
374 | (buffer-string)))))) | |
dda00b2c | 375 | |
dda00b2c BW |
376 | (defun mh-x-image-get-download-state (file) |
377 | "Check the state of FILE by following any symbolic links." | |
378 | (unless (file-exists-p mh-x-image-cache-directory) | |
379 | (call-process "mkdir" nil nil nil mh-x-image-cache-directory)) | |
380 | (cond ((file-symlink-p file) | |
381 | (intern (file-name-nondirectory (file-chase-links file)))) | |
382 | ((not (file-exists-p file)) nil) | |
383 | (t 'ok))) | |
384 | ||
385 | (defun mh-x-image-set-download-state (file data) | |
386 | "Setup a symbolic link from FILE to DATA." | |
387 | (if data | |
388 | (make-symbolic-link (symbol-name data) file t) | |
389 | (delete-file file))) | |
390 | ||
391 | (defun mh-x-image-url-sane-p (url) | |
392 | "Check if URL is something sensible." | |
393 | (let ((len (length url))) | |
394 | (cond ((< len 5) nil) | |
395 | ((not (equal (substring url 0 5) "http:")) nil) | |
396 | ((> len 100) nil) | |
397 | (t t)))) | |
398 | ||
399 | (defun mh-x-image-display (image marker) | |
400 | "Display IMAGE at MARKER." | |
5d2e28bf SM |
401 | (with-current-buffer (marker-buffer marker) |
402 | (let ((inhibit-read-only t) | |
dda00b2c BW |
403 | (buffer-modified-flag (buffer-modified-p))) |
404 | (unwind-protect | |
405 | (when (and (file-readable-p image) (not (file-symlink-p image)) | |
406 | (eq marker mh-x-image-marker)) | |
407 | (goto-char marker) | |
408 | (mh-do-in-gnu-emacs | |
409 | (mh-funcall-if-exists insert-image (create-image image 'png))) | |
410 | (mh-do-in-xemacs | |
411 | (when (featurep 'png) | |
412 | (set-extent-begin-glyph | |
413 | (make-extent (point) (point)) | |
414 | (make-glyph | |
415 | (vector 'png ':data (with-temp-buffer | |
416 | (insert-file-contents-literally image) | |
417 | (buffer-string)))))))) | |
418 | (set-buffer-modified-p buffer-modified-flag))))) | |
419 | ||
420 | (defun mh-x-image-url-fetch-image (url cache-file marker sentinel) | |
421 | "Fetch and display the image specified by URL. | |
422 | After the image is fetched, it is stored in CACHE-FILE. It will | |
423 | be displayed in a buffer and position specified by MARKER. The | |
424 | actual display is carried out by the SENTINEL function." | |
425 | (if mh-wget-executable | |
426 | (let ((buffer (get-buffer-create (generate-new-buffer-name | |
427 | mh-temp-fetch-buffer))) | |
428 | (filename (or (mh-funcall-if-exists make-temp-file "mhe-fetch") | |
429 | (expand-file-name (make-temp-name "~/mhe-fetch"))))) | |
5d2e28bf | 430 | (with-current-buffer buffer |
dda00b2c BW |
431 | (set (make-local-variable 'mh-x-image-url-cache-file) cache-file) |
432 | (set (make-local-variable 'mh-x-image-marker) marker) | |
433 | (set (make-local-variable 'mh-x-image-temp-file) filename)) | |
434 | (set-process-sentinel | |
435 | (start-process "*mh-x-image-url-fetch*" buffer | |
436 | mh-wget-executable mh-wget-option filename url) | |
437 | sentinel)) | |
438 | ;; Temporary failure | |
439 | (mh-x-image-set-download-state cache-file 'try-again))) | |
440 | ||
441 | (defun mh-x-image-scale-and-display (process change) | |
442 | "When the wget PROCESS terminates scale and display image. | |
443 | The argument CHANGE is ignored." | |
444 | (when (eq (process-status process) 'exit) | |
445 | (let (marker temp-file cache-filename wget-buffer) | |
5d2e28bf | 446 | (with-current-buffer (setq wget-buffer (process-buffer process)) |
dda00b2c BW |
447 | (setq marker mh-x-image-marker |
448 | cache-filename mh-x-image-url-cache-file | |
449 | temp-file mh-x-image-temp-file)) | |
450 | (cond | |
451 | ;; Check if we have `convert' | |
452 | ((eq mh-x-image-scaling-function 'ignore) | |
453 | (message "The \"convert\" program is needed to display X-Image-URL") | |
454 | (mh-x-image-set-download-state cache-filename 'try-again)) | |
455 | ;; Scale fetched image | |
456 | ((and (funcall mh-x-image-scaling-function temp-file cache-filename) | |
457 | nil)) | |
458 | ;; Attempt to display image if we have it | |
459 | ((file-exists-p cache-filename) | |
460 | (mh-x-image-display cache-filename marker)) | |
461 | ;; We didn't find the image. Should we try to display it the next time? | |
462 | (t (mh-x-image-set-download-state cache-filename 'try-again))) | |
463 | (ignore-errors | |
464 | (set-marker marker nil) | |
465 | (delete-process process) | |
466 | (kill-buffer wget-buffer) | |
467 | (delete-file temp-file))))) | |
468 | ||
469 | (provide 'mh-xface) | |
470 | ||
471 | ;; Local Variables: | |
472 | ;; indent-tabs-mode: nil | |
473 | ;; sentence-end-double-space: nil | |
474 | ;; End: | |
475 | ||
476 | ;;; mh-xface.el ends here |