|
0
|
1 ;;; mm.el,v --- Mailcap parsing routines, and MIME handling
|
|
|
2 ;; Author: wmperry
|
|
|
3 ;; Created: 1996/05/28 02:46:51
|
|
|
4 ;; Version: 1.96
|
|
|
5 ;; Keywords: mail, news, hypermedia
|
|
|
6
|
|
|
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
8 ;;;
|
|
|
9 ;;; Copyright (c) 1994, 1995 by William M. Perry (wmperry@spry.com)
|
|
|
10 ;;;
|
|
|
11 ;;; This file is not part of GNU Emacs, but the same permissions apply.
|
|
|
12 ;;;
|
|
|
13 ;;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
|
14 ;;; it under the terms of the GNU General Public License as published by
|
|
|
15 ;;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
16 ;;; any later version.
|
|
|
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
|
|
|
24 ;;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
|
25 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
26 ;;;
|
|
|
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
28 ;;; Generalized mailcap parsing and access routines
|
|
|
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
30 ;;;
|
|
|
31 ;;; Data structures
|
|
|
32 ;;; ---------------
|
|
|
33 ;;; The mailcap structure is an assoc list of assoc lists.
|
|
|
34 ;;; 1st assoc list is keyed on the major content-type
|
|
|
35 ;;; 2nd assoc list is keyed on the minor content-type (which can be a regexp)
|
|
|
36 ;;;
|
|
|
37 ;;; Which looks like:
|
|
|
38 ;;; -----------------
|
|
|
39 ;;; (
|
|
|
40 ;;; ("application"
|
|
|
41 ;;; ("postscript" . <info>)
|
|
|
42 ;;; )
|
|
|
43 ;;; ("text"
|
|
|
44 ;;; ("plain" . <info>)
|
|
|
45 ;;; )
|
|
|
46 ;;; )
|
|
|
47 ;;;
|
|
|
48 ;;; Where <info> is another assoc list of the various information
|
|
|
49 ;;; related to the mailcap RFC. This is keyed on the lowercase
|
|
|
50 ;;; attribute name (viewer, test, etc). This looks like:
|
|
|
51 ;;; (("viewer" . viewerinfo)
|
|
|
52 ;;; ("test" . testinfo)
|
|
|
53 ;;; ("xxxx" . "string")
|
|
|
54 ;;; )
|
|
|
55 ;;;
|
|
|
56 ;;; Where viewerinfo specifies how the content-type is viewed. Can be
|
|
|
57 ;;; a string, in which case it is run through a shell, with
|
|
|
58 ;;; appropriate parameters, or a symbol, in which case the symbol is
|
|
|
59 ;;; funcall'd, with the buffer as an argument.
|
|
|
60 ;;;
|
|
|
61 ;;; testinfo is a list of strings, or nil. If nil, it means the
|
|
|
62 ;;; viewer specified is always valid. If it is a list of strings,
|
|
|
63 ;;; these are used to determine whether a viewer passes the 'test' or
|
|
|
64 ;;; not.
|
|
|
65 ;;;
|
|
|
66 ;;; The main interface to this code is:
|
|
|
67 ;;;
|
|
|
68 ;;; To set everything up:
|
|
|
69 ;;;
|
|
|
70 ;;; (mm-parse-mailcaps [path])
|
|
|
71 ;;;
|
|
|
72 ;;; Where PATH is a unix-style path specification (: separated list
|
|
|
73 ;;; of strings). If PATH is nil, the environment variable MAILCAPS
|
|
|
74 ;;; will be consulted. If there is no environment variable, then a
|
|
|
75 ;;; default list of paths is used.
|
|
|
76 ;;;
|
|
|
77 ;;; To retrieve the information:
|
|
|
78 ;;; (mm-mime-info st [nd] [request])
|
|
|
79 ;;;
|
|
|
80 ;;; Where st and nd are positions in a buffer that contain the
|
|
|
81 ;;; content-type header information of a mail/news/whatever message.
|
|
|
82 ;;; st can optionally be a string that contains the content-type
|
|
|
83 ;;; information.
|
|
|
84 ;;;
|
|
|
85 ;;; Third argument REQUEST specifies what information to return. If
|
|
|
86 ;;; it is nil or the empty string, the viewer (second field of the
|
|
|
87 ;;; mailcap entry) will be returned. If it is a string, then the
|
|
|
88 ;;; mailcap field corresponding to that string will be returned
|
|
|
89 ;;; (print, description, whatever). If a number, then all the
|
|
|
90 ;;; information for this specific viewer is returned.
|
|
|
91 ;;;
|
|
|
92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
93 ;;; Variables, etc
|
|
|
94 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
2
|
95 (eval-and-compile
|
|
|
96 (require 'cl))
|
|
|
97
|
|
0
|
98 (defconst mm-version (let ((x "1.96"))
|
|
|
99 (if (string-match "Revision: \\([^ \t\n]+\\)" x)
|
|
|
100 (substring x (match-beginning 1) (match-end 1))
|
|
|
101 x))
|
|
|
102 "Version # of MM package")
|
|
|
103
|
|
|
104 (defvar mm-parse-args-syntax-table
|
|
|
105 (copy-syntax-table emacs-lisp-mode-syntax-table)
|
|
|
106 "A syntax table for parsing sgml attributes.")
|
|
|
107
|
|
|
108 (modify-syntax-entry ?' "\"" mm-parse-args-syntax-table)
|
|
|
109 (modify-syntax-entry ?` "\"" mm-parse-args-syntax-table)
|
|
|
110 (modify-syntax-entry ?{ "(" mm-parse-args-syntax-table)
|
|
|
111 (modify-syntax-entry ?} ")" mm-parse-args-syntax-table)
|
|
|
112
|
|
|
113 ;;; This is so we can use a consistent method of checking for mule support
|
|
|
114 ;;; Emacs-based mule uses (boundp 'MULE), but XEmacs-based mule uses
|
|
|
115 ;;; (featurep 'mule) - I choose to use the latter.
|
|
|
116
|
|
|
117 (if (boundp 'MULE)
|
|
|
118 (provide 'mule))
|
|
|
119
|
|
|
120 (defvar mm-mime-data
|
|
|
121 '(
|
|
|
122 ("multipart" . (
|
|
|
123 ("alternative". (("viewer" . mm-multipart-viewer)
|
|
|
124 ("type" . "multipart/alternative")))
|
|
|
125 ("mixed" . (("viewer" . mm-multipart-viewer)
|
|
|
126 ("type" . "multipart/mixed")))
|
|
|
127 (".*" . (("viewer" . mm-save-binary-file)
|
|
|
128 ("type" . "multipart/*")))
|
|
|
129 )
|
|
|
130 )
|
|
|
131 ("application" . (
|
|
|
132 ("octet-stream" . (("viewer" . mm-save-binary-file)
|
|
|
133 ("type" ."application/octet-stream")))
|
|
|
134 ("dvi" . (("viewer" . "open %s")
|
|
|
135 ("type" . "application/dvi")
|
|
|
136 ("test" . (eq (device-type) 'ns))))
|
|
|
137 ("dvi" . (("viewer" . "xdvi %s")
|
|
|
138 ("test" . (eq (device-type) 'x))
|
|
|
139 ("needsx11")
|
|
|
140 ("type" . "application/dvi")))
|
|
|
141 ("dvi" . (("viewer" . "dvitty %s")
|
|
|
142 ("test" . (not (getenv "DISPLAY")))
|
|
|
143 ("type" . "application/dvi")))
|
|
|
144 ("emacs-lisp" . (("viewer" . mm-maybe-eval)
|
|
|
145 ("type" . "application/emacs-lisp")))
|
|
|
146 ; ("x-tar" . (("viewer" . tar-mode)
|
|
|
147 ; ("test" . (fboundp 'tar-mode))
|
|
|
148 ; ("type" . "application/x-tar")))
|
|
|
149 ("x-tar" . (("viewer" . mm-save-binary-file)
|
|
|
150 ("type" . "application/x-tar")))
|
|
|
151 ("x-latex" . (("viewer" . tex-mode)
|
|
|
152 ("test" . (fboundp 'tex-mode))
|
|
|
153 ("type" . "application/x-latex")))
|
|
|
154 ("x-tex" . (("viewer" . tex-mode)
|
|
|
155 ("test" . (fboundp 'tex-mode))
|
|
|
156 ("type" . "application/x-tex")))
|
|
|
157 ("latex" . (("viewer" . tex-mode)
|
|
|
158 ("test" . (fboundp 'tex-mode))
|
|
|
159 ("type" . "application/latex")))
|
|
|
160 ("tex" . (("viewer" . tex-mode)
|
|
|
161 ("test" . (fboundp 'tex-mode))
|
|
|
162 ("type" . "application/tex")))
|
|
|
163 ("texinfo" . (("viewer" . texinfo-mode)
|
|
|
164 ("test" . (fboundp 'texinfo-mode))
|
|
|
165 ("type" . "application/tex")))
|
|
|
166 ("zip" . (("viewer" . mm-save-binary-file)
|
|
|
167 ("type" . "application/zip")
|
|
|
168 ("copiousoutput")))
|
|
|
169 ("pdf" . (("viewer" . "acroread %s")
|
|
|
170 ("type" . "application/pdf")))
|
|
|
171 ("postscript" . (("viewer" . "open %s")
|
|
|
172 ("type" . "application/postscript")
|
|
|
173 ("test" . (eq (device-type) 'ns))))
|
|
|
174 ("postscript" . (("viewer" . "ghostview %s")
|
|
|
175 ("type" . "application/postscript")
|
|
|
176 ("test" . (eq (device-type) 'x))
|
|
|
177 ("needsx11")))
|
|
|
178 ("postscript" . (("viewer" . "ps2ascii %s")
|
|
|
179 ("type" . "application/postscript")
|
|
|
180 ("test" . (not (getenv "DISPLAY")))
|
|
|
181 ("copiousoutput")))
|
|
|
182 ("x-www-pem-reply" .
|
|
|
183 (("viewer" . (w3-decode-pgp/pem "pem"))
|
|
|
184 ("test" . (fboundp 'w3-decode-pgp/pem))
|
|
|
185 ("type" . "application/x-www-pem-reply")
|
|
|
186 ))
|
|
|
187 ("x-www-pgp-reply" .
|
|
|
188 (("viewer" . (w3-decode-pgp/pem "pgp"))
|
|
|
189 ("test" . (fboundp 'w3-decode-pgp/pem))
|
|
|
190 ("type" . "application/x-www-pgp-reply")))
|
|
|
191 ))
|
|
|
192 ("audio" . (
|
|
|
193 ("x-mpeg" . (("viewer" . "maplay %s")
|
|
|
194 ("type" . "audio/x-mpeg")))
|
|
|
195 (".*" . (("viewer" . mm-play-sound-file)
|
|
|
196 ("test" . (or (featurep 'nas-sound)
|
|
|
197 (featurep 'native-sound)))
|
|
|
198 ("type" . "audio/*")))
|
|
|
199 (".*" . (("viewer" . "showaudio")
|
|
|
200 ("type" . "audio/*")))
|
|
|
201 ))
|
|
|
202 ("message" . (
|
|
|
203 ("rfc-*822" . (("viewer" . vm-mode)
|
|
|
204 ("test" . (fboundp 'vm-mode))
|
|
|
205 ("type" . "message/rfc-822")))
|
|
|
206 ("rfc-*822" . (("viewer" . w3-mode)
|
|
|
207 ("test" . (fboundp 'w3-mode))
|
|
|
208 ("type" . "message/rfc-822")))
|
|
|
209 ("rfc-*822" . (("viewer" . view-mode)
|
|
|
210 ("test" . (fboundp 'view-mode))
|
|
|
211 ("type" . "message/rfc-822")))
|
|
|
212 ("rfc-*822" . (("viewer" . fundamental-mode)
|
|
|
213 ("type" . "message/rfc-822")))
|
|
|
214 ))
|
|
|
215 ("image" . (
|
|
|
216 ("x-xwd" . (("viewer" . "xwud -in %s")
|
|
|
217 ("type" . "image/x-xwd")
|
|
|
218 ("compose" . "xwd -frame > %s")
|
|
|
219 ("test" . (eq (device-type) 'x))
|
|
|
220 ("needsx11")))
|
|
|
221 ("x11-dump" . (("viewer" . "xwud -in %s")
|
|
|
222 ("type" . "image/x-xwd")
|
|
|
223 ("compose" . "xwd -frame > %s")
|
|
|
224 ("test" . (eq (device-type) 'x))
|
|
|
225 ("needsx11")))
|
|
|
226 ("windowdump" . (("viewer" . "xwud -in %s")
|
|
|
227 ("type" . "image/x-xwd")
|
|
|
228 ("compose" . "xwd -frame > %s")
|
|
|
229 ("test" . (eq (device-type) 'x))
|
|
|
230 ("needsx11")))
|
|
|
231 (".*" . (("viewer" . "open %s")
|
|
|
232 ("type" . "image/*")
|
|
|
233 ("test" . (eq (device-type) 'ns))))
|
|
|
234 (".*" . (("viewer" . "xv -perfect %s")
|
|
|
235 ("type" . "image/*")
|
|
|
236 ("test" . (eq (device-type) 'x))
|
|
|
237 ("needsx11")))
|
|
|
238 ))
|
|
|
239 ("text" . (
|
|
|
240 ("plain" . (("viewer" . w3-mode)
|
|
|
241 ("test" . (fboundp 'w3-mode))
|
|
|
242 ("type" . "text/plain")))
|
|
|
243 ("plain" . (("viewer" . view-mode)
|
|
|
244 ("test" . (fboundp 'view-mode))
|
|
|
245 ("type" . "text/plain")))
|
|
|
246 ("plain" . (("viewer" . fundamental-mode)
|
|
|
247 ("type" . "text/plain")))
|
|
|
248 ("enriched" . (("viewer" . enriched-decode-region)
|
|
|
249 ("test" . (fboundp
|
|
|
250 'enriched-decode-region))
|
|
|
251 ("type" . "text/enriched")))
|
|
|
252 ("html" . (("viewer" . w3-prepare-buffer)
|
|
|
253 ("test" . (fboundp 'w3-prepare-buffer))
|
|
|
254 ("type" . "text/html")))
|
|
|
255 ))
|
|
|
256 ("video" . (
|
|
|
257 ("mpeg" . (("viewer" . "mpeg_play %s")
|
|
|
258 ("type" . "video/mpeg")
|
|
|
259 ("test" . (eq (device-type) 'x))
|
|
|
260 ("needsx11")))
|
|
|
261 ))
|
|
|
262 ("x-world" . (
|
|
|
263 ("x-vrml" . (("viewer" . "webspace -remote %s -URL %u")
|
|
|
264 ("type" . "x-world/x-vrml")
|
|
|
265 ("description"
|
|
|
266 "VRML document")))))
|
|
|
267 ("archive" . (
|
|
|
268 ("tar" . (("viewer" . tar-mode)
|
|
|
269 ("type" . "archive/tar")
|
|
|
270 ("test" . (fboundp 'tar-mode))))
|
|
|
271 ))
|
|
|
272 )
|
|
|
273 "*The mailcap structure is an assoc list of assoc lists.
|
|
|
274 1st assoc list is keyed on the major content-type
|
|
|
275 2nd assoc list is keyed on the minor content-type (which can be a regexp)
|
|
|
276
|
|
|
277 Which looks like:
|
|
|
278 -----------------
|
|
|
279 (
|
|
|
280 (\"application\"
|
|
|
281 (\"postscript\" . <info>)
|
|
|
282 )
|
|
|
283 (\"text\"
|
|
|
284 (\"plain\" . <info>)
|
|
|
285 )
|
|
|
286 )
|
|
|
287
|
|
|
288 Where <info> is another assoc list of the various information
|
|
|
289 related to the mailcap RFC. This is keyed on the lowercase
|
|
|
290 attribute name (viewer, test, etc). This looks like:
|
|
|
291 ((\"viewer\" . viewerinfo)
|
|
|
292 (\"test\" . testinfo)
|
|
|
293 (\"xxxx\" . \"string\")
|
|
|
294 )
|
|
|
295
|
|
|
296 Where viewerinfo specifies how the content-type is viewed. Can be
|
|
|
297 a string, in which case it is run through a shell, with
|
|
|
298 appropriate parameters, or a symbol, in which case the symbol is
|
|
|
299 funcall'd, with the buffer as an argument.
|
|
|
300
|
|
|
301 testinfo is a list of strings, or nil. If nil, it means the
|
|
|
302 viewer specified is always valid. If it is a list of strings,
|
|
|
303 these are used to determine whether a viewer passes the 'test' or
|
|
|
304 not.")
|
|
|
305
|
|
|
306 (defvar mm-content-transfer-encodings
|
|
|
307 '(("base64" . base64-decode)
|
|
|
308 ("7bit" . ignore)
|
|
|
309 ("8bit" . ignore)
|
|
|
310 ("binary" . ignore)
|
|
|
311 ("x-compress" . ("uncompress" "-c"))
|
|
|
312 ("x-gzip" . ("gzip" "-dc"))
|
|
|
313 ("compress" . ("uncompress" "-c"))
|
|
|
314 ("gzip" . ("gzip" "-dc"))
|
|
|
315 ("x-hqx" . ("mcvert" "-P" "-s" "-S"))
|
|
|
316 ("quoted-printable" . mm-decode-quoted-printable)
|
|
|
317 )
|
|
|
318 "*An assoc list of content-transfer-encodings and how to decode them.")
|
|
|
319
|
|
|
320 (defvar mm-download-directory nil
|
|
|
321 "*Where downloaded files should go by default.")
|
|
|
322
|
|
|
323 (defvar mm-temporary-directory "/tmp"
|
|
|
324 "*Where temporary files go.")
|
|
|
325
|
|
|
326
|
|
|
327 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
328 ;;; A few things from w3 and url, just in case this is used without them
|
|
|
329 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
330
|
|
|
331 (defun mm-generate-unique-filename (&optional fmt)
|
|
|
332 "Generate a unique filename in mm-temporary-directory"
|
|
|
333 (if (not fmt)
|
|
|
334 (let ((base (format "mm-tmp.%d" (user-real-uid)))
|
|
|
335 (fname "")
|
|
|
336 (x 0))
|
|
|
337 (setq fname (format "%s%d" base x))
|
|
|
338 (while (file-exists-p
|
|
|
339 (expand-file-name fname mm-temporary-directory))
|
|
|
340 (setq x (1+ x)
|
|
|
341 fname (concat base (int-to-string x))))
|
|
|
342 (expand-file-name fname mm-temporary-directory))
|
|
|
343 (let ((base (concat "mm" (int-to-string (user-real-uid))))
|
|
|
344 (fname "")
|
|
|
345 (x 0))
|
|
|
346 (setq fname (format fmt (concat base (int-to-string x))))
|
|
|
347 (while (file-exists-p
|
|
|
348 (expand-file-name fname mm-temporary-directory))
|
|
|
349 (setq x (1+ x)
|
|
|
350 fname (format fmt (concat base (int-to-string x)))))
|
|
|
351 (expand-file-name fname mm-temporary-directory))))
|
|
|
352
|
|
2
|
353 (if (and (fboundp 'copy-tree)
|
|
|
354 (subrp (symbol-function 'copy-tree)))
|
|
|
355 (fset 'mm-copy-tree 'copy-tree)
|
|
|
356 (defun mm-copy-tree (tree)
|
|
|
357 (if (consp tree)
|
|
|
358 (cons (mm-copy-tree (car tree))
|
|
|
359 (mm-copy-tree (cdr tree)))
|
|
|
360 (if (vectorp tree)
|
|
|
361 (let* ((new (copy-sequence tree))
|
|
|
362 (i (1- (length new))))
|
|
|
363 (while (>= i 0)
|
|
|
364 (aset new i (mm-copy-tree (aref new i)))
|
|
|
365 (setq i (1- i)))
|
|
|
366 new)
|
|
|
367 tree))))
|
|
0
|
368
|
|
|
369 (if (not (fboundp 'w3-save-binary-file))
|
|
|
370 (defun mm-save-binary-file ()
|
|
2
|
371 ;; Ok, this is truly fucked. In XEmacs, if you use the mouse to select
|
|
|
372 ;; a URL that gets saved via this function, read-file-name will pop up a
|
|
|
373 ;; dialog box for file selection. For some reason which buffer we are in
|
|
|
374 ;; gets royally screwed (even with save-excursions and the whole nine
|
|
|
375 ;; yards). SO, we just keep the old buffer name around and away we go.
|
|
|
376 (let ((old-buff (current-buffer))
|
|
|
377 (file (read-file-name "Filename to save as: "
|
|
|
378 (or mm-download-directory "~/")
|
|
|
379 (file-name-nondirectory (url-view-url t))
|
|
|
380 nil
|
|
|
381 (file-name-nondirectory (url-view-url t))))
|
|
|
382 (require-final-newline nil))
|
|
|
383 (set-buffer old-buff)
|
|
|
384 (if (featurep 'mule)
|
|
|
385 (let ((mc-flag t))
|
|
|
386 (write-region (point-min) (point-max) file nil nil *noconv*))
|
|
|
387 (write-region (point-min) (point-max) file))
|
|
|
388 (kill-buffer (current-buffer))))
|
|
0
|
389 (fset 'mm-save-binary-file 'w3-save-binary-file))
|
|
|
390
|
|
|
391 (if (not (fboundp 'w3-maybe-eval))
|
|
|
392 (defun mm-maybe-eval ()
|
|
|
393 "Maybe evaluate a buffer of emacs lisp code"
|
|
|
394 (if (yes-or-no-p "This is emacs-lisp code, evaluate it? ")
|
|
|
395 (eval-buffer (current-buffer))
|
|
|
396 (emacs-lisp-mode)))
|
|
|
397 (fset 'mm-maybe-eval 'w3-maybe-eval))
|
|
|
398
|
|
|
399
|
|
|
400 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
401 ;;; The mailcap parser
|
|
|
402 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
2
|
403 (defun mm-viewer-unescape (format &optional filename url)
|
|
|
404 (save-excursion
|
|
|
405 (set-buffer (get-buffer-create " *mm-parse*"))
|
|
|
406 (erase-buffer)
|
|
|
407 (insert format)
|
|
|
408 (goto-char (point-min))
|
|
|
409 (while (re-search-forward "%\\(.\\)" nil t)
|
|
|
410 (let ((escape (aref (match-string 1) 0)))
|
|
|
411 (replace-match "" t t)
|
|
|
412 (case escape
|
|
|
413 (?% (insert "%"))
|
|
|
414 (?s (insert (or filename "\"\"")))
|
|
|
415 (?u (insert (or url "\"\""))))))
|
|
|
416 (buffer-string)))
|
|
|
417
|
|
0
|
418 (defun mm-in-assoc (elt list)
|
|
|
419 ;; Check to see if ELT matches any of the regexps in the car elements of LIST
|
|
|
420 (let (rslt)
|
|
|
421 (while (and list (not rslt))
|
|
|
422 (and (car (car list))
|
|
|
423 (string-match (car (car list)) elt)
|
|
|
424 (setq rslt (car list)))
|
|
|
425 (setq list (cdr list)))
|
|
|
426 rslt))
|
|
|
427
|
|
|
428 (defun mm-replace-regexp (regexp to-string)
|
|
|
429 ;; Quiet replace-regexp.
|
|
|
430 (goto-char (point-min))
|
|
|
431 (while (re-search-forward regexp nil t)
|
|
|
432 (replace-match to-string t nil)))
|
|
|
433
|
|
|
434 (defun mm-parse-mailcaps (&optional path)
|
|
|
435 ;; Parse out all the mailcaps specified in a unix-style path string PATH
|
|
|
436 (cond
|
|
|
437 (path nil)
|
|
|
438 ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS")))
|
|
|
439 ((memq system-type '(ms-dos ms-windows windows-nt))
|
|
|
440 (setq path (mapconcat 'expand-file-name '("~/mail.cap" "~/etc/mail.cap")
|
|
|
441 ";")))
|
|
|
442 (t (setq path (concat "/etc/mailcap:/usr/etc/mailcap:"
|
|
|
443 "/usr/local/etc/mailcap:"
|
|
|
444 (expand-file-name "~/.mailcap")))))
|
|
|
445 (let ((fnames (mm-string-to-tokens path
|
|
|
446 (if (memq system-type
|
|
|
447 '(ms-dos ms-windows windows-nt))
|
|
|
448 ?;
|
|
|
449 ?:))) fname)
|
|
|
450 (while fnames
|
|
|
451 (setq fname (car fnames))
|
|
|
452 (if (and (file-exists-p fname) (file-readable-p fname))
|
|
|
453 (mm-parse-mailcap (car fnames)))
|
|
|
454 (setq fnames (cdr fnames)))))
|
|
|
455
|
|
|
456 (defun mm-parse-mailcap (fname)
|
|
|
457 ;; Parse out the mailcap file specified by FNAME
|
|
|
458 (let (major ; The major mime type (image/audio/etc)
|
|
|
459 minor ; The minor mime type (gif, basic, etc)
|
|
|
460 save-pos ; Misc saved positions used in parsing
|
|
|
461 viewer ; How to view this mime type
|
|
|
462 info ; Misc info about this mime type
|
|
|
463 )
|
|
|
464 (save-excursion
|
|
|
465 (set-buffer (get-buffer-create " *mailcap*"))
|
|
|
466 (erase-buffer)
|
|
|
467 (insert-file-contents fname)
|
|
|
468 (set-syntax-table mm-parse-args-syntax-table)
|
|
|
469 (mm-replace-regexp "#.*" "") ; Remove all comments
|
|
|
470 (mm-replace-regexp "\n+" "\n") ; And blank lines
|
|
|
471 (mm-replace-regexp "\\\\[ \t\n]+" " ") ; And collapse spaces
|
|
|
472 (mm-replace-regexp (concat (regexp-quote "\\") "[ \t]*\n") "")
|
|
|
473 (goto-char (point-max))
|
|
|
474 (skip-chars-backward " \t\n")
|
|
|
475 (delete-region (point) (point-max))
|
|
|
476 (goto-char (point-min))
|
|
|
477 (while (not (eobp))
|
|
|
478 (skip-chars-forward " \t\n")
|
|
|
479 (setq save-pos (point)
|
|
|
480 info nil)
|
|
|
481 (skip-chars-forward "^/;")
|
|
|
482 (downcase-region save-pos (point))
|
|
|
483 (setq major (buffer-substring save-pos (point)))
|
|
|
484 (skip-chars-forward "/ \t\n")
|
|
|
485 (setq save-pos (point))
|
|
|
486 (skip-chars-forward "^;")
|
|
|
487 (downcase-region save-pos (point))
|
|
|
488 (setq minor
|
|
|
489 (cond
|
|
|
490 ((= ?* (or (char-after save-pos) 0)) ".*")
|
|
|
491 ((= (point) save-pos) ".*")
|
|
|
492 (t (buffer-substring save-pos (point)))))
|
|
|
493 (skip-chars-forward "; \t\n")
|
|
|
494 ;;; Got the major/minor chunks, now for the viewers/etc
|
|
|
495 ;;; The first item _must_ be a viewer, according to the
|
|
|
496 ;;; RFC for mailcap files (#1343)
|
|
|
497 (skip-chars-forward "; \t\n")
|
|
|
498 (setq save-pos (point))
|
|
|
499 (skip-chars-forward "^;\n")
|
|
|
500 (if (= (or (char-after save-pos) 0) ?')
|
|
|
501 (setq viewer (progn
|
|
|
502 (narrow-to-region (1+ save-pos) (point))
|
|
|
503 (goto-char (point-min))
|
|
|
504 (prog1
|
|
|
505 (read (current-buffer))
|
|
|
506 (goto-char (point-max))
|
|
|
507 (widen))))
|
|
|
508 (setq viewer (buffer-substring save-pos (point))))
|
|
|
509 (setq save-pos (point))
|
|
|
510 (end-of-line)
|
|
|
511 (setq info (nconc (list (cons "viewer" viewer)
|
|
|
512 (cons "type" (concat major "/"
|
|
|
513 (if (string= minor ".*")
|
|
|
514 "*" minor))))
|
|
|
515 (mm-parse-mailcap-extras save-pos (point))))
|
|
|
516 (mm-mailcap-entry-passes-test info)
|
|
|
517 (mm-add-mailcap-entry major minor info)))))
|
|
|
518
|
|
|
519 (defun mm-parse-mailcap-extras (st nd)
|
|
|
520 ;; Grab all the extra stuff from a mailcap entry
|
|
|
521 (let (
|
|
|
522 name ; From name=
|
|
|
523 value ; its value
|
|
|
524 results ; Assoc list of results
|
|
|
525 name-pos ; Start of XXXX= position
|
|
|
526 val-pos ; Start of value position
|
|
|
527 done ; Found end of \'d ;s?
|
|
|
528 )
|
|
|
529 (save-restriction
|
|
|
530 (narrow-to-region st nd)
|
|
|
531 (goto-char (point-min))
|
|
|
532 (skip-chars-forward " \n\t;")
|
|
|
533 (while (not (eobp))
|
|
|
534 (setq done nil)
|
|
|
535 (skip-chars-forward " \";\n\t")
|
|
|
536 (setq name-pos (point))
|
|
|
537 (skip-chars-forward "^ \n\t=")
|
|
|
538 (downcase-region name-pos (point))
|
|
|
539 (setq name (buffer-substring name-pos (point)))
|
|
|
540 (skip-chars-forward " \t\n")
|
|
|
541 (if (/= (or (char-after (point)) 0) ?=) ; There is no value
|
|
|
542 (setq value nil)
|
|
|
543 (skip-chars-forward " \t\n=")
|
|
|
544 (setq val-pos (point))
|
|
|
545 (if (memq (char-after val-pos) '(?\" ?'))
|
|
|
546 (progn
|
|
|
547 (setq val-pos (1+ val-pos))
|
|
|
548 (condition-case nil
|
|
|
549 (progn
|
|
|
550 (forward-sexp 1)
|
|
|
551 (backward-char 1))
|
|
|
552 (error (goto-char (point-max)))))
|
|
|
553 (while (not done)
|
|
|
554 (skip-chars-forward "^;")
|
|
|
555 (if (= (or (char-after (1- (point))) 0) ?\\ )
|
|
|
556 (progn
|
|
|
557 (subst-char-in-region (1- (point)) (point) ?\\ ? )
|
|
|
558 (skip-chars-forward ";"))
|
|
|
559 (setq done t))))
|
|
|
560 (setq value (buffer-substring val-pos (point))))
|
|
|
561 (setq results (cons (cons name value) results)))
|
|
|
562 results)))
|
|
|
563
|
|
|
564 (defun mm-string-to-tokens (str &optional delim)
|
|
|
565 "Return a list of words from the string STR"
|
|
|
566 (setq delim (or delim ? ))
|
|
|
567 (let (results y)
|
|
|
568 (mapcar
|
|
|
569 (function
|
|
|
570 (lambda (x)
|
|
|
571 (cond
|
|
|
572 ((and (= x delim) y) (setq results (cons y results) y nil))
|
|
|
573 ((/= x delim) (setq y (concat y (char-to-string x))))
|
|
|
574 (t nil)))) str)
|
|
|
575 (nreverse (cons y results))))
|
|
|
576
|
|
|
577 (defun mm-mailcap-entry-passes-test (info)
|
|
|
578 ;; Return t iff a mailcap entry passes its test clause or no test
|
|
|
579 ;; clause is present.
|
|
|
580 (let (status ; Call-process-regions return value
|
|
|
581 (test (assoc "test" info)); The test clause
|
|
|
582 )
|
|
|
583 (setq status (and test (mm-string-to-tokens (cdr test))))
|
|
|
584 (if (and (assoc "needsx11" info) (not (getenv "DISPLAY")))
|
|
|
585 (setq status nil)
|
|
|
586 (cond
|
|
|
587 ((and (equal (nth 0 status) "test")
|
|
|
588 (equal (nth 1 status) "-n")
|
|
|
589 (or (equal (nth 2 status) "$DISPLAY")
|
|
|
590 (equal (nth 2 status) "\"$DISPLAY\"")))
|
|
|
591 (setq status (if (getenv "DISPLAY") t nil)))
|
|
|
592 ((and (equal (nth 0 status) "test")
|
|
|
593 (equal (nth 1 status) "-z")
|
|
|
594 (or (equal (nth 2 status) "$DISPLAY")
|
|
|
595 (equal (nth 2 status) "\"$DISPLAY\"")))
|
|
|
596 (setq status (if (getenv "DISPLAY") nil t)))
|
|
|
597 (test nil)
|
|
|
598 (t nil)))
|
|
|
599 (and test (listp test) (setcdr test status))))
|
|
|
600
|
|
|
601 (defun mm-parse-args (st &optional nd nodowncase)
|
|
|
602 ;; Return an assoc list of attribute/value pairs from an RFC822-type string
|
|
|
603 (let (
|
|
|
604 name ; From name=
|
|
|
605 value ; its value
|
|
|
606 results ; Assoc list of results
|
|
|
607 name-pos ; Start of XXXX= position
|
|
|
608 val-pos ; Start of value position
|
|
|
609 )
|
|
|
610 (save-excursion
|
|
|
611 (if (stringp st)
|
|
|
612 (progn
|
|
|
613 (set-buffer (get-buffer-create " *mm-temp*"))
|
|
|
614 (set-syntax-table mm-parse-args-syntax-table)
|
|
|
615 (erase-buffer)
|
|
|
616 (insert st)
|
|
|
617 (setq st (point-min)
|
|
|
618 nd (point-max)))
|
|
|
619 (set-syntax-table mm-parse-args-syntax-table))
|
|
|
620 (save-restriction
|
|
|
621 (narrow-to-region st nd)
|
|
|
622 (goto-char (point-min))
|
|
|
623 (while (not (eobp))
|
|
|
624 (skip-chars-forward "; \n\t")
|
|
|
625 (setq name-pos (point))
|
|
|
626 (skip-chars-forward "^ \n\t=;")
|
|
|
627 (if (not nodowncase)
|
|
|
628 (downcase-region name-pos (point)))
|
|
|
629 (setq name (buffer-substring name-pos (point)))
|
|
|
630 (skip-chars-forward " \t\n")
|
|
|
631 (if (/= (or (char-after (point)) 0) ?=) ; There is no value
|
|
|
632 (setq value nil)
|
|
|
633 (skip-chars-forward " \t\n=")
|
|
|
634 (setq val-pos (point)
|
|
|
635 value
|
|
|
636 (cond
|
|
|
637 ((or (= (or (char-after val-pos) 0) ?\")
|
|
|
638 (= (or (char-after val-pos) 0) ?'))
|
|
|
639 (buffer-substring (1+ val-pos)
|
|
|
640 (condition-case ()
|
|
|
641 (prog2
|
|
|
642 (forward-sexp 1)
|
|
|
643 (1- (point))
|
|
|
644 (skip-chars-forward "\""))
|
|
|
645 (error
|
|
|
646 (skip-chars-forward "^ \t\n")
|
|
|
647 (point)))))
|
|
|
648 (t
|
|
|
649 (buffer-substring val-pos
|
|
|
650 (progn
|
|
|
651 (skip-chars-forward "^;")
|
|
|
652 (skip-chars-backward " \t")
|
|
|
653 (point)))))))
|
|
|
654 (setq results (cons (cons name value) results))
|
|
|
655 (skip-chars-forward "; \n\t"))
|
|
|
656 results))))
|
|
|
657
|
|
|
658 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
659 ;;; The action routines.
|
|
|
660 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
661 (defun mm-possible-viewers (major minor)
|
|
|
662 ;; Return a list of possible viewers from MAJOR for minor type MINOR
|
|
|
663 (let ((exact '())
|
|
|
664 (wildcard '()))
|
|
|
665 (while major
|
|
|
666 (cond
|
|
|
667 ((equal (car (car major)) minor)
|
|
|
668 (setq exact (cons (cdr (car major)) exact)))
|
|
|
669 ((string-match (car (car major)) minor)
|
|
|
670 (setq wildcard (cons (cdr (car major)) wildcard))))
|
|
|
671 (setq major (cdr major)))
|
|
|
672 (nconc (nreverse exact) (nreverse wildcard))))
|
|
|
673
|
|
|
674 (defun mm-unescape-mime-test (test type-info)
|
|
|
675 (let ((buff (get-buffer-create " *unescape*"))
|
|
|
676 save-pos save-chr subst)
|
|
|
677 (cond
|
|
|
678 ((symbolp test) test)
|
|
|
679 ((and (listp test) (symbolp (car test))) test)
|
|
|
680 ((or (stringp test)
|
|
|
681 (and (listp test) (stringp (car test))
|
|
|
682 (setq test (mapconcat 'identity test " "))))
|
|
|
683 (save-excursion
|
|
|
684 (set-buffer buff)
|
|
|
685 (erase-buffer)
|
|
|
686 (insert test)
|
|
|
687 (goto-char (point-min))
|
|
|
688 (while (not (eobp))
|
|
|
689 (skip-chars-forward "^%")
|
|
|
690 (if (/= (- (point)
|
|
|
691 (progn (skip-chars-backward "\\\\")
|
|
|
692 (point)))
|
|
|
693 0) ; It is an escaped %
|
|
|
694 (progn
|
|
|
695 (delete-char 1)
|
|
|
696 (skip-chars-forward "%."))
|
|
|
697 (setq save-pos (point))
|
|
|
698 (skip-chars-forward "%")
|
|
|
699 (setq save-chr (char-after (point)))
|
|
|
700 (cond
|
|
|
701 ((null save-chr) nil)
|
|
|
702 ((= save-chr ?t)
|
|
|
703 (delete-region save-pos (progn (forward-char 1) (point)))
|
|
|
704 (insert (or (cdr (assoc "type" type-info)) "\"\"")))
|
|
|
705 ((= save-chr ?M)
|
|
|
706 (delete-region save-pos (progn (forward-char 1) (point)))
|
|
|
707 (insert "\"\""))
|
|
|
708 ((= save-chr ?n)
|
|
|
709 (delete-region save-pos (progn (forward-char 1) (point)))
|
|
|
710 (insert "\"\""))
|
|
|
711 ((= save-chr ?F)
|
|
|
712 (delete-region save-pos (progn (forward-char 1) (point)))
|
|
|
713 (insert "\"\""))
|
|
|
714 ((= save-chr ?{)
|
|
|
715 (forward-char 1)
|
|
|
716 (skip-chars-forward "^}")
|
|
|
717 (downcase-region (+ 2 save-pos) (point))
|
|
|
718 (setq subst (buffer-substring (+ 2 save-pos) (point)))
|
|
|
719 (delete-region save-pos (1+ (point)))
|
|
|
720 (insert (or (cdr (assoc subst type-info)) "\"\"")))
|
|
|
721 (t nil))))
|
|
|
722 (buffer-string)))
|
|
|
723 (t (error "Bad value to mm-unescape-mime-test. %s" test)))))
|
|
|
724
|
|
|
725 (defun mm-viewer-passes-test (viewer-info type-info)
|
|
|
726 ;; Return non-nil iff the viewer specified by VIEWER-INFO passes its
|
|
|
727 ;; test clause (if any).
|
|
|
728 (let* ((test-info (assoc "test" viewer-info))
|
|
|
729 (test (cdr test-info))
|
|
|
730 (viewer (cdr (assoc "viewer" viewer-info)))
|
|
|
731 status
|
|
|
732 parsed-test
|
|
|
733 )
|
|
|
734 (cond
|
|
|
735 ((not test-info) t) ; No test clause
|
|
|
736 ((not test) nil) ; Already failed test
|
|
|
737 ((eq test t) t) ; Already passed test
|
|
|
738 ((and (symbolp test) ; Lisp function as test
|
|
|
739 (fboundp test))
|
|
|
740 (funcall test type-info))
|
|
|
741 ((and (symbolp test) ; Lisp variable as test
|
|
|
742 (boundp test))
|
|
|
743 (symbol-value test))
|
|
|
744 ((and (listp test) ; List to be eval'd
|
|
|
745 (symbolp (car test)))
|
|
|
746 (eval test))
|
|
|
747 (t
|
|
|
748 (setq test (mm-unescape-mime-test test type-info)
|
|
|
749 test (list "/bin/sh" nil nil nil "-c" test)
|
|
|
750 status (apply 'call-process test))
|
|
|
751 (= 0 status)))))
|
|
|
752
|
|
|
753 (defun mm-add-mailcap-entry (major minor info)
|
|
|
754 (let ((old-major (assoc major mm-mime-data)))
|
|
|
755 (if (null old-major) ; New major area
|
|
|
756 (setq mm-mime-data
|
|
|
757 (cons (cons major (list (cons minor info)))
|
|
|
758 mm-mime-data))
|
|
|
759 (let ((cur-minor (assoc minor old-major)))
|
|
|
760 (cond
|
|
|
761 ((or (null cur-minor) ; New minor area, or
|
|
|
762 (assoc "test" info)) ; Has a test, insert at beginning
|
|
|
763 (setcdr old-major (cons (cons minor info) (cdr old-major))))
|
|
|
764 ((and (not (assoc "test" info)); No test info, replace completely
|
|
|
765 (not (assoc "test" cur-minor)))
|
|
|
766 (setcdr cur-minor info))
|
|
|
767 (t
|
|
|
768 (setcdr old-major (cons (cons minor info) (cdr old-major)))))))))
|
|
|
769
|
|
|
770
|
|
|
771 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
772 ;;; The main whabbo
|
|
|
773 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
774 (defun mm-viewer-lessp (x y)
|
|
|
775 ;; Return t iff viewer X is more desirable than viewer Y
|
|
|
776 (let ((x-wild (string-match "[*?]" (or (cdr-safe (assoc "type" x)) "")))
|
|
|
777 (y-wild (string-match "[*?]" (or (cdr-safe (assoc "type" y)) "")))
|
|
|
778 (x-lisp (not (stringp (or (cdr-safe (assoc "viewer" x)) ""))))
|
|
|
779 (y-lisp (not (stringp (or (cdr-safe (assoc "viewer" y)) "")))))
|
|
|
780 (cond
|
|
|
781 ((and x-lisp (not y-lisp))
|
|
|
782 t)
|
|
|
783 ((and (not y-lisp) x-wild (not y-wild))
|
|
|
784 t)
|
|
|
785 ((and (not x-wild) y-wild)
|
|
|
786 t)
|
|
|
787 (t nil))))
|
|
|
788
|
|
|
789 (defun mm-mime-info (st &optional nd request)
|
|
|
790 "Get the mime viewer command for HEADERLINE, return nil if none found.
|
|
|
791 Expects a complete content-type header line as its argument. This can
|
|
|
792 be simple like text/html, or complex like text/plain; charset=blah; foo=bar
|
|
|
793
|
|
|
794 Third argument REQUEST specifies what information to return. If it is
|
|
|
795 nil or the empty string, the viewer (second field of the mailcap
|
|
|
796 entry) will be returned. If it is a string, then the mailcap field
|
|
|
797 corresponding to that string will be returned (print, description,
|
|
|
798 whatever). If a number, then all the information for this specific
|
|
|
799 viewer is returned."
|
|
|
800 (let (
|
|
|
801 major ; Major encoding (text, etc)
|
|
|
802 minor ; Minor encoding (html, etc)
|
|
|
803 info ; Other info
|
|
|
804 save-pos ; Misc. position during parse
|
|
|
805 major-info ; (assoc major mm-mime-data)
|
|
|
806 minor-info ; (assoc minor major-info)
|
|
|
807 test ; current test proc.
|
|
|
808 viewers ; Possible viewers
|
|
|
809 passed ; Viewers that passed the test
|
|
|
810 viewer ; The one and only viewer
|
|
|
811 )
|
|
|
812 (save-excursion
|
|
|
813 (cond
|
|
|
814 ((null st)
|
|
|
815 (set-buffer (get-buffer-create " *mimeparse*"))
|
|
|
816 (erase-buffer)
|
|
|
817 (insert "text/plain")
|
|
|
818 (setq st (point-min)))
|
|
|
819 ((stringp st)
|
|
|
820 (set-buffer (get-buffer-create " *mimeparse*"))
|
|
|
821 (erase-buffer)
|
|
|
822 (insert st)
|
|
|
823 (setq st (point-min)))
|
|
|
824 ((null nd)
|
|
|
825 (narrow-to-region st (progn (goto-char st) (end-of-line) (point))))
|
|
|
826 (t (narrow-to-region st nd)))
|
|
|
827 (goto-char st)
|
|
|
828 (skip-chars-forward ": \t\n")
|
|
|
829 (buffer-enable-undo)
|
|
|
830 (setq viewer
|
|
|
831 (catch 'mm-exit
|
|
|
832 (setq save-pos (point))
|
|
|
833 (skip-chars-forward "^/")
|
|
|
834 (downcase-region save-pos (point))
|
|
|
835 (setq major (buffer-substring save-pos (point)))
|
|
|
836 (if (not (setq major-info (cdr (assoc major mm-mime-data))))
|
|
|
837 (throw 'mm-exit nil))
|
|
|
838 (skip-chars-forward "/ \t\n")
|
|
|
839 (setq save-pos (point))
|
|
|
840 (skip-chars-forward "^ \t\n;")
|
|
|
841 (downcase-region save-pos (point))
|
|
|
842 (setq minor (buffer-substring save-pos (point)))
|
|
|
843 (if (not
|
|
|
844 (setq viewers (mm-possible-viewers major-info minor)))
|
|
|
845 (throw 'mm-exit nil))
|
|
|
846 (skip-chars-forward "; \t")
|
|
|
847 (if (eolp)
|
|
|
848 nil ; No qualifiers
|
|
|
849 (setq save-pos (point))
|
|
|
850 (end-of-line)
|
|
|
851 (setq info (mm-parse-args save-pos (point)))
|
|
|
852 )
|
|
|
853 (while viewers
|
|
|
854 (if (mm-viewer-passes-test (car viewers) info)
|
|
|
855 (setq passed (cons (car viewers) passed)))
|
|
|
856 (setq viewers (cdr viewers)))
|
|
|
857 (setq passed (sort (nreverse passed) 'mm-viewer-lessp))
|
|
|
858 (car passed)))
|
|
|
859 (if (and (stringp (cdr (assoc "viewer" viewer)))
|
|
|
860 passed)
|
|
|
861 (setq viewer (car passed)))
|
|
|
862 (widen)
|
|
|
863 (cond
|
|
|
864 ((and (null viewer) (not (equal major "default")))
|
|
|
865 (mm-mime-info "default" nil request))
|
|
|
866 ((or (null request) (equal request ""))
|
|
|
867 (mm-unescape-mime-test (cdr (assoc "viewer" viewer)) info))
|
|
|
868 ((stringp request)
|
|
|
869 (if (or (string= request "test") (string= request "viewer"))
|
|
|
870 (mm-unescape-mime-test (cdr-safe (assoc request viewer)) info)))
|
|
|
871 (t
|
|
|
872 ;; MUST make a copy *sigh*, else we modify mm-mime-data
|
|
2
|
873 (setq viewer (mm-copy-tree viewer))
|
|
0
|
874 (let ((view (assoc "viewer" viewer))
|
|
|
875 (test (assoc "test" viewer)))
|
|
|
876 (if view (setcdr view (mm-unescape-mime-test (cdr view) info)))
|
|
|
877 (if test (setcdr test (mm-unescape-mime-test (cdr test) info))))
|
|
|
878 viewer)))))
|
|
|
879
|
|
|
880
|
|
|
881 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
882 ;;; Experimental MIME-types parsing
|
|
|
883 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
884 (defvar mm-mime-extensions
|
|
|
885 '(
|
|
|
886 ("" . "text/plain")
|
|
|
887 (".abs" . "audio/x-mpeg")
|
|
|
888 (".aif" . "audio/aiff")
|
|
|
889 (".aifc" . "audio/aiff")
|
|
|
890 (".aiff" . "audio/aiff")
|
|
|
891 (".ano" . "application/x-annotator")
|
|
|
892 (".au" . "audio/ulaw")
|
|
|
893 (".avi" . "video/x-msvideo")
|
|
|
894 (".bcpio" . "application/x-bcpio")
|
|
|
895 (".bin" . "application/octet-stream")
|
|
|
896 (".cdf" . "application/x-netcdr")
|
|
|
897 (".cpio" . "application/x-cpio")
|
|
|
898 (".csh" . "application/x-csh")
|
|
|
899 (".dvi" . "application/x-dvi")
|
|
|
900 (".el" . "application/emacs-lisp")
|
|
|
901 (".eps" . "application/postscript")
|
|
|
902 (".etx" . "text/x-setext")
|
|
|
903 (".exe" . "application/octet-stream")
|
|
|
904 (".fax" . "image/x-fax")
|
|
|
905 (".gif" . "image/gif")
|
|
|
906 (".hdf" . "application/x-hdf")
|
|
|
907 (".hqx" . "application/mac-binhex40")
|
|
|
908 (".htm" . "text/html")
|
|
|
909 (".html" . "text/html")
|
|
|
910 (".icon" . "image/x-icon")
|
|
|
911 (".ief" . "image/ief")
|
|
|
912 (".jpg" . "image/jpeg")
|
|
|
913 (".macp" . "image/x-macpaint")
|
|
|
914 (".man" . "application/x-troff-man")
|
|
|
915 (".me" . "application/x-troff-me")
|
|
|
916 (".mif" . "application/mif")
|
|
|
917 (".mov" . "video/quicktime")
|
|
|
918 (".movie" . "video/x-sgi-movie")
|
|
|
919 (".mp2" . "audio/x-mpeg")
|
|
|
920 (".mp2a" . "audio/x-mpeg2")
|
|
|
921 (".mpa" . "audio/x-mpeg")
|
|
|
922 (".mpa2" . "audio/x-mpeg2")
|
|
|
923 (".mpe" . "video/mpeg")
|
|
|
924 (".mpeg" . "video/mpeg")
|
|
|
925 (".mpega" . "audio/x-mpeg")
|
|
|
926 (".mpegv" . "video/mpeg")
|
|
|
927 (".mpg" . "video/mpeg")
|
|
|
928 (".mpv" . "video/mpeg")
|
|
|
929 (".ms" . "application/x-troff-ms")
|
|
|
930 (".nc" . "application/x-netcdf")
|
|
|
931 (".nc" . "application/x-netcdf")
|
|
|
932 (".oda" . "application/oda")
|
|
|
933 (".pbm" . "image/x-portable-bitmap")
|
|
|
934 (".pdf" . "application/pdf")
|
|
|
935 (".pgm" . "image/portable-graymap")
|
|
|
936 (".pict" . "image/pict")
|
|
|
937 (".pnm" . "image/x-portable-anymap")
|
|
|
938 (".ppm" . "image/portable-pixmap")
|
|
|
939 (".ps" . "application/postscript")
|
|
|
940 (".qt" . "video/quicktime")
|
|
|
941 (".ras" . "image/x-raster")
|
|
|
942 (".rgb" . "image/x-rgb")
|
|
|
943 (".rtf" . "application/rtf")
|
|
|
944 (".rtx" . "text/richtext")
|
|
|
945 (".sh" . "application/x-sh")
|
|
|
946 (".sit" . "application/x-stuffit")
|
|
|
947 (".snd" . "audio/basic")
|
|
|
948 (".src" . "application/x-wais-source")
|
|
|
949 (".tar" . "archive/tar")
|
|
|
950 (".tcl" . "application/x-tcl")
|
|
|
951 (".tcl" . "application/x-tcl")
|
|
|
952 (".tex" . "application/x-tex")
|
|
|
953 (".texi" . "application/texinfo")
|
|
|
954 (".tga" . "image/x-targa")
|
|
|
955 (".tif" . "image/tiff")
|
|
|
956 (".tiff" . "image/tiff")
|
|
|
957 (".tr" . "application/x-troff")
|
|
|
958 (".troff" . "application/x-troff")
|
|
|
959 (".tsv" . "text/tab-separated-values")
|
|
|
960 (".txt" . "text/plain")
|
|
|
961 (".vbs" . "video/mpeg")
|
|
|
962 (".vox" . "audio/basic")
|
|
|
963 (".vrml" . "x-world/x-vrml")
|
|
|
964 (".wav" . "audio/x-wav")
|
|
|
965 (".wrl" . "x-world/x-vrml")
|
|
|
966 (".xbm" . "image/xbm")
|
|
|
967 (".xpm" . "image/x-pixmap")
|
|
|
968 (".xwd" . "image/windowdump")
|
|
|
969 (".zip" . "application/zip")
|
|
|
970 (".ai" . "application/postscript")
|
|
|
971 (".jpe" . "image/jpeg")
|
|
|
972 (".jpeg" . "image/jpeg")
|
|
|
973 )
|
|
|
974 "*An assoc list of file extensions and the MIME content-types they
|
|
|
975 correspond to.")
|
|
|
976
|
|
|
977 (defun mm-parse-mimetypes (&optional path)
|
|
|
978 ;; Parse out all the mimetypes specified in a unix-style path string PATH
|
|
|
979 (cond
|
|
|
980 (path nil)
|
|
|
981 ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES")))
|
|
|
982 ((memq system-type '(ms-dos ms-windows windows-nt))
|
|
|
983 (setq path (mapconcat 'expand-file-name
|
|
|
984 '("~/mime.typ" "~/etc/mime.typ") ";")))
|
|
|
985 (t (setq path (concat (expand-file-name "~/.mime-types") ":"
|
|
|
986 "/etc/mime-types:/usr/etc/mime-types:"
|
|
|
987 "/usr/local/etc/mime-types:"
|
|
|
988 "/usr/local/www/conf/mime-types"))))
|
|
|
989 (let ((fnames (mm-string-to-tokens path
|
|
|
990 (if (memq system-type
|
|
|
991 '(ms-dos ms-windows windows-nt))
|
|
|
992 ?;
|
|
|
993 ?:))) fname)
|
|
|
994 (while fnames
|
|
|
995 (setq fname (car fnames))
|
|
|
996 (if (and (file-exists-p fname) (file-readable-p fname))
|
|
|
997 (mm-parse-mimetype-file (car fnames)))
|
|
|
998 (setq fnames (cdr fnames)))))
|
|
|
999
|
|
|
1000 (defun mm-parse-mimetype-file (fname)
|
|
|
1001 ;; Parse out a mime-types file
|
|
|
1002 (let (type ; The MIME type for this line
|
|
|
1003 extns ; The extensions for this line
|
|
|
1004 save-pos ; Misc. saved buffer positions
|
|
|
1005 )
|
|
|
1006 (save-excursion
|
|
|
1007 (set-buffer (get-buffer-create " *mime-types*"))
|
|
|
1008 (erase-buffer)
|
|
|
1009 (insert-file-contents fname)
|
|
|
1010 (mm-replace-regexp "#.*" "")
|
|
|
1011 (mm-replace-regexp "\n+" "\n")
|
|
|
1012 (mm-replace-regexp "[ \t]+$" "")
|
|
|
1013 (goto-char (point-max))
|
|
|
1014 (skip-chars-backward " \t\n")
|
|
|
1015 (delete-region (point) (point-max))
|
|
|
1016 (goto-char (point-min))
|
|
|
1017 (while (not (eobp))
|
|
|
1018 (skip-chars-forward " \t\n")
|
|
|
1019 (setq save-pos (point))
|
|
|
1020 (skip-chars-forward "^ \t")
|
|
|
1021 (downcase-region save-pos (point))
|
|
|
1022 (setq type (buffer-substring save-pos (point)))
|
|
|
1023 (while (not (eolp))
|
|
|
1024 (skip-chars-forward " \t")
|
|
|
1025 (setq save-pos (point))
|
|
|
1026 (skip-chars-forward "^ \t\n")
|
|
|
1027 (setq extns (cons (buffer-substring save-pos (point)) extns)))
|
|
|
1028 (while extns
|
|
|
1029 (setq mm-mime-extensions
|
|
|
1030 (cons
|
|
|
1031 (cons (if (= (string-to-char (car extns)) ?.)
|
|
|
1032 (car extns)
|
|
|
1033 (concat "." (car extns))) type) mm-mime-extensions)
|
|
|
1034 extns (cdr extns)))))))
|
|
|
1035
|
|
|
1036 (defun mm-extension-to-mime (extn)
|
|
|
1037 "Return the MIME content type of the file extensions EXTN"
|
|
|
1038 (if (and (stringp extn)
|
|
|
1039 (not (= (string-to-char extn) ?.)))
|
|
|
1040 (setq extn (concat "." extn)))
|
|
|
1041 (cdr (assoc (downcase extn) mm-mime-extensions)))
|
|
|
1042
|
|
|
1043
|
|
|
1044 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
1045 ;;; Editing/Composition of body parts
|
|
|
1046 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
1047 (defun mm-compose-type (type)
|
|
|
1048 ;; Compose a body section of MIME-type TYPE.
|
|
|
1049 (let* ((info (mm-mime-info type nil 5))
|
|
|
1050 (fnam (mm-generate-unique-filename))
|
|
|
1051 (comp (or (cdr (assoc "compose" info))))
|
|
|
1052 (ctyp (cdr (assoc "composetyped" info)))
|
|
|
1053 (buff (get-buffer-create " *mimecompose*"))
|
|
|
1054 (typeit (not ctyp))
|
|
|
1055 (retval "")
|
|
|
1056 (usef nil))
|
|
|
1057 (setq comp (mm-unescape-mime-test (or comp ctyp) info))
|
|
|
1058 (while (string-match "\\([^\\\\]\\)%s" comp)
|
|
|
1059 (setq comp (concat (substring comp 0 (match-end 1)) fnam
|
|
|
1060 (substring comp (match-end 0) nil))
|
|
|
1061 usef t))
|
|
|
1062 (call-process (or shell-file-name
|
|
|
1063 (getenv "ESHELL") (getenv "SHELL") "/bin/sh")
|
|
|
1064 nil (if usef nil buff) nil "-c" comp)
|
|
|
1065 (setq retval
|
|
|
1066 (concat
|
|
|
1067 (if typeit (concat "Content-type: " type "\r\n\r\n") "")
|
|
|
1068 (if usef
|
|
|
1069 (save-excursion
|
|
|
1070 (set-buffer buff)
|
|
|
1071 (erase-buffer)
|
|
|
1072 (insert-file-contents fnam)
|
|
|
1073 (buffer-string))
|
|
|
1074 (save-excursion
|
|
|
1075 (set-buffer buff)
|
|
|
1076 (buffer-string)))
|
|
|
1077 "\r\n"))
|
|
|
1078 retval))
|
|
|
1079
|
|
|
1080 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
1081 ;;; Misc.
|
|
|
1082 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
1083 (defun mm-type-to-file (type)
|
|
|
1084 "Return the file extension for content-type TYPE"
|
|
|
1085 (rassoc type mm-mime-extensions))
|
|
|
1086
|
|
|
1087
|
|
|
1088 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
1089 ;;; Miscellaneous MIME viewers written in elisp
|
|
|
1090 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
1091 (defun mm-play-sound-file (&optional buff)
|
|
|
1092 "Play a sound file in buffer BUFF (defaults to current buffer)"
|
|
|
1093 (setq buff (or buff (current-buffer)))
|
|
|
1094 (let ((fname (mm-generate-unique-filename "%s.au"))
|
|
|
1095 (synchronous-sounds t)) ; Play synchronously
|
|
|
1096 (if (featurep 'mule)
|
|
|
1097 (write-region (point-min) (point-max) fname nil nil *noconv*)
|
|
|
1098 (write-region (point-min) (point-max) fname))
|
|
|
1099 (kill-buffer (current-buffer))
|
|
|
1100 (play-sound-file fname)
|
|
|
1101 (condition-case ()
|
|
|
1102 (delete-file fname)
|
|
|
1103 (error nil))))
|
|
|
1104
|
|
|
1105 (defun mm-parse-mime-headers (&optional no-delete)
|
|
|
1106 "Return a list of the MIME headers at the top of this buffer. If
|
|
|
1107 optional argument NO-DELETE is non-nil, don't delete the headers."
|
|
|
1108 (let* ((st (point-min))
|
|
|
1109 (nd (progn
|
|
|
1110 (goto-char (point-min))
|
|
|
1111 (skip-chars-forward " \t\n")
|
|
|
1112 (if (re-search-forward "^\r*$" nil t)
|
|
|
1113 (1+ (point))
|
|
|
1114 (point-max))))
|
|
|
1115 save-pos
|
|
|
1116 status
|
|
|
1117 hname
|
|
|
1118 hvalu
|
|
|
1119 result
|
|
|
1120 )
|
|
|
1121 (narrow-to-region st nd)
|
|
|
1122 (goto-char (point-min))
|
|
|
1123 (while (not (eobp))
|
|
|
1124 (skip-chars-forward " \t\n\r")
|
|
|
1125 (setq save-pos (point))
|
|
|
1126 (skip-chars-forward "^:\n\r")
|
|
|
1127 (downcase-region save-pos (point))
|
|
|
1128 (setq hname (buffer-substring save-pos (point)))
|
|
|
1129 (skip-chars-forward ": \t ")
|
|
|
1130 (setq save-pos (point))
|
|
|
1131 (skip-chars-forward "^\n\r")
|
|
|
1132 (setq hvalu (buffer-substring save-pos (point))
|
|
|
1133 result (cons (cons hname hvalu) result)))
|
|
|
1134 (or no-delete (delete-region st nd))
|
|
|
1135 result))
|
|
|
1136
|
|
|
1137 (defun mm-find-available-multiparts (separator &optional buf)
|
|
|
1138 "Return a list of mime-headers for the various body parts of a
|
|
|
1139 multipart message in buffer BUF with separator SEPARATOR.
|
|
|
1140 The different multipart specs are put in `mm-temporary-directory'."
|
|
|
1141 (let ((sep (concat "^--" separator "\r*$"))
|
|
|
1142 headers
|
|
|
1143 fname
|
|
|
1144 results)
|
|
|
1145 (save-excursion
|
|
|
1146 (and buf (set-buffer buf))
|
|
|
1147 (goto-char (point-min))
|
|
|
1148 (while (re-search-forward sep nil t)
|
|
|
1149 (let ((st (set-marker (make-marker)
|
|
|
1150 (progn
|
|
|
1151 (forward-line 1)
|
|
|
1152 (beginning-of-line)
|
|
|
1153 (point))))
|
|
|
1154 (nd (set-marker (make-marker)
|
|
|
1155 (if (re-search-forward sep nil t)
|
|
|
1156 (1- (match-beginning 0))
|
|
|
1157 (point-max)))))
|
|
|
1158 (narrow-to-region st nd)
|
|
|
1159 (goto-char st)
|
|
|
1160 (if (looking-at "^\r*$")
|
|
|
1161 (insert "Content-type: text/plain\n"
|
|
|
1162 "Content-length: " (int-to-string (- nd st)) "\n"))
|
|
|
1163 (setq headers (mm-parse-mime-headers)
|
|
|
1164 fname (mm-generate-unique-filename))
|
|
|
1165 (let ((x (or (cdr (assoc "content-type" headers)) "text/plain")))
|
|
|
1166 (if (string-match "name=\"*\\([^ \"]+\\)\"*" x)
|
|
|
1167 (setq fname (expand-file-name
|
|
|
1168 (substring x (match-beginning 1)
|
|
|
1169 (match-end 1))
|
|
|
1170 mm-temporary-directory))))
|
|
|
1171 (widen)
|
|
|
1172 (if (assoc "content-transfer-encoding" headers)
|
|
|
1173 (let ((coding (cdr
|
|
|
1174 (assoc "content-transfer-encoding" headers)))
|
|
|
1175 (cmd nil))
|
|
|
1176 (setq coding (and coding (downcase coding))
|
|
|
1177 cmd (or (cdr (assoc coding
|
|
|
1178 mm-content-transfer-encodings))
|
|
|
1179 (read-string
|
|
|
1180 (concat "How shall I decode " coding "? ")
|
|
|
1181 "cat")))
|
|
|
1182 (if (string= cmd "") (setq cmd "cat"))
|
|
|
1183 (if (stringp cmd)
|
|
|
1184 (shell-command-on-region st nd cmd t)
|
|
|
1185 (funcall cmd st nd))
|
|
|
1186 (set-marker nd (point))))
|
|
|
1187 (write-region st nd fname nil 5)
|
|
|
1188 (delete-region st nd)
|
|
|
1189 (setq results (cons
|
|
|
1190 (cons
|
|
|
1191 (cons "mm-filename" fname) headers) results)))))
|
|
|
1192 results))
|
|
|
1193
|
|
|
1194 (defun mm-format-multipart-as-html (&optional buf type)
|
|
|
1195 (if buf (set-buffer buf))
|
|
|
1196 (let* ((boundary (if (string-match
|
|
|
1197 "boundary[ \t]*=[ \t\"]*\\([^ \"\t\n]+\\)"
|
|
|
1198 type)
|
|
|
1199 (regexp-quote
|
|
|
1200 (substring type (match-beginning 1) (match-end 1)))))
|
|
|
1201 (parts (mm-find-available-multiparts boundary)))
|
|
|
1202 (erase-buffer)
|
|
|
1203 (insert "<html>\n"
|
|
|
1204 " <head>\n"
|
|
|
1205 " <title>Multipart Message</title>\n"
|
|
|
1206 " </head>\n"
|
|
|
1207 " <body>\n"
|
|
|
1208 " <h1> Multipart message encountered </h1>\n"
|
|
|
1209 " <p> I have encountered a multipart MIME message.\n"
|
|
|
1210 " The following parts have been detected. Please\n"
|
|
|
1211 " select which one you want to view.\n"
|
|
|
1212 " </p>\n"
|
|
|
1213 " <ul>\n"
|
|
|
1214 (mapconcat
|
|
|
1215 (function (lambda (x)
|
|
|
1216 (concat " <li> <a href=\"file:"
|
|
|
1217 (cdr (assoc "mm-filename" x))
|
|
|
1218 "\">"
|
|
|
1219 (or (cdr (assoc "content-description" x)) "")
|
|
|
1220 "--"
|
|
|
1221 (or (cdr (assoc "content-type" x))
|
|
|
1222 "unknown type")
|
|
|
1223 "</a> </li>")))
|
|
|
1224 parts "\n")
|
|
|
1225 " </ul>\n"
|
|
|
1226 " </body>\n"
|
|
|
1227 "</html>\n"
|
|
|
1228 "<!-- Automatically generated by MM v" mm-version "-->\n")))
|
|
|
1229
|
|
|
1230 (defun mm-multipart-viewer ()
|
|
|
1231 (mm-format-multipart-as-html
|
|
|
1232 (current-buffer)
|
|
|
1233 (cdr (assoc "content-type" url-current-mime-headers)))
|
|
|
1234 (let ((w3-working-buffer (current-buffer)))
|
|
|
1235 (w3-prepare-buffer)))
|
|
|
1236
|
|
|
1237 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
1238 ;;; Transfer encodings we can decrypt automatically
|
|
|
1239 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
1240 (defun mm-decode-quoted-printable (&optional st nd)
|
|
|
1241 (interactive)
|
|
|
1242 (setq st (or st (point-min))
|
|
|
1243 nd (or nd (point-max)))
|
|
|
1244 (save-restriction
|
|
|
1245 (narrow-to-region st nd)
|
|
|
1246 (save-excursion
|
|
|
1247 (let ((buffer-read-only nil))
|
|
|
1248 (goto-char (point-min))
|
|
|
1249 (while (re-search-forward "=[0-9A-F][0-9A-F]" nil t)
|
|
|
1250 (replace-match
|
|
|
1251 (char-to-string
|
|
|
1252 (+
|
|
|
1253 (* 16 (mm-hex-char-to-integer
|
|
|
1254 (char-after (1+ (match-beginning 0)))))
|
|
|
1255 (mm-hex-char-to-integer
|
|
|
1256 (char-after (1- (match-end 0))))))))))))
|
|
|
1257
|
|
|
1258 ;; Taken from hexl.el.
|
|
|
1259 (defun mm-hex-char-to-integer (character)
|
|
|
1260 "Take a char and return its value as if it was a hex digit."
|
|
|
1261 (if (and (>= character ?0) (<= character ?9))
|
|
|
1262 (- character ?0)
|
|
|
1263 (let ((ch (logior character 32)))
|
|
|
1264 (if (and (>= ch ?a) (<= ch ?f))
|
|
|
1265 (- ch (- ?a 10))
|
|
|
1266 (error (format "Invalid hex digit `%c'." ch))))))
|
|
|
1267
|
|
|
1268
|
|
|
1269 (require 'base64)
|
|
|
1270 (provide 'mm)
|
