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