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