annotate lisp/mh-e/mh-xface.el @ 70792:5c421372c34a

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