1 ;;; mh-xface.el --- MH-E X-Face and Face header field display
3 ;; Copyright (C) 2002-2003, 2005-2013 Free Software Foundation, Inc.
5 ;; Author: Bill Wohler <wohler@newt.com>
6 ;; Maintainer: Bill Wohler <wohler@newt.com>
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs is free software: you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
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.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
34 (autoload 'message-fetch-field "message")
36 (defvar mh-show-xface-function
37 (cond ((and (featurep 'xemacs) (locate-library "x-face") (not (featurep 'xface)))
39 #'mh-face-display-function)
40 ((>= emacs-major-version 21)
41 #'mh-face-display-function)
43 "Determine at run time what function should be called to display X-Face.")
45 (defvar mh-uncompface-executable
46 (and (fboundp 'executable-find) (executable-find "uncompface")))
53 (defun mh-show-xface ()
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)))
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."
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)
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))
73 (cond (face (setq raw (mh-face-to-png face)
75 (x-face (setq raw (mh-uncompface x-face)
77 (url (setq type 'url))
78 (t (multiple-value-setq (type raw)
79 (values-list (mh-picon-get-image)))))
81 (goto-char (point-min))
82 (when (re-search-forward "^from:" (point-max) t)
86 (mh-x-image-url-display url)
88 insert-image (create-image
91 (mh-face-foreground 'mh-show-xface nil t)
93 (mh-face-background 'mh-show-xface nil t))
99 (mh-x-image-url-display url))
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))
108 (set-extent-begin-glyph
109 (make-extent (point) (point))
110 (make-glyph (vector 'xface ':data (concat "X-Face: " x-face))))
112 ;; Otherwise try external support with x-face...
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))
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 " "))))))))
125 (defun mh-face-to-png (data)
126 "Convert base64 encoded DATA to png image."
128 (if (fboundp 'set-buffer-multibyte)
129 (set-buffer-multibyte nil))
131 (ignore-errors (base64-decode-region (point-min) (point-max)))
134 (defun mh-uncompface (data)
135 "Run DATA through `uncompface' to generate bitmap."
137 (if (fboundp 'set-buffer-multibyte)
138 (set-buffer-multibyte nil))
140 (when (and mh-uncompface-executable
141 (equal (call-process-region (point-min) (point-max)
142 mh-uncompface-executable t '(t nil))
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)
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")))
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.")
175 (defvar mh-picon-existing-directory-list 'unset
176 "List of directories to search in.")
178 (defvar mh-picon-cache (make-hash-table :test #'equal))
180 (defvar mh-picon-image-types
181 (loop for type in '(xpm xbm gif)
182 when (or (mh-do-in-gnu-emacs
184 (mh-funcall-if-exists image-type-available-p type)))
185 (mh-do-in-xemacs (featurep type)))
188 (autoload 'message-tokenize-header "sendmail")
190 (defun* mh-picon-get-image ()
191 "Find the best possible match and return contents."
192 (mh-picon-set-directory-list)
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
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 "\\."))))
207 (cond (cached-value (return-from mh-picon-get-image cached-value))
208 ((not host-list) (return-from mh-picon-get-image nil)))
212 (loop for dir in mh-picon-existing-directory-list
213 do (loop for type in mh-picon-image-types
215 for file1 = (format "%s/%s.%s"
216 dir canonical-address type)
217 when (file-exists-p file1)
218 do (return-from loop file1)
220 for file2 = (format "%s/%s.%s" dir user type)
221 when (file-exists-p file2)
222 do (return-from loop file2)
224 for file3 = (format "%s/%s.%s" dir host type)
225 when (file-exists-p file3)
226 do (return-from loop file3)))
228 ;; Search order for user@foo.net:
229 ;; [path]net/foo/user
230 ;; [path]net/foo/user/face
232 ;; [path]net/user/face
233 ;; [path]net/foo/unknown
234 ;; [path]net/foo/unknown/face
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)
244 do (return-from loop z1)
245 for z2 = (format "%s/face.%s"
247 when (file-exists-p z2)
248 do (return-from loop z2)))))))
249 (setf (gethash canonical-address mh-picon-cache)
250 (mh-picon-file-contents match)))))
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))))
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
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)))
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."
276 (if (fboundp 'set-buffer-multibyte)
277 (set-buffer-multibyte nil))
278 (let ((type (and (string-match ".*\\.\\(...\\)$" file)
279 (intern (match-string 1 file)))))
280 (insert-file-contents-literally file)
281 (list type (buffer-string))))
286 ;;; X-Image-URL Display
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)
295 "Function to use to scale image to proper size.")
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"
302 (unless (equal res "")
303 (delete-file output))))
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))
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)
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))
326 (marker (point-marker)))
327 (set (make-local-variable 'mh-x-image-marker) marker)
328 (cond ((not (mh-x-image-url-sane-p url)))
330 (mh-x-image-display cache-filename marker))
331 ((or (not mh-wget-executable)
332 (eq mh-x-image-scaling-function 'ignore)))
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))
344 (mh-x-image-url-fetch-image url cache-filename marker
345 'mh-x-image-scale-and-display)))))
347 (defvar mh-x-image-cache-directory nil
348 "Directory where X-Image-URL images are cached.")
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)))
360 (defun mh-x-image-url-cache-canonicalize (url)
362 Replace the ?/ character with a ?! character and append .png.
363 Also replaces special characters with `mh-url-hexify-string'
364 since not all characters, such as :, are valid within Windows
365 filenames. In addition, replaces * with %2a. See URL
366 `http://msdn.microsoft.com/library/default.asp?url=/library/en-us/shellcc/platform/shell/reference/ifaces/iitemnamelimits/GetValidCharacters.asp'."
367 (format "%s/%s.png" mh-x-image-cache-directory
368 (mh-replace-regexp-in-string
370 (mh-url-hexify-string
373 (mh-replace-string "/" "!")
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)
385 (defun mh-x-image-set-download-state (file data)
386 "Setup a symbolic link from FILE to DATA."
388 (make-symbolic-link (symbol-name data) file t)
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)
399 (defun mh-x-image-display (image marker)
400 "Display IMAGE at MARKER."
401 (with-current-buffer (marker-buffer marker)
402 (let ((inhibit-read-only t)
403 (buffer-modified-flag (buffer-modified-p)))
405 (when (and (file-readable-p image) (not (file-symlink-p image))
406 (eq marker mh-x-image-marker))
409 (mh-funcall-if-exists insert-image (create-image image 'png)))
411 (when (featurep 'png)
412 (set-extent-begin-glyph
413 (make-extent (point) (point))
415 (vector 'png ':data (with-temp-buffer
416 (insert-file-contents-literally image)
417 (buffer-string))))))))
418 (set-buffer-modified-p buffer-modified-flag)))))
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")))))
430 (with-current-buffer buffer
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)
439 (mh-x-image-set-download-state cache-file 'try-again)))
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)
446 (with-current-buffer (setq wget-buffer (process-buffer process))
447 (setq marker mh-x-image-marker
448 cache-filename mh-x-image-url-cache-file
449 temp-file mh-x-image-temp-file))
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)
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)))
464 (set-marker marker nil)
465 (delete-process process)
466 (kill-buffer wget-buffer)
467 (delete-file temp-file)))))
472 ;; indent-tabs-mode: nil
473 ;; sentence-end-double-space: nil
476 ;;; mh-xface.el ends here