1 ;;; mailcap.el --- Functions for displaying MIME parts
2 ;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
4 ;; Author: William M. Perry <wmperry@aventail.com>
5 ;; Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Keywords: news, mail
8 ;; This file is part of GNU Emacs.
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)
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.
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.
29 (eval-when-compile (require 'cl))
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)
40 "A syntax table for parsing sgml attributes.")
42 (defvar mailcap-mime-data
45 (viewer . ssl-view-site-cert)
46 (test . (fboundp 'ssl-view-site-cert))
47 (type . "application/x-x509-ca-cert"))
49 (viewer . ssl-view-user-cert)
50 (test . (fboundp 'ssl-view-user-cert))
51 (type . "application/x-x509-user-cert"))
53 (viewer . mailcap-save-binary-file)
55 (type ."application/octet-stream"))
58 (type . "application/dvi")
59 (test . (eq (mm-device-type) 'ns)))
62 (test . (eq (mm-device-type) 'x))
64 (type . "application/dvi"))
66 (viewer . "dvitty %s")
67 (test . (not (getenv "DISPLAY")))
68 (type . "application/dvi"))
70 (viewer . mailcap-maybe-eval)
71 (type . "application/emacs-lisp"))
73 (viewer . mailcap-save-binary-file)
75 (type . "application/x-tar"))
78 (test . (fboundp 'tex-mode))
79 (type . "application/x-latex"))
82 (test . (fboundp 'tex-mode))
83 (type . "application/x-tex"))
86 (test . (fboundp 'tex-mode))
87 (type . "application/latex"))
90 (test . (fboundp 'tex-mode))
91 (type . "application/tex"))
93 (viewer . texinfo-mode)
94 (test . (fboundp 'texinfo-mode))
95 (type . "application/tex"))
97 (viewer . mailcap-save-binary-file)
99 (type . "application/zip")
102 (viewer . "acroread %s")
103 (type . "application/pdf"))
106 (type . "application/postscript")
107 (test . (eq (mm-device-type) 'ns)))
109 (viewer . "ghostview -dSAFER %s")
110 (type . "application/postscript")
111 (test . (eq (mm-device-type) 'x))
114 (viewer . "ps2ascii %s")
115 (type . "application/postscript")
116 (test . (not (getenv "DISPLAY")))
120 (viewer . "maplay %s")
121 (type . "audio/x-mpeg"))
123 (viewer . "showaudio")
127 (viewer . mm-view-message)
128 (test . (and (featurep 'gnus)
130 (type . "message/rfc822"))
133 (test . (fboundp 'vm-mode))
134 (type . "message/rfc822"))
137 (test . (fboundp 'w3-mode))
138 (type . "message/rfc822"))
141 (test . (fboundp 'view-mode))
142 (type . "message/rfc822"))
144 (viewer . fundamental-mode)
145 (type . "message/rfc822")))
148 (viewer . "xwud -in %s")
149 (type . "image/x-xwd")
150 ("compose" . "xwd -frame > %s")
151 (test . (eq (mm-device-type) 'x))
154 (viewer . "xwud -in %s")
155 (type . "image/x-xwd")
156 ("compose" . "xwd -frame > %s")
157 (test . (eq (mm-device-type) 'x))
160 (viewer . "xwud -in %s")
161 (type . "image/x-xwd")
162 ("compose" . "xwd -frame > %s")
163 (test . (eq (mm-device-type) 'x))
166 (viewer . "aopen %s")
168 (test . (eq (mm-device-type) 'ns)))
170 (viewer . "display %s")
172 (test . (eq (mm-device-type) 'x))
177 (test . (eq (mm-device-type) 'x))
182 (test . (fboundp 'w3-mode))
183 (type . "text/plain"))
186 (test . (fboundp 'view-mode))
187 (type . "text/plain"))
189 (viewer . fundamental-mode)
190 (type . "text/plain"))
192 (viewer . enriched-decode-region)
193 (test . (fboundp 'enriched-decode))
194 (type . "text/enriched"))
196 (viewer . mm-w3-prepare-buffer)
197 (test . (fboundp 'w3-prepare-buffer))
198 (type . "text/html")))
201 (viewer . "mpeg_play %s")
202 (type . "video/mpeg")
203 (test . (eq (mm-device-type) 'x))
207 (viewer . "webspace -remote %s -URL %u")
208 (type . "x-world/x-vrml")
214 (type . "archive/tar")
215 (test . (fboundp 'tar-mode)))))
216 "The mailcap structure is an assoc list of assoc lists.
217 1st assoc list is keyed on the major content-type
218 2nd assoc list is keyed on the minor content-type (which can be a regexp)
223 (\"postscript\" . <info>))
225 (\"plain\" . <info>)))
227 Where <info> is another assoc list of the various information
228 related to the mailcap RFC. This is keyed on the lowercase
229 attribute name (viewer, test, etc). This looks like:
230 ((viewer . viewerinfo)
234 Where viewerinfo specifies how the content-type is viewed. Can be
235 a string, in which case it is run through a shell, with
236 appropriate parameters, or a symbol, in which case the symbol is
237 funcall'd, with the buffer as an argument.
239 testinfo is a list of strings, or nil. If nil, it means the
240 viewer specified is always valid. If it is a list of strings,
241 these are used to determine whether a viewer passes the 'test' or
244 (defvar mailcap-download-directory nil
245 "*Where downloaded files should go by default.")
247 (defvar mailcap-temporary-directory
248 (cond ((fboundp 'temp-directory) (temp-directory))
249 ((boundp 'temporary-file-directory) temporary-file-directory)
251 "*Where temporary files go.")
254 ;;; Utility functions
257 (defun mailcap-generate-unique-filename (&optional fmt)
258 "Generate a unique filename in mailcap-temporary-directory."
260 (let ((base (format "mailcap-tmp.%d" (user-real-uid)))
263 (setq fname (format "%s%d" base x))
264 (while (file-exists-p
265 (expand-file-name fname mailcap-temporary-directory))
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))))
272 (setq fname (format fmt (concat base (int-to-string x))))
273 (while (file-exists-p
274 (expand-file-name fname mailcap-temporary-directory))
276 fname (format fmt (concat base (int-to-string x)))))
277 (expand-file-name fname mailcap-temporary-directory))))
279 (defun mailcap-save-binary-file ()
280 (goto-char (point-min))
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))))
289 (defun mailcap-maybe-eval ()
290 "Maybe evaluate a buffer of emacs lisp code."
291 (if (yes-or-no-p "This is emacs-lisp code, evaluate it? ")
292 (eval-buffer (current-buffer))
296 ;;; The mailcap parser
299 (defun mailcap-replace-regexp (regexp to-string)
300 ;; Quiet replace-regexp.
301 (goto-char (point-min))
302 (while (re-search-forward regexp nil t)
303 (replace-match to-string t nil)))
305 (defvar mailcap-parsed-p nil)
307 (defun mailcap-parse-mailcaps (&optional path force)
308 "Parse out all the mailcaps specified in a unix-style path string PATH.
309 If FORCE, re-parse even if already parsed."
310 (interactive (list nil t))
311 (when (or (not mailcap-parsed-p)
315 ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS")))
316 ((memq system-type '(ms-dos ms-windows windows-nt))
317 (setq path (mapconcat 'expand-file-name
318 '("~/mail.cap" "~/etc/mail.cap" "~/.mailcap")
320 (t (setq path (mapconcat 'expand-file-name
322 "/etc/mailcap:/usr/etc/mailcap"
323 "/usr/local/etc/mailcap") ":"))))
324 (let ((fnames (reverse
326 path (if (memq system-type
327 '(ms-dos ms-windows windows-nt))
332 (setq fname (car fnames))
333 (if (and (file-exists-p fname) (file-readable-p fname)
334 (file-regular-p fname))
335 (mailcap-parse-mailcap (car fnames)))
336 (setq fnames (cdr fnames))))
337 (setq mailcap-parsed-p t)))
339 (defun mailcap-parse-mailcap (fname)
340 ;; Parse out the mailcap file specified by FNAME
341 (let (major ; The major mime type (image/audio/etc)
342 minor ; The minor mime type (gif, basic, etc)
343 save-pos ; Misc saved positions used in parsing
344 viewer ; How to view this mime type
345 info ; Misc info about this mime type
348 (insert-file-contents fname)
349 (set-syntax-table mailcap-parse-args-syntax-table)
350 (mailcap-replace-regexp "#.*" "") ; Remove all comments
351 (mailcap-replace-regexp "\n+" "\n") ; And blank lines
352 (mailcap-replace-regexp "\\\\[ \t\n]+" " ") ; And collapse spaces
353 (mailcap-replace-regexp (concat (regexp-quote "\\") "[ \t]*\n") "")
354 (goto-char (point-max))
355 (skip-chars-backward " \t\n")
356 (delete-region (point) (point-max))
357 (goto-char (point-min))
359 (skip-chars-forward " \t\n")
360 (setq save-pos (point)
362 (skip-chars-forward "^/; \t\n")
363 (downcase-region save-pos (point))
364 (setq major (buffer-substring save-pos (point)))
365 (skip-chars-forward " \t\n")
367 (when (eq (char-after) ?/)
369 (skip-chars-forward " \t\n")
370 (setq save-pos (point))
371 (skip-chars-forward "^; \t\n")
372 (downcase-region save-pos (point))
375 ((eq ?* (or (char-after save-pos) 0)) ".*")
376 ((= (point) save-pos) ".*")
377 (t (regexp-quote (buffer-substring save-pos (point)))))))
378 (skip-chars-forward " \t\n")
379 ;;; Got the major/minor chunks, now for the viewers/etc
380 ;;; The first item _must_ be a viewer, according to the
381 ;;; RFC for mailcap files (#1343)
383 (when (eq (char-after) ?\;)
385 (skip-chars-forward " \t\n")
386 (setq save-pos (point))
387 (skip-chars-forward "^;\n")
389 (while (eq (char-before) ?\\)
390 (backward-delete-char 1)
392 (skip-chars-forward "^;\n"))
393 (if (eq (or (char-after save-pos) 0) ?')
395 (narrow-to-region (1+ save-pos) (point))
396 (goto-char (point-min))
398 (read (current-buffer))
399 (goto-char (point-max))
401 (setq viewer (buffer-substring save-pos (point)))))
402 (setq save-pos (point))
404 (unless (equal viewer "")
405 (setq info (nconc (list (cons 'viewer viewer)
406 (cons 'type (concat major "/"
407 (if (string= minor ".*")
409 (mailcap-parse-mailcap-extras save-pos (point))))
410 (mailcap-mailcap-entry-passes-test info)
411 (mailcap-add-mailcap-entry major minor info))))))
413 (defun mailcap-parse-mailcap-extras (st nd)
414 ;; Grab all the extra stuff from a mailcap entry
418 results ; Assoc list of results
419 name-pos ; Start of XXXX= position
420 val-pos ; Start of value position
421 done ; Found end of \'d ;s?
424 (narrow-to-region st nd)
425 (goto-char (point-min))
426 (skip-chars-forward " \n\t;")
429 (setq name-pos (point))
430 (skip-chars-forward "^ \n\t=;")
431 (downcase-region name-pos (point))
432 (setq name (buffer-substring name-pos (point)))
433 (skip-chars-forward " \t\n")
434 (if (not (eq (char-after (point)) ?=)) ; There is no value
436 (skip-chars-forward " \t\n=")
437 (setq val-pos (point))
438 (if (memq (char-after val-pos) '(?\" ?'))
440 (setq val-pos (1+ val-pos))
445 (error (goto-char (point-max)))))
447 (skip-chars-forward "^;")
448 (if (eq (char-after (1- (point))) ?\\ )
450 (subst-char-in-region (1- (point)) (point) ?\\ ? )
451 (skip-chars-forward ";"))
453 (setq value (buffer-substring val-pos (point))))
454 (setq results (cons (cons name value) results))
455 (skip-chars-forward " \";\n\t"))
458 (defun mailcap-mailcap-entry-passes-test (info)
459 ;; Return t iff a mailcap entry passes its test clause or no test
460 ;; clause is present.
461 (let (status ; Call-process-regions return value
462 (test (assq 'test info)) ; The test clause
464 (setq status (and test (split-string (cdr test) " ")))
465 (if (and (or (assoc "needsterm" info)
466 (assoc "needsterminal" info)
467 (assoc "needsx11" info))
468 (not (getenv "DISPLAY")))
471 ((and (equal (nth 0 status) "test")
472 (equal (nth 1 status) "-n")
473 (or (equal (nth 2 status) "$DISPLAY")
474 (equal (nth 2 status) "\"$DISPLAY\"")))
475 (setq status (if (getenv "DISPLAY") t nil)))
476 ((and (equal (nth 0 status) "test")
477 (equal (nth 1 status) "-z")
478 (or (equal (nth 2 status) "$DISPLAY")
479 (equal (nth 2 status) "\"$DISPLAY\"")))
480 (setq status (if (getenv "DISPLAY") nil t)))
483 (and test (listp test) (setcdr test status))))
486 ;;; The action routines.
489 (defun mailcap-possible-viewers (major minor)
490 ;; Return a list of possible viewers from MAJOR for minor type MINOR
495 ((equal (car (car major)) minor)
496 (setq exact (cons (cdr (car major)) exact)))
497 ((and minor (string-match (car (car major)) minor))
498 (setq wildcard (cons (cdr (car major)) wildcard))))
499 (setq major (cdr major)))
500 (nconc (nreverse exact) (nreverse wildcard))))
502 (defun mailcap-unescape-mime-test (test type-info)
503 (let (save-pos save-chr subst)
505 ((symbolp test) test)
506 ((and (listp test) (symbolp (car test))) test)
508 (and (listp test) (stringp (car test))
509 (setq test (mapconcat 'identity test " "))))
512 (goto-char (point-min))
514 (skip-chars-forward "^%")
516 (progn (skip-chars-backward "\\\\")
518 0) ; It is an escaped %
521 (skip-chars-forward "%."))
522 (setq save-pos (point))
523 (skip-chars-forward "%")
524 (setq save-chr (char-after (point)))
526 ((null save-chr) nil)
528 (delete-region save-pos (progn (forward-char 1) (point)))
529 (insert (or (cdr (assq 'type type-info)) "\"\"")))
531 (delete-region save-pos (progn (forward-char 1) (point)))
534 (delete-region save-pos (progn (forward-char 1) (point)))
537 (delete-region save-pos (progn (forward-char 1) (point)))
541 (skip-chars-forward "^}")
542 (downcase-region (+ 2 save-pos) (point))