(uudecode): Require.
[bpt/emacs.git] / lisp / gnus / mailcap.el
CommitLineData
c113de23
GM
1;;; mailcap.el --- Functions for displaying MIME parts
2;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
3
4;; Author: William M. Perry <wmperry@aventail.com>
5;; Lars Magne Ingebrigtsen <larsi@gnus.org>
6;; Keywords: news, mail
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 2, or (at your option)
13;; any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING. If not, write to the
22;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23;; Boston, MA 02111-1307, USA.
24
25;;; Commentary:
26
27;;; Code:
28
29(eval-when-compile (require 'cl))
30(require 'mail-parse)
31(require 'mm-util)
32
33(defvar mailcap-parse-args-syntax-table
34 (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
35 (modify-syntax-entry ?' "\"" table)
36 (modify-syntax-entry ?` "\"" table)
37 (modify-syntax-entry ?{ "(" table)
38 (modify-syntax-entry ?} ")" table)
39 table)
40 "A syntax table for parsing sgml attributes.")
41
42(defvar mailcap-mime-data
43 '(("application"
44 ("x-x509-ca-cert"
45 (viewer . ssl-view-site-cert)
46 (test . (fboundp 'ssl-view-site-cert))
47 (type . "application/x-x509-ca-cert"))
48 ("x-x509-user-cert"
49 (viewer . ssl-view-user-cert)
50 (test . (fboundp 'ssl-view-user-cert))
51 (type . "application/x-x509-user-cert"))
52 ("octet-stream"
53 (viewer . mailcap-save-binary-file)
54 (non-viewer . t)
55 (type . "application/octet-stream"))
56 ("dvi"
57 (viewer . "open %s")
58 (type . "application/dvi")
59 (test . (eq (mm-device-type) 'ns)))
60 ("dvi"
61 (viewer . "xdvi %s")
62 (test . (eq (mm-device-type) 'x))
63 ("needsx11")
64 (type . "application/dvi"))
65 ("dvi"
66 (viewer . "dvitty %s")
67 (test . (not (getenv "DISPLAY")))
68 (type . "application/dvi"))
69 ("emacs-lisp"
70 (viewer . mailcap-maybe-eval)
71 (type . "application/emacs-lisp"))
72 ("x-tar"
73 (viewer . mailcap-save-binary-file)
74 (non-viewer . t)
75 (type . "application/x-tar"))
76 ("x-latex"
77 (viewer . tex-mode)
78 (test . (fboundp 'tex-mode))
79 (type . "application/x-latex"))
80 ("x-tex"
81 (viewer . tex-mode)
82 (test . (fboundp 'tex-mode))
83 (type . "application/x-tex"))
84 ("latex"
85 (viewer . tex-mode)
86 (test . (fboundp 'tex-mode))
87 (type . "application/latex"))
88 ("tex"
89 (viewer . tex-mode)
90 (test . (fboundp 'tex-mode))
91 (type . "application/tex"))
92 ("texinfo"
93 (viewer . texinfo-mode)
94 (test . (fboundp 'texinfo-mode))
95 (type . "application/tex"))
96 ("zip"
97 (viewer . mailcap-save-binary-file)
98 (non-viewer . t)
99 (type . "application/zip")
100 ("copiousoutput"))
101 ("pdf"
102 (viewer . "acroread %s")
103 (type . "application/pdf"))
104 ("postscript"
105 (viewer . "open %s")
106 (type . "application/postscript")
107 (test . (eq (mm-device-type) 'ns)))
108 ("postscript"
109 (viewer . "ghostview -dSAFER %s")
110 (type . "application/postscript")
111 (test . (eq (mm-device-type) 'x))
112 ("needsx11"))
113 ("postscript"
114 (viewer . "ps2ascii %s")
115 (type . "application/postscript")
116 (test . (not (getenv "DISPLAY")))
117 ("copiousoutput")))
118 ("audio"
119 ("x-mpeg"
120 (viewer . "maplay %s")
121 (type . "audio/x-mpeg"))
122 (".*"
123 (viewer . "showaudio")
124 (type . "audio/*")))
125 ("message"
126 ("rfc-*822"
127 (viewer . mm-view-message)
128 (test . (and (featurep 'gnus)
129 (gnus-alive-p)))
130 (type . "message/rfc822"))
131 ("rfc-*822"
132 (viewer . vm-mode)
133 (test . (fboundp 'vm-mode))
134 (type . "message/rfc822"))
135 ("rfc-*822"
136 (viewer . w3-mode)
137 (test . (fboundp 'w3-mode))
138 (type . "message/rfc822"))
139 ("rfc-*822"
140 (viewer . view-mode)
141 (test . (fboundp 'view-mode))
142 (type . "message/rfc822"))
143 ("rfc-*822"
144 (viewer . fundamental-mode)
145 (type . "message/rfc822")))
146 ("image"
147 ("x-xwd"
148 (viewer . "xwud -in %s")
149 (type . "image/x-xwd")
150 ("compose" . "xwd -frame > %s")
151 (test . (eq (mm-device-type) 'x))
152 ("needsx11"))
153 ("x11-dump"
154 (viewer . "xwud -in %s")
155 (type . "image/x-xwd")
156 ("compose" . "xwd -frame > %s")
157 (test . (eq (mm-device-type) 'x))
158 ("needsx11"))
159 ("windowdump"
160 (viewer . "xwud -in %s")
161 (type . "image/x-xwd")
162 ("compose" . "xwd -frame > %s")
163 (test . (eq (mm-device-type) 'x))
164 ("needsx11"))
165 (".*"
166 (viewer . "aopen %s")
167 (type . "image/*")
168 (test . (eq (mm-device-type) 'ns)))
169 (".*"
170 (viewer . "display %s")
171 (type . "image/*")
172 (test . (eq (mm-device-type) 'x))
173 ("needsx11"))
174 (".*"
175 (viewer . "ee %s")
176 (type . "image/*")
177 (test . (eq (mm-device-type) 'x))
178 ("needsx11")))
179 ("text"
180 ("plain"
181 (viewer . w3-mode)
182 (test . (fboundp 'w3-mode))
183 (type . "text/plain"))
184 ("plain"
185 (viewer . view-mode)
186 (test . (fboundp 'view-mode))
187 (type . "text/plain"))
188 ("plain"
189 (viewer . fundamental-mode)
190 (type . "text/plain"))
191 ("enriched"
192 (viewer . enriched-decode-region)
193 (test . (fboundp 'enriched-decode))
194 (type . "text/enriched"))
195 ("html"
196 (viewer . mm-w3-prepare-buffer)
197 (test . (fboundp 'w3-prepare-buffer))
198 (type . "text/html")))
199 ("video"
200 ("mpeg"
201 (viewer . "mpeg_play %s")
202 (type . "video/mpeg")
203 (test . (eq (mm-device-type) 'x))
204 ("needsx11")))
205 ("x-world"
206 ("x-vrml"
207 (viewer . "webspace -remote %s -URL %u")
208 (type . "x-world/x-vrml")
209 ("description"
210 "VRML document")))
211 ("archive"
212 ("tar"
213 (viewer . tar-mode)
214 (type . "archive/tar")
215 (test . (fboundp 'tar-mode)))))
216 "The mailcap structure is an assoc list of assoc lists.
2171st assoc list is keyed on the major content-type
2182nd assoc list is keyed on the minor content-type (which can be a regexp)
219
220Which looks like:
221-----------------
222 ((\"application\"
223 (\"postscript\" . <info>))
224 (\"text\"
225 (\"plain\" . <info>)))
226
227Where <info> is another assoc list of the various information
228related to the mailcap RFC. This is keyed on the lowercase
229attribute name (viewer, test, etc). This looks like:
230 ((viewer . viewerinfo)
231 (test . testinfo)
232 (xxxx . \"string\"))
233
234Where viewerinfo specifies how the content-type is viewed. Can be
235a string, in which case it is run through a shell, with
236appropriate parameters, or a symbol, in which case the symbol is
237funcall'd, with the buffer as an argument.
238
239testinfo is a list of strings, or nil. If nil, it means the
240viewer specified is always valid. If it is a list of strings,
241these are used to determine whether a viewer passes the 'test' or
242not.")
243
244(defvar mailcap-download-directory nil
245 "*Where downloaded files should go by default.")
246
247(defvar mailcap-temporary-directory
248 (cond ((fboundp 'temp-directory) (temp-directory))
249 ((boundp 'temporary-file-directory) temporary-file-directory)
250 ("/tmp/"))
251 "*Where temporary files go.")
252
253;;;
254;;; Utility functions
255;;;
256
257(defun mailcap-generate-unique-filename (&optional fmt)
258 "Generate a unique filename in mailcap-temporary-directory."
259 (if (not fmt)
260 (let ((base (format "mailcap-tmp.%d" (user-real-uid)))
261 (fname "")
262 (x 0))
263 (setq fname (format "%s%d" base x))
264 (while (file-exists-p
265 (expand-file-name fname mailcap-temporary-directory))
266 (setq x (1+ x)
267 fname (concat base (int-to-string x))))
268 (expand-file-name fname mailcap-temporary-directory))
269 (let ((base (concat "mm" (int-to-string (user-real-uid))))
270 (fname "")
271 (x 0))
272 (setq fname (format fmt (concat base (int-to-string x))))
273 (while (file-exists-p
274 (expand-file-name fname mailcap-temporary-directory))
275 (setq x (1+ x)
276 fname (format fmt (concat base (int-to-string x)))))
277 (expand-file-name fname mailcap-temporary-directory))))
278
279(defun mailcap-save-binary-file ()
280 (goto-char (point-min))
281 (unwind-protect
282 (let ((file (read-file-name
283 "Filename to save as: "
284 (or mailcap-download-directory "~/")))
285 (require-final-newline nil))
286 (write-region (point-min) (point-max) file))
287 (kill-buffer (current-buffer))))
288
289(defvar mailcap-maybe-eval-warning
290 "*** WARNING ***
291
292This MIME part contains untrusted and possibly harmful content.
293If you evaluate the Emacs Lisp code contained in it, a lot of nasty
294things can happen. Please examine the code very carefully before you
295instruct Emacs to evaluate it. You can browse the buffer containing
296the code using \\[scroll-other-window].
297
298If you are unsure what to do, please answer \"no\"."
299 "Text of warning message displayed by `mailcap-maybe-eval'.
300Make sure that this text consists only of few text lines. Otherwise,
301Gnus might fail to display all of it.")
302
303(defun mailcap-maybe-eval ()
304 "Maybe evaluate a buffer of emacs lisp code."
305 (let ((lisp-buffer (current-buffer)))
306 (goto-char (point-min))
307 (when
308 (save-window-excursion
309 (delete-other-windows)
310 (let ((buffer (get-buffer-create (generate-new-buffer-name
311 "*Warning*"))))
312 (unwind-protect
313 (with-current-buffer buffer
314 (insert (substitute-command-keys
315 mailcap-maybe-eval-warning))
316 (goto-char (point-min))
317 (display-buffer buffer)
318 (yes-or-no-p "This is potentially dangerous emacs-lisp code, evaluate it? "))
319 (kill-buffer buffer))))
320 (eval-buffer (current-buffer)))
321 (when (buffer-live-p lisp-buffer)
322 (with-current-buffer lisp-buffer
323 (emacs-lisp-mode)))))
324
325
326;;;
327;;; The mailcap parser
328;;;
329
330(defun mailcap-replace-regexp (regexp to-string)
331 ;; Quiet replace-regexp.
332 (goto-char (point-min))
333 (while (re-search-forward regexp nil t)
334 (replace-match to-string t nil)))
335
336(defvar mailcap-parsed-p nil)
337
338(defun mailcap-parse-mailcaps (&optional path force)
339 "Parse out all the mailcaps specified in a path string PATH.
340Components of PATH are separated by the `path-separator' character
341appropriate for this system. If FORCE, re-parse even if already
342parsed. If PATH is omitted, use the value of environment variable
343MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus
344/usr/local/etc/mailcap."
345 (interactive (list nil t))
346 (when (or (not mailcap-parsed-p)
347 force)
348 (cond
349 (path nil)
350 ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS")))
351 ((memq system-type '(ms-dos ms-windows windows-nt))
352 (setq path '("~/.mailcap" "~/mail.cap" "~/etc/mail.cap")))
353 (t (setq path
354 ;; This is per RFC 1524, specifically
355 ;; with /usr before /usr/local.
356 '("~/.mailcap" "/etc/mailcap" "/usr/etc/mailcap"
357 "/usr/local/etc/mailcap"))))
358 (let ((fnames (reverse
359 (if (stringp path)
9b198954 360 (delete "" (split-string path path-separator))
c113de23
GM
361 path)))
362 fname)
363 (while fnames
364 (setq fname (car fnames))
365 (if (and (file-readable-p fname)
366 (file-regular-p fname))
367 (mailcap-parse-mailcap fname))
368 (setq fnames (cdr fnames))))
369 (setq mailcap-parsed-p t)))
370
371(defun mailcap-parse-mailcap (fname)
372 ;; Parse out the mailcap file specified by FNAME
373 (let (major ; The major mime type (image/audio/etc)
374 minor ; The minor mime type (gif, basic, etc)
375 save-pos ; Misc saved positions used in parsing
376 viewer ; How to view this mime type
377 info ; Misc info about this mime type
378 )
379 (with-temp-buffer
380 (insert-file-contents fname)
381 (set-syntax-table mailcap-parse-args-syntax-table)
382 (mailcap-replace-regexp "#.*" "") ; Remove all comments
383 (mailcap-replace-regexp "\\\\[ \t]*\n" " ") ; And collapse spaces
384 (mailcap-replace-regexp "\n+" "\n") ; And blank lines
385 (goto-char (point-max))
386 (skip-chars-backward " \t\n")
387 (delete-region (point) (point-max))
388 (while (not (bobp))
389 (skip-chars-backward " \t\n")
390 (beginning-of-line)
391 (setq save-pos (point)
392 info nil)
393 (skip-chars-forward "^/; \t\n")
394 (downcase-region save-pos (point))
395 (setq major (buffer-substring save-pos (point)))
396 (skip-chars-forward " \t")
397 (setq minor "")
398 (when (eq (char-after) ?/)
399 (forward-char)
400 (skip-chars-forward " \t")
401 (setq save-pos (point))
402 (skip-chars-forward "^; \t\n")
403 (downcase-region save-pos (point))
404 (setq minor
405 (cond
406 ((eq ?* (or (char-after save-pos) 0)) ".*")
407 ((= (point) save-pos) ".*")
408 (t (regexp-quote (buffer-substring save-pos (point)))))))
409 (skip-chars-forward " \t")
410 ;;; Got the major/minor chunks, now for the viewers/etc
411 ;;; The first item _must_ be a viewer, according to the
412 ;;; RFC for mailcap files (#1343)
413 (setq viewer "")
414 (when (eq (char-after) ?\;)
415 (forward-char)
416 (skip-chars-forward " \t")
417 (setq save-pos (point))
418 (skip-chars-forward "^;\n")
419 ;; skip \;
420 (while (eq (char-before) ?\\)
421 (backward-delete-char 1)
422 (forward-char)
423 (skip-chars-forward "^;\n"))
424 (if (eq (or (char-after save-pos) 0) ?')
425 (setq viewer (progn
426 (narrow-to-region (1+ save-pos) (point))
427 (goto-char (point-min))
428 (prog1
429 (read (current-buffer))
430 (goto-char (point-max))
431 (widen))))
432 (setq viewer (buffer-substring save-pos (point)))))
433 (setq save-pos (point))
434 (end-of-line)
435 (unless (equal viewer "")
436 (setq info (nconc (list (cons 'viewer viewer)
437 (cons 'type (concat major "/"
438 (if (string= minor ".*")
439 "*" minor))))
440 (mailcap-parse-mailcap-extras save-pos (point))))
441 (mailcap-mailcap-entry-passes-test info)
442 (mailcap-add-mailcap-entry major minor info))
443 (beginning-of-line)))))
444
445(defun mailcap-parse-mailcap-extras (st nd)
446 ;; Grab all the extra stuff from a mailcap entry
447 (let (
448 name ; From name=
449 value ; its value
450 results ; Assoc list of results
451 name-pos ; Start of XXXX= position
452 val-pos ; Start of value position
453 done ; Found end of \'d ;s?
454 )
455 (save-restriction
456 (narrow-to-region st nd)
457 (goto-char (point-min))
458 (skip-chars-forward " \n\t;")
459 (while (not (eobp))
460 (setq done nil)
461 (setq name-pos (point))
462 (skip-chars-forward "^ \n\t=;")
463 (downcase-region name-pos (point))
464 (setq name (buffer-substring name-pos (point)))
465 (skip-chars-forward " \t\n")
466 (if (not (eq (char-after (point)) ?=)) ; There is no value
467 (setq value t)
468 (skip-chars-forward " \t\n=")
469 (setq val-pos (point))
470 (if (memq (char-after val-pos) '(?\" ?'))
471 (progn
472 (setq val-pos (1+ val-pos))
473 (condition-case nil
474 (progn
475 (forward-sexp 1)
476 (backward-char 1))
477 (error (goto-char (point-max)))))
478 (while (not done)
479 (skip-chars-forward "^;")
480 (if (eq (char-after (1- (point))) ?\\ )
481 (progn
482 (subst-char-in-region (1- (point)) (point) ?\\ ? )
483 (skip-chars-forward ";"))
484 (setq done t))))
485 (setq value (buffer-substring val-pos (point))))
486 (setq results (cons (cons name value) results))
487 (skip-chars-forward " \";\n\t"))
488 results)))
489
490(defun mailcap-mailcap-entry-passes-test (info)
491 ;; Return t iff a mailcap entry passes its test clause or no test
492 ;; clause is present.
493 (let (status ; Call-process-regions return value
494 (test (assq 'test info)) ; The test clause
495 )
496 (setq status (and test (split-string (cdr test) " ")))
497 (if (and (or (assoc "needsterm" info)
498 (assoc "needsterminal" info)
499 (assoc "needsx11" info))
500 (not (getenv "DISPLAY")))
501 (setq status nil)
502 (cond
503 ((and (equal (nth 0 status) "test")
504 (equal (nth 1 status) "-n")
505 (or (equal (nth 2 status) "$DISPLAY")
506 (equal (nth 2 status) "\"$DISPLAY\"")))
507 (setq status (if (getenv "DISPLAY") t nil)))
508 ((and (equal (nth 0 status) "test")
509 (equal (nth 1 status) "-z")
510 (or (equal (nth 2 status) "$DISPLAY")
511 (equal (nth 2 status) "\"$DISPLAY\"")))
512 (setq status (if (getenv "DISPLAY") nil t)))
513 (test nil)
514 (t nil)))
515 (and test (listp test) (setcdr test status))))
516
517;;;
518;;; The action routines.
519;;;
520
521(defun mailcap-possible-viewers (major minor)
522 ;; Return a list of possible viewers from MAJOR for minor type MINOR
523 (let ((exact '())
524 (wildcard '()))
525 (while major
526 (cond
527 ((equal (car (car major)) minor)
528 (setq exact (cons (cdr (car major)) exact)))
529 ((and minor (string-match (car (car major)) minor))
530 (setq wildcard (cons (cdr (car major)) wildcard))))
531 (setq major (cdr major)))
532 (nconc exact wildcard)))
533
534(defun mailcap-unescape-mime-test (test type-info)
535 (let (save-pos save-chr subst)
536 (cond
537 ((symbolp test) test)
538 ((and (listp test) (symbolp (car test))) test)
539 ((or (stringp test)
540 (and (listp test) (stringp (car test))
541 (setq test (mapconcat 'identity test " "))))
542 (with-temp-buffer
543 (insert test)
544 (goto-char (point-min))
545 (while (not (eobp))
546 (skip-chars-forward "^%")
547 (if (/= (- (point)
548 (progn (skip-chars-backward "\\\\")
549 (point)))
550 0) ; It is an escaped %
551 (progn
552 (delete-char 1)
553 (skip-chars-forward "%."))
554 (setq save-pos (point))
555 (skip-chars-forward "%")
556 (setq save-chr (char-after (point)))
557 (cond
558 ((null save-chr) nil)
559 ((= save-chr ?t)
560 (delete-region save-pos (progn (forward-char 1) (point)))
561 (insert (or (cdr (assq 'type type-info)) "\"\"")))
562 ((= save-chr ?M)
563 (delete-region save-pos (progn (forward-char 1) (point)))
564 (insert "\"\""))
565 ((= save-chr ?n)
566 (delete-region save-pos (progn (forward-char 1) (point)))
567 (insert "\"\""))
568 ((= save-chr ?F)
569 (delete-region save-pos (progn (forward-char 1) (point)))
570 (insert "\"\""))
571 ((= save-chr ?{)
572 (forward-char 1)
573 (skip-chars-forward "^}")
574 (downcase-region (+ 2 save-pos) (point))
575 (setq subst (buffer-substring (+ 2 save-pos) (point)))
576 (delete-region save-pos (1+ (point)))
577 (insert (or (cdr (assoc subst type-info)) "\"\"")))
578 (t nil))))
579 (buffer-string)))
580 (t (error "Bad value to mailcap-unescape-mime-test. %s" test)))))
581
582(defvar mailcap-viewer-test-cache nil)
583
584(defun mailcap-viewer-passes-test (viewer-info type-info)
585 ;; Return non-nil iff the viewer specified by VIEWER-INFO passes its
586 ;; test clause (if any).
587 (let* ((test-info (assq 'test viewer-info))
588 (test (cdr test-info))
589 (otest test)
590 (viewer (cdr (assoc 'viewer viewer-info)))
591 (default-directory (expand-file-name "~/"))
592 status parsed-test cache result)
593 (if (setq cache (assoc test mailcap-viewer-test-cache))
594 (cadr cache)
595 (setq
596 result
597 (cond
598 ((not test-info) t) ; No test clause
599 ((not test) nil) ; Already failed test
600 ((eq test t) t) ; Already passed test
601 ((and (symbolp test) ; Lisp function as test
602 (fboundp test))
603 (funcall test type-info))
604 ((and (symbolp test) ; Lisp variable as test
605 (boundp test))
606 (symbol-value test))
607 ((and (listp test) ; List to be eval'd
608 (symbolp (car test)))
609 (eval test))
610 (t
611 (setq test (mailcap-unescape-mime-test test type-info)
612 test (list shell-file-name nil nil nil
613 shell-command-switch test)
614 status (apply 'call-process test))
615 (= 0 status))))
616 (push (list otest result) mailcap-viewer-test-cache)
617 result)))
618
619(defun mailcap-add-mailcap-entry (major minor info)
620 (let ((old-major (assoc major mailcap-mime-data)))
621 (if (null old-major) ; New major area
622 (setq mailcap-mime-data
623 (cons (cons major (list (cons minor info)))
624 mailcap-mime-data))
625 (let ((cur-minor (assoc minor old-major)))
626 (cond
627 ((or (null cur-minor) ; New minor area, or
628 (assq 'test info)) ; Has a test, insert at beginning
629 (setcdr old-major (cons (cons minor info) (cdr old-major))))
630 ((and (not (assq 'test info)) ; No test info, replace completely
631 (not (assq 'test cur-minor))
632 (equal (assq 'viewer info) ; Keep alternative viewer
633 (assq 'viewer cur-minor)))
634 (setcdr cur-minor info))
635 (t
636 (setcdr old-major (cons (cons minor info) (cdr old-major))))))
637 )))
638
639(defun mailcap-add (type viewer &optional test)
640 "Add VIEWER as a handler for TYPE.
641If TEST is not given, it defaults to t."
642 (let ((tl (split-string type "/")))
643 (when (or (not (car tl))
644 (not (cadr tl)))
645 (error "%s is not a valid MIME type" type))
646 (mailcap-add-mailcap-entry
647 (car tl) (cadr tl)
648 `((viewer . ,viewer)
649 (test . ,(if test test t))
650 (type . ,type)))))
651
652;;;
653;;; The main whabbo
654;;;
655
656(defun mailcap-viewer-lessp (x y)
657 ;; Return t iff viewer X is more desirable than viewer Y
658 (let ((x-wild (string-match "[*?]" (or (cdr-safe (assq 'type x)) "")))
659 (y-wild (string-match "[*?]" (or (cdr-safe (assq 'type y)) "")))
660 (x-lisp (not (stringp (or (cdr-safe (assq 'viewer x)) ""))))
661 (y-lisp (not (stringp (or (cdr-safe (assq 'viewer y)) "")))))
662 (cond
663 ((and x-wild (not y-wild))
664 nil)
665 ((and (not x-wild) y-wild)
666 t)
667 ((and (not y-lisp) x-lisp)
668 t)
669 (t nil))))
670
671(defun mailcap-mime-info (string &optional request)
672 "Get the MIME viewer command for STRING, return nil if none found.
673Expects a complete content-type header line as its argument.
674
675Second argument REQUEST specifies what information to return. If it is
676nil or the empty string, the viewer (second field of the mailcap
677entry) will be returned. If it is a string, then the mailcap field
678corresponding to that string will be returned (print, description,
679whatever). If a number, then all the information for this specific
680viewer is returned. If `all', then all possible viewers for
681this type is returned."
682 (let (
683 major ; Major encoding (text, etc)
684 minor ; Minor encoding (html, etc)
685 info ; Other info
686 save-pos ; Misc. position during parse
687 major-info ; (assoc major mailcap-mime-data)
688 minor-info ; (assoc minor major-info)
689 test ; current test proc.
690 viewers ; Possible viewers
691 passed ; Viewers that passed the test
692 viewer ; The one and only viewer
693 ctl)
694 (save-excursion
695 (setq ctl (mail-header-parse-content-type (or string "text/plain")))
696 (setq major (split-string (car ctl) "/"))
697 (setq minor (cadr major)
698 major (car major))
699 (when (setq major-info (cdr (assoc major mailcap-mime-data)))
700 (when (setq viewers (mailcap-possible-viewers major-info minor))
701 (setq info (mapcar (lambda (a) (cons (symbol-name (car a))
702 (cdr a)))
703 (cdr ctl)))
704 (while viewers
705 (if (mailcap-viewer-passes-test (car viewers) info)
706 (setq passed (cons (car viewers) passed)))
707 (setq viewers (cdr viewers)))
708 (setq passed (sort passed 'mailcap-viewer-lessp))
709 (setq viewer (car passed))))
710 (when (and (stringp (cdr (assq 'viewer viewer)))
711 passed)
712 (setq viewer (car passed)))
713 (cond
714 ((and (null viewer) (not (equal major "default")) request)
715 (mailcap-mime-info "default" request))
716 ((or (null request) (equal request ""))
717 (mailcap-unescape-mime-test (cdr (assq 'viewer viewer)) info))
718 ((stringp request)
719 (if (or (eq request 'test) (eq request 'viewer))
720 (mailcap-unescape-mime-test
721 (cdr-safe (assoc request viewer)) info)))
722 ((eq request 'all)
723 passed)
724 (t
725 ;; MUST make a copy *sigh*, else we modify mailcap-mime-data
726 (setq viewer (copy-sequence viewer))
727 (let ((view (assq 'viewer viewer))
728 (test (assq 'test viewer)))
729 (if view (setcdr view (mailcap-unescape-mime-test (cdr view) info)))
730 (if test (setcdr test (mailcap-unescape-mime-test (cdr test) info))))
731 viewer)))))
732
733;;;
734;;; Experimental MIME-types parsing
735;;;
736
737(defvar mailcap-mime-extensions
738 '(("" . "text/plain")
739 (".abs" . "audio/x-mpeg")
740 (".aif" . "audio/aiff")
741 (".aifc" . "audio/aiff")
742 (".aiff" . "audio/aiff")
743 (".ano" . "application/x-annotator")
744 (".au" . "audio/ulaw")
745 (".avi" . "video/x-msvideo")
746 (".bcpio" . "application/x-bcpio")
747 (".bin" . "application/octet-stream")
748 (".cdf" . "application/x-netcdr")
749 (".cpio" . "application/x-cpio")
750 (".csh" . "application/x-csh")
751 (".css" . "text/css")
752 (".dvi" . "application/x-dvi")
753 (".diff" . "text/x-patch")
754 (".el" . "application/emacs-lisp")
755 (".eps" . "application/postscript")
756 (".etx" . "text/x-setext")
757 (".exe" . "application/octet-stream")
758 (".fax" . "image/x-fax")
759 (".gif" . "image/gif")
760 (".hdf" . "application/x-hdf")
761 (".hqx" . "application/mac-binhex40")
762 (".htm" . "text/html")
763 (".html" . "text/html")
764 (".icon" . "image/x-icon")
765 (".ief" . "image/ief")
766 (".jpg" . "image/jpeg")
767 (".macp" . "image/x-macpaint")
768 (".man" . "application/x-troff-man")
769 (".me" . "application/x-troff-me")
770 (".mif" . "application/mif")
771 (".mov" . "video/quicktime")
772 (".movie" . "video/x-sgi-movie")
773 (".mp2" . "audio/x-mpeg")
774 (".mp3" . "audio/x-mpeg")
775 (".mp2a" . "audio/x-mpeg2")
776 (".mpa" . "audio/x-mpeg")
777 (".mpa2" . "audio/x-mpeg2")
778 (".mpe" . "video/mpeg")
779 (".mpeg" . "video/mpeg")
780 (".mpega" . "audio/x-mpeg")
781 (".mpegv" . "video/mpeg")
782 (".mpg" . "video/mpeg")
783 (".mpv" . "video/mpeg")
784 (".ms" . "application/x-troff-ms")
785 (".nc" . "application/x-netcdf")
786 (".nc" . "application/x-netcdf")
787 (".oda" . "application/oda")
788 (".patch" . "text/x-patch")
789 (".pbm" . "image/x-portable-bitmap")
790 (".pdf" . "application/pdf")
791 (".pgm" . "image/portable-graymap")
792 (".pict" . "image/pict")
793 (".png" . "image/png")
794 (".pnm" . "image/x-portable-anymap")
795 (".ppm" . "image/portable-pixmap")
796 (".ps" . "application/postscript")
797 (".qt" . "video/quicktime")
798 (".ras" . "image/x-raster")
799 (".rgb" . "image/x-rgb")
800 (".rtf" . "application/rtf")
801 (".rtx" . "text/richtext")
802 (".sh" . "application/x-sh")
803 (".sit" . "application/x-stuffit")
804 (".snd" . "audio/basic")
805 (".src" . "application/x-wais-source")
806 (".tar" . "archive/tar")
807 (".tcl" . "application/x-tcl")
808 (".tcl" . "application/x-tcl")
809 (".tex" . "application/x-tex")
810 (".texi" . "application/texinfo")
811 (".tga" . "image/x-targa")
812 (".tif" . "image/tiff")
813 (".tiff" . "image/tiff")
814 (".tr" . "application/x-troff")
815 (".troff" . "application/x-troff")
816 (".tsv" . "text/tab-separated-values")
817 (".txt" . "text/plain")
818 (".vbs" . "video/mpeg")
819 (".vox" . "audio/basic")
820 (".vrml" . "x-world/x-vrml")
821 (".wav" . "audio/x-wav")
822 (".wrl" . "x-world/x-vrml")
823 (".xbm" . "image/xbm")
824 (".xpm" . "image/xpm")
825 (".xwd" . "image/windowdump")
826 (".zip" . "application/zip")
827 (".ai" . "application/postscript")
828 (".jpe" . "image/jpeg")
829 (".jpeg" . "image/jpeg"))
830 "An assoc list of file extensions and corresponding MIME content-types.")
831
832(defvar mailcap-mimetypes-parsed-p nil)
833
834(defun mailcap-parse-mimetypes (&optional path force)
835 "Parse out all the mimetypes specified in a unix-style path string PATH.
836Components of PATH are separated by the `path-separator' character
837appropriate for this system. If PATH is omitted, use the value of
838environment variable MIMETYPES if set; otherwise use a default path.
839If FORCE, re-parse even if already parsed."
840 (interactive (list nil t))
841 (when (or (not mailcap-mimetypes-parsed-p)
842 force)
843 (cond
844 (path nil)
845 ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES")))
846 ((memq system-type '(ms-dos ms-windows windows-nt))
847 (setq path '("~/mime.typ" "~/etc/mime.typ")))
848 (t (setq path
849 ;; mime.types seems to be the normal name, definitely so
850 ;; on current GNUish systems. The search order follows
851 ;; that for mailcap.
852 '("~/.mime.types"
853 "/etc/mime.types"
854 "/usr/etc/mime.types"
855 "/usr/local/etc/mime.types"
856 "/usr/local/www/conf/mime.types"
857 "~/.mime-types"
858 "/etc/mime-types"
859 "/usr/etc/mime-types"
860 "/usr/local/etc/mime-types"
861 "/usr/local/www/conf/mime-types"))))
862 (let ((fnames (reverse (if (stringp path)
9b198954 863 (delete "" (split-string path path-separator))
c113de23
GM
864 path)))
865 fname)
866 (while fnames
867 (setq fname (car fnames))
868 (if (and (file-readable-p fname))
869 (mailcap-parse-mimetype-file fname))
870 (setq fnames (cdr fnames))))
871 (setq mailcap-mimetypes-parsed-p t)))
872
873(defun mailcap-parse-mimetype-file (fname)
874 ;; Parse out a mime-types file
875 (let (type ; The MIME type for this line
876 extns ; The extensions for this line
877 save-pos ; Misc. saved buffer positions
878 )
879 (with-temp-buffer
880 (insert-file-contents fname)
881 (mailcap-replace-regexp "#.*" "")
882 (mailcap-replace-regexp "\n+" "\n")
883 (mailcap-replace-regexp "[ \t]+$" "")
884 (goto-char (point-max))
885 (skip-chars-backward " \t\n")
886 (delete-region (point) (point-max))
887 (goto-char (point-min))
888 (while (not (eobp))
889 (skip-chars-forward " \t\n")
890 (setq save-pos (point))
891 (skip-chars-forward "^ \t\n")
892 (downcase-region save-pos (point))
893 (setq type (buffer-substring save-pos (point)))
894 (while (not (eolp))
895 (skip-chars-forward " \t")
896 (setq save-pos (point))
897 (skip-chars-forward "^ \t\n")
898 (setq extns (cons (buffer-substring save-pos (point)) extns)))
899 (while extns
900 (setq mailcap-mime-extensions
901 (cons
902 (cons (if (= (string-to-char (car extns)) ?.)
903 (car extns)
904 (concat "." (car extns))) type)
905 mailcap-mime-extensions)
906 extns (cdr extns)))))))
907
908(defun mailcap-extension-to-mime (extn)
909 "Return the MIME content type of the file extensions EXTN."
910 (mailcap-parse-mimetypes)
911 (if (and (stringp extn)
912 (not (eq (string-to-char extn) ?.)))
913 (setq extn (concat "." extn)))
914 (cdr (assoc (downcase extn) mailcap-mime-extensions)))
915
916(defvar mailcap-binary-suffixes
917 (if (memq system-type '(ms-dos windows-nt))
918 '(".exe" ".com" ".bat" ".cmd" ".btm" "")
919 '("")))
920
921(defun mailcap-command-p (command)
922 "Say whether COMMAND is in the exec path.
923The path of COMMAND will be returned iff COMMAND is a command."
924 (let ((path (if (file-name-absolute-p command) '(nil) exec-path))
925 file dir)
926 (catch 'found
927 (while (setq dir (pop path))
928 (let ((suffixes mailcap-binary-suffixes))
929 (while suffixes
930 (when (and (file-executable-p
931 (setq file (expand-file-name
932 (concat command (pop suffixes))
933 dir)))
934 (not (file-directory-p file)))
935 (throw 'found file))))))))
936
937(defun mailcap-mime-types ()
938 "Return a list of MIME media types."
939 (mailcap-parse-mimetypes)
9b198954
DL
940 (mm-delete-duplicates
941 (nconc
942 (mapcar 'cdr mailcap-mime-extensions)
943 (apply
944 'nconc
945 (mapcar
946 (lambda (l)
947 (delq nil
948 (mapcar
949 (lambda (m)
950 (let ((type (cdr (assq 'type (cdr m)))))
951 (if (equal (cadr (split-string type "/"))
952 "*")
953 nil
954 type)))
955 (cdr l))))
956 mailcap-mime-data)))))
c113de23
GM
957
958(provide 'mailcap)
959
960;;; mailcap.el ends here