cgit.sxemacs.org Git - gnus/blob - lisp/mailcap.el

   1 ;;; mailcap.el --- MIME media types configuration
   2 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.
   3
   4 ;; Author: William M. Perry <wmperry@aventail.com>
   5 ;;      Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: news, mail, multimedia
   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 ;; Provides configuration of MIME media types from directly from Lisp
  28 ;; and via the usual mailcap mechanism (RFC 1524).  Deals with
  29 ;; mime.types similarly.
  30
  31 ;;; Code:
  32
  33 (eval-when-compile (require 'cl))
  34 (require 'mail-parse)
  35 (require 'mm-util)
  36
  37 (defgroup mailcap nil
  38   "Definition of viewers for MIME types."
  39   :version "21.1"
  40   :group 'mime)
  41
  42 (defvar mailcap-parse-args-syntax-table
  43   (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
  44     (modify-syntax-entry ?' "\"" table)
  45     (modify-syntax-entry ?` "\"" table)
  46     (modify-syntax-entry ?{ "(" table)
  47     (modify-syntax-entry ?} ")" table)
  48     table)
  49   "A syntax table for parsing sgml attributes.")
  50
  51 ;; Postpone using defcustom for this as it's so big and we essentially
  52 ;; have to have two copies of the data around then.  Perhaps just
  53 ;; customize the Lisp viewers and rely on the normal configuration
  54 ;; files for the rest?  -- fx
  55 (defvar mailcap-mime-data
  56   '(("application"
  57      ("vnd.ms-excel"
  58       (viewer . "gnumeric %s")
  59       (test   . (getenv "DISPLAY"))
  60       (type . "application/vnd.ms-excel"))
  61      ("x-x509-ca-cert"
  62       (viewer . ssl-view-site-cert)
  63       (test . (fboundp 'ssl-view-site-cert))
  64       (type . "application/x-x509-ca-cert"))
  65      ("x-x509-user-cert"
  66       (viewer . ssl-view-user-cert)
  67       (test . (fboundp 'ssl-view-user-cert))
  68       (type . "application/x-x509-user-cert"))
  69      ("octet-stream"
  70       (viewer . mailcap-save-binary-file)
  71       (non-viewer . t)
  72       (type . "application/octet-stream"))
  73 ;;; XEmacs says `ns' device-type not implemented.
  74 ;;      ("dvi"
  75 ;;       (viewer . "open %s")
  76 ;;       (type   . "application/dvi")
  77 ;;       (test   . (eq (mm-device-type) 'ns)))
  78      ("dvi"
  79       (viewer . "xdvi -safer %s")
  80       (test   . (eq window-system 'x))
  81       ("needsx11")
  82       (type   . "application/dvi"))
  83      ("dvi"
  84       (viewer . "dvitty %s")
  85       (test   . (not (getenv "DISPLAY")))
  86       (type   . "application/dvi"))
  87      ("emacs-lisp"
  88       (viewer . mailcap-maybe-eval)
  89       (type   . "application/emacs-lisp"))
  90      ("x-emacs-lisp"
  91       (viewer . mailcap-maybe-eval)
  92       (type   . "application/x-emacs-lisp"))
  93      ("x-tar"
  94       (viewer . mailcap-save-binary-file)
  95       (non-viewer . t)
  96       (type   . "application/x-tar"))
  97      ("x-latex"
  98       (viewer . tex-mode)
  99       (test   . (fboundp 'tex-mode))
 100       (type   . "application/x-latex"))
 101      ("x-tex"
 102       (viewer . tex-mode)
 103       (test   . (fboundp 'tex-mode))
 104       (type   . "application/x-tex"))
 105      ("latex"
 106       (viewer . tex-mode)
 107       (test   . (fboundp 'tex-mode))
 108       (type   . "application/latex"))
 109      ("tex"
 110       (viewer . tex-mode)
 111       (test   . (fboundp 'tex-mode))
 112       (type   . "application/tex"))
 113      ("texinfo"
 114       (viewer . texinfo-mode)
 115       (test   . (fboundp 'texinfo-mode))
 116       (type   . "application/tex"))
 117      ("zip"
 118       (viewer . mailcap-save-binary-file)
 119       (non-viewer . t)
 120       (type   . "application/zip")
 121       ("copiousoutput"))
 122      ;; Prefer free viewers.
 123      ("pdf"
 124       (viewer . "gv -safer %s")
 125       (type . "application/pdf")
 126       (test . window-system))
 127      ("pdf"
 128       (viewer . "xpdf %s")
 129       (type . "application/pdf")
 130       (test . (eq window-system 'x)))
 131      ("pdf"
 132       (viewer . "acroread %s")
 133       (type   . "application/pdf"))
 134 ;;; XEmacs says `ns' device-type not implemented.
 135 ;;      ("postscript"
 136 ;;       (viewer . "open %s")
 137 ;;       (type   . "application/postscript")
 138 ;;       (test   . (eq (mm-device-type) 'ns)))
 139      ("postscript"
 140       (viewer . "gv -safer %s")
 141       (type . "application/postscript")
 142       (test   . window-system)
 143       ("needsx11"))
 144      ("postscript"
 145       (viewer . "ghostview -dSAFER %s")
 146       (type . "application/postscript")
 147       (test   . (eq window-system 'x))
 148       ("needsx11"))
 149      ("postscript"
 150       (viewer . "ps2ascii %s")
 151       (type . "application/postscript")
 152       (test . (not (getenv "DISPLAY")))
 153       ("copiousoutput"))
 154      ("sieve"
 155       (viewer . sieve-mode)
 156       (test   . (fboundp 'sieve-mode))
 157       (type   . "application/sieve")))
 158     ("audio"
 159      ("x-mpeg"
 160       (viewer . "maplay %s")
 161       (type   . "audio/x-mpeg"))
 162      (".*"
 163       (viewer . "showaudio")
 164       (type   . "audio/*")))
 165     ("message"
 166      ("rfc-*822"
 167       (viewer . mm-view-message)
 168       (test   . (and (featurep 'gnus)
 169                      (gnus-alive-p)))
 170       (type   . "message/rfc822"))
 171      ("rfc-*822"
 172       (viewer . vm-mode)
 173       (test   . (fboundp 'vm-mode))
 174       (type   . "message/rfc822"))
 175      ("rfc-*822"
 176       (viewer . w3-mode)
 177       (test   . (fboundp 'w3-mode))
 178       (type   . "message/rfc822"))
 179      ("rfc-*822"
 180       (viewer . view-mode)
 181       (type   . "message/rfc822")))
 182     ("image"
 183      ("x-xwd"
 184       (viewer  . "xwud -in %s")
 185       (type    . "image/x-xwd")
 186       ("compose" . "xwd -frame > %s")
 187       (test    . (eq window-system 'x))
 188       ("needsx11"))
 189      ("x11-dump"
 190       (viewer . "xwud -in %s")
 191       (type . "image/x-xwd")
 192       ("compose" . "xwd -frame > %s")
 193       (test   . (eq window-system 'x))
 194       ("needsx11"))
 195      ("windowdump"
 196       (viewer . "xwud -in %s")
 197       (type . "image/x-xwd")
 198       ("compose" . "xwd -frame > %s")
 199       (test   . (eq window-system 'x))
 200       ("needsx11"))
 201 ;;; XEmacs says `ns' device-type not implemented.
 202 ;;      (".*"
 203 ;;       (viewer . "aopen %s")
 204 ;;       (type   . "image/*")
 205 ;;       (test   . (eq (mm-device-type) 'ns)))
 206      (".*"
 207       (viewer . "display %s")
 208       (type . "image/*")
 209       (test   . (eq window-system 'x))
 210       ("needsx11"))
 211      (".*"
 212       (viewer . "ee %s")
 213       (type . "image/*")
 214       (test   . (eq window-system 'x))
 215       ("needsx11")))
 216     ("text"
 217      ("plain"
 218       (viewer  . w3-mode)
 219       (test    . (fboundp 'w3-mode))
 220       (type    . "text/plain"))
 221      ("plain"
 222       (viewer  . view-mode)
 223       (test    . (fboundp 'view-mode))
 224       (type    . "text/plain"))
 225      ("plain"
 226       (viewer  . fundamental-mode)
 227       (type    . "text/plain"))
 228      ("enriched"
 229       (viewer . enriched-decode)
 230       (test   . (fboundp 'enriched-decode))
 231       (type   . "text/enriched"))
 232      ("html"
 233       (viewer . mm-w3-prepare-buffer)
 234       (test   . (fboundp 'w3-prepare-buffer))
 235       (type   . "text/html")))
 236     ("video"
 237      ("mpeg"
 238       (viewer . "mpeg_play %s")
 239       (type   . "video/mpeg")
 240       (test   . (eq window-system 'x))
 241       ("needsx11")))
 242     ("x-world"
 243      ("x-vrml"
 244       (viewer  . "webspace -remote %s -URL %u")
 245       (type    . "x-world/x-vrml")
 246       ("description"
 247        "VRML document")))
 248     ("archive"
 249      ("tar"
 250       (viewer . tar-mode)
 251       (type . "archive/tar")
 252       (test . (fboundp 'tar-mode)))))
 253   "The mailcap structure is an assoc list of assoc lists.
 254 1st assoc list is keyed on the major content-type
 255 2nd assoc list is keyed on the minor content-type (which can be a regexp)
 256
 257 Which looks like:
 258 -----------------
 259  ((\"application\"
 260    (\"postscript\" . <info>))
 261   (\"text\"
 262    (\"plain\" . <info>)))
 263
 264 Where <info> is another assoc list of the various information
 265 related to the mailcap RFC 1524.  This is keyed on the lowercase
 266 attribute name (viewer, test, etc).  This looks like:
 267  ((viewer . VIEWERINFO)
 268   (test   . TESTINFO)
 269   (xxxx   . \"STRING\")
 270   FLAG)
 271
 272 Where VIEWERINFO specifies how the content-type is viewed.  Can be
 273 a string, in which case it is run through a shell, with
 274 appropriate parameters, or a symbol, in which case the symbol is
 275 `funcall'ed, with the buffer as an argument.
 276
 277 TESTINFO is a test for the viewer's applicability, or nil.  If nil, it
 278 means the viewer is always valid.  If it is a Lisp function, it is
 279 called with a list of items from any extra fields from the
 280 Content-Type header as argument to return a boolean value for the
 281 validity.  Otherwise, if it is a non-function Lisp symbol or list
 282 whose car is a symbol, it is `eval'led to yield the validity.  If it
 283 is a string or list of strings, it represents a shell command to run
 284 to return a true or false shell value for the validity.")
 285
 286 (defcustom mailcap-download-directory nil
 287   "*Directory to which `mailcap-save-binary-file' downloads files by default.
 288 nil means your home directory."
 289   :type '(choice (const :tag "Home directory" nil)
 290                  directory)
 291   :group 'mailcap)
 292
 293 (defvar mailcap-poor-system-types
 294   '(ms-dos ms-windows windows-nt win32 w32 mswindows)
 295   "Systems that don't have a Unix-like directory hierarchy.")
 296
 297 ;;;
 298 ;;; Utility functions
 299 ;;;
 300
 301 (defun mailcap-save-binary-file ()
 302   (goto-char (point-min))
 303   (unwind-protect
 304       (let ((file (read-file-name
 305                    "Filename to save as: "
 306                    (or mailcap-download-directory "~/")))
 307             (require-final-newline nil))
 308         (write-region (point-min) (point-max) file))
 309     (kill-buffer (current-buffer))))
 310
 311 (defvar mailcap-maybe-eval-warning
 312   "*** WARNING ***
 313
 314 This MIME part contains untrusted and possibly harmful content.
 315 If you evaluate the Emacs Lisp code contained in it, a lot of nasty
 316 things can happen.  Please examine the code very carefully before you
 317 instruct Emacs to evaluate it.  You can browse the buffer containing
 318 the code using \\[scroll-other-window].
 319
 320 If you are unsure what to do, please answer \"no\"."
 321   "Text of warning message displayed by `mailcap-maybe-eval'.
 322 Make sure that this text consists only of few text lines.  Otherwise,
 323 Gnus might fail to display all of it.")
 324
 325 (defun mailcap-maybe-eval ()
 326   "Maybe evaluate a buffer of Emacs Lisp code."
 327   (let ((lisp-buffer (current-buffer)))
 328     (goto-char (point-min))
 329     (when
 330         (save-window-excursion
 331           (delete-other-windows)
 332           (let ((buffer (get-buffer-create (generate-new-buffer-name
 333                                             "*Warning*"))))
 334             (unwind-protect
 335                 (with-current-buffer buffer
 336                   (insert (substitute-command-keys
 337                            mailcap-maybe-eval-warning))
 338                   (goto-char (point-min))
 339                   (display-buffer buffer)
 340                   (yes-or-no-p "This is potentially dangerous emacs-lisp code, evaluate it? "))
 341               (kill-buffer buffer))))
 342       (eval-buffer (current-buffer)))
 343     (when (buffer-live-p lisp-buffer)
 344       (with-current-buffer lisp-buffer
 345         (emacs-lisp-mode)))))
 346
 347
 348 ;;;
 349 ;;; The mailcap parser
 350 ;;;
 351
 352 (defun mailcap-replace-regexp (regexp to-string)
 353   ;; Quiet replace-regexp.
 354   (goto-char (point-min))
 355   (while (re-search-forward regexp nil t)
 356     (replace-match to-string t nil)))
 357
 358 (defvar mailcap-parsed-p nil)
 359
 360 (defun mailcap-parse-mailcaps (&optional path force)
 361   "Parse out all the mailcaps specified in a path string PATH.
 362 Components of PATH are separated by the `path-separator' character
 363 appropriate for this system.  If FORCE, re-parse even if already
 364 parsed.  If PATH is omitted, use the value of environment variable
 365 MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus
 366 /usr/local/etc/mailcap."
 367   (interactive (list nil t))
 368   (when (or (not mailcap-parsed-p)
 369             force)
 370     (cond
 371      (path nil)
 372      ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS")))
 373      ((memq system-type mailcap-poor-system-types)
 374       (setq path '("~/.mailcap" "~/mail.cap" "~/etc/mail.cap")))
 375      (t (setq path
 376               ;; This is per RFC 1524, specifically
 377               ;; with /usr before /usr/local.
 378               '("~/.mailcap" "/etc/mailcap" "/usr/etc/mailcap"
 379                 "/usr/local/etc/mailcap"))))
 380     (let ((fnames (reverse
 381                    (if (stringp path)
 382                        (delete "" (split-string path path-separator))
 383                      path)))
 384           fname)
 385       (while fnames
 386         (setq fname (car fnames))
 387         (if (and (file-readable-p fname)
 388                  (file-regular-p fname))
 389             (mailcap-parse-mailcap fname))
 390         (setq fnames (cdr fnames))))
 391       (setq mailcap-parsed-p t)))
 392
 393 (defun mailcap-parse-mailcap (fname)
 394   "Parse out the mailcap file specified by FNAME."
 395   (let (major                           ; The major mime type (image/audio/etc)
 396         minor                           ; The minor mime type (gif, basic, etc)
 397         save-pos                        ; Misc saved positions used in parsing
 398         viewer                          ; How to view this mime type
 399         info                            ; Misc info about this mime type
 400         )
 401     (with-temp-buffer
 402       (insert-file-contents fname)
 403       (set-syntax-table mailcap-parse-args-syntax-table)
 404       (mailcap-replace-regexp "#.*" "") ; Remove all comments
 405       (mailcap-replace-regexp "\\\\[ \t]*\n" " ") ; And collapse spaces
 406       (mailcap-replace-regexp "\n+" "\n") ; And blank lines
 407       (goto-char (point-max))
 408       (skip-chars-backward " \t\n")
 409       (delete-region (point) (point-max))
 410       (while (not (bobp))
 411         (skip-chars-backward " \t\n")
 412         (beginning-of-line)
 413         (setq save-pos (point)
 414               info nil)
 415         (skip-chars-forward "^/; \t\n")
 416         (downcase-region save-pos (point))
 417         (setq major (buffer-substring save-pos (point)))
 418         (skip-chars-forward " \t")
 419         (setq minor "")
 420         (when (eq (char-after) ?/)
 421           (forward-char)
 422           (skip-chars-forward " \t")
 423           (setq save-pos (point))
 424           (skip-chars-forward "^; \t\n")
 425           (downcase-region save-pos (point))
 426           (setq minor
 427                 (cond
 428                  ((eq ?* (or (char-after save-pos) 0)) ".*")
 429                  ((= (point) save-pos) ".*")
 430                  (t (regexp-quote (buffer-substring save-pos (point)))))))
 431         (skip-chars-forward " \t")
 432         ;;; Got the major/minor chunks, now for the viewers/etc
 433         ;;; The first item _must_ be a viewer, according to the
 434         ;;; RFC for mailcap files (#1524)
 435         (setq viewer "")
 436         (when (eq (char-after) ?\;)
 437           (forward-char)
 438           (skip-chars-forward " \t")
 439           (setq save-pos (point))
 440           (skip-chars-forward "^;\n")
 441           ;; skip \;
 442           (while (eq (char-before) ?\\)
 443             (backward-delete-char 1)
 444 &n