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

   1 ;;; mailcap.el --- Functions for displaying MIME parts
   2 ;; Copyright (C) 1998 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-and-compile
  30   (require 'cl))
  31 (require 'mail-parse)
  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       (type ."application/octet-stream"))
  55      ("dvi"
  56       (viewer . "open %s")
  57       (type   . "application/dvi")
  58       (test   . (eq (mm-device-type) 'ns)))
  59      ("dvi"
  60       (viewer . "xdvi %s")
  61       (test   . (eq (mm-device-type) 'x))
  62       ("needsx11")
  63       (type   . "application/dvi"))
  64      ("dvi"
  65       (viewer . "dvitty %s")
  66       (test   . (not (getenv "DISPLAY")))
  67       (type   . "application/dvi"))
  68      ("emacs-lisp"
  69       (viewer . mailcap-maybe-eval)
  70       (type   . "application/emacs-lisp"))
  71      ("x-tar"
  72       (viewer . mailcap-save-binary-file)
  73       (type   . "application/x-tar"))
  74      ("x-latex"
  75       (viewer . tex-mode)
  76       (test   . (fboundp 'tex-mode))
  77       (type   . "application/x-latex"))
  78      ("x-tex"
  79       (viewer . tex-mode)
  80       (test   . (fboundp 'tex-mode))
  81       (type   . "application/x-tex"))
  82      ("latex"
  83       (viewer . tex-mode)
  84       (test   . (fboundp 'tex-mode))
  85       (type   . "application/latex"))
  86      ("tex"
  87       (viewer . tex-mode)
  88       (test   . (fboundp 'tex-mode))
  89       (type   . "application/tex"))
  90      ("texinfo"
  91       (viewer . texinfo-mode)
  92       (test   . (fboundp 'texinfo-mode))
  93       (type   . "application/tex"))
  94      ("zip"
  95       (viewer . mailcap-save-binary-file)
  96       (type   . "application/zip")
  97       ("copiousoutput"))
  98      ("pdf"
  99       (viewer . "acroread %s")
 100       (type   . "application/pdf"))
 101      ("postscript"
 102       (viewer . "open %s")
 103       (type   . "application/postscript")
 104       (test   . (eq (mm-device-type) 'ns)))
 105      ("postscript"
 106       (viewer . "ghostview %s")
 107       (type . "application/postscript")
 108       (test   . (eq (mm-device-type) 'x))
 109       ("needsx11"))
 110      ("postscript"
 111       (viewer . "ps2ascii %s")
 112       (type . "application/postscript")
 113       (test . (not (getenv "DISPLAY")))
 114       ("copiousoutput")))
 115     ("audio"
 116      ("x-mpeg"
 117       (viewer . "maplay %s")
 118       (type   . "audio/x-mpeg"))
 119      (".*"
 120       (viewer . mm-view-sound-file)
 121       (test   . (or (featurep 'nas-sound)
 122                       (featurep 'native-sound)))
 123       (type   . "audio/*"))
 124      (".*"
 125       (viewer . "showaudio")
 126       (type   . "audio/*")))
 127     ("message"
 128      ("rfc-*822"
 129       (viewer . vm-mode)
 130       (test   . (fboundp 'vm-mode))
 131       (type   . "message/rfc-822"))
 132      ("rfc-*822"
 133       (viewer . w3-mode)
 134       (test   . (fboundp 'w3-mode))
 135       (type   . "message/rfc-822"))
 136      ("rfc-*822"
 137       (viewer . view-mode)
 138       (test   . (fboundp 'view-mode))
 139       (type   . "message/rfc-822"))
 140      ("rfc-*822"
 141       (viewer . fundamental-mode)
 142       (type   . "message/rfc-822")))
 143     ("image"
 144      ("x-xwd"
 145       (viewer  . "xwud -in %s")
 146       (type    . "image/x-xwd")
 147       ("compose" . "xwd -frame > %s")
 148       (test    . (eq (mm-device-type) 'x))
 149       ("needsx11"))
 150      ("x11-dump"
 151       (viewer . "xwud -in %s")
 152       (type . "image/x-xwd")
 153       ("compose" . "xwd -frame > %s")
 154       (test   . (eq (mm-device-type) 'x))
 155       ("needsx11"))
 156      ("windowdump"
 157       (viewer . "xwud -in %s")
 158       (type . "image/x-xwd")
 159       ("compose" . "xwd -frame > %s")
 160       (test   . (eq (mm-device-type) 'x))
 161       ("needsx11"))
 162      (".*"
 163       (viewer . "aopen %s")
 164       (type   . "image/*")
 165       (test   . (eq (mm-device-type) 'ns)))
 166      (".*"
 167       (viewer . "xv -perfect %s")
 168       (type . "image/*")
 169       (test   . (eq (mm-device-type) 'x))
 170       ("needsx11")))
 171     ("text"
 172      ("plain"
 173       (viewer  . w3-mode)
 174       (test    . (fboundp 'w3-mode))
 175       (type    . "text/plain"))
 176      ("plain"
 177       (viewer  . view-mode)
 178       (test    . (fboundp 'view-mode))
 179       (type    . "text/plain"))
 180      ("plain"
 181       (viewer  . fundamental-mode)
 182       (type    . "text/plain"))
 183      ("enriched"
 184       (viewer . enriched-decode-region)
 185       (test   . (fboundp 'enriched-decode-region))
 186       (type   . "text/enriched"))
 187      ("html"
 188       (viewer . mm-w3-prepare-buffer)
 189       (test   . (fboundp 'w3-prepare-buffer))
 190       (type   . "text/html")))
 191     ("video"
 192      ("mpeg"
 193       (viewer . "mpeg_play %s")
 194       (type   . "video/mpeg")
 195       (test   . (eq (mm-device-type) 'x))
 196       ("needsx11")))
 197     ("x-world"
 198      ("x-vrml"
 199       (viewer  . "webspace -remote %s -URL %u")
 200       (type    . "x-world/x-vrml")
 201       ("description"
 202        "VRML document")))
 203     ("archive"
 204      ("tar"
 205       (viewer . tar-mode)
 206       (type . "archive/tar")
 207       (test . (fboundp 'tar-mode)))))
 208      "*The mailcap structure is an assoc list of assoc lists.
 209 1st assoc list is keyed on the major content-type
 210 2nd assoc list is keyed on the minor content-type (which can be a regexp)
 211
 212 Which looks like:
 213 -----------------
 214  ((\"application\"
 215    (\"postscript\" . <info>))
 216   (\"text\"
 217    (\"plain\" . <info>)))
 218
 219 Where <info> is another assoc list of the various information
 220 related to the mailcap RFC.  This is keyed on the lowercase
 221 attribute name (viewer, test, etc).  This looks like:
 222  ((viewer . viewerinfo)
 223   (test   . testinfo)
 224   (xxxx   . \"string\"))
 225
 226 Where viewerinfo specifies how the content-type is viewed.  Can be
 227 a string, in which case it is run through a shell, with
 228 appropriate parameters, or a symbol, in which case the symbol is
 229 funcall'd, with the buffer as an argument.
 230
 231 testinfo is a list of strings, or nil.  If nil, it means the
 232 viewer specified is always valid.  If it is a list of strings,
 233 these are used to determine whether a viewer passes the 'test' or
 234 not.")
 235
 236 (defvar mailcap-download-directory nil
 237   "*Where downloaded files should go by default.")
 238
 239 (defvar mailcap-temporary-directory (or (getenv "TMPDIR") "/tmp")
 240   "*Where temporary files go.")
 241
 242 ;;;
 243 ;;; Utility functions
 244 ;;;
 245
 246 (defun mailcap-generate-unique-filename (&optional fmt)
 247   "Generate a unique filename in mailcap-temporary-directory"
 248   (if (not fmt)
 249       (let ((base (format "mailcap-tmp.%d" (user-real-uid)))
 250             (fname "")
 251             (x 0))
 252         (setq fname (format "%s%d" base x))
 253         (while (file-exists-p
 254                 (expand-file-name fname mailcap-temporary-directory))
 255           (setq x (1+ x)
 256                 fname (concat base (int-to-string x))))
 257         (expand-file-name fname mailcap-temporary-directory))
 258     (let ((base (concat "mm" (int-to-string (user-real-uid))))
 259           (fname "")
 260           (x 0))
 261       (setq fname (format fmt (concat base (int-to-string x))))
 262       (while (file-exists-p
 263               (expand-file-name fname mailcap-temporary-directory))
 264         (setq x (1+ x)
 265               fname (format fmt (concat base (int-to-string x)))))
 266       (expand-file-name fname mailcap-temporary-directory))))
 267
 268 (defun mailcap-save-binary-file ()
 269   (let ((file (read-file-name
 270                "Filename to save as: "
 271                (or mailcap-download-directory "~/")))
 272         (require-final-newline nil))
 273     (write-region (point-min) (point-max) file)
 274     (kill-buffer (current-buffer))))
 275
 276 (defun mailcap-maybe-eval ()
 277   "Maybe evaluate a buffer of emacs lisp code"
 278   (if (yes-or-no-p "This is emacs-lisp code, evaluate it? ")
 279       (eval-buffer (current-buffer))
 280     (emacs-lisp-mode)))
 281
 282 ;;;
 283 ;;; The mailcap parser
 284 ;;;
 285
 286 (defun mailcap-replace-regexp (regexp to-string)
 287   ;; Quiet replace-regexp.
 288   (goto-char (point-min))
 289   (while (re-search-forward regexp nil t)
 290     (replace-match to-string t nil)))
 291
 292 (defvar mailcap-parsed-p nil)
 293
 294 (defun mailcap-parse-mailcaps (&optional path force)
 295   "Parse out all the mailcaps specified in a unix-style path string PATH.
 296 If FORCE, re-parse even if already parsed."
 297   (when (or (not mailcap-parsed-p)
 298             force)
 299     (cond
 300      (path nil)
 301      ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS")))
 302      ((memq system-type '(ms-dos ms-windows windows-nt))
 303       (setq path (mapconcat 'expand-file-name '("~/mail.cap" "~/etc/mail.cap")
 304                             ";")))
 305      (t (setq path (mapconcat 'expand-file-name
 306                               '("~/.mailcap"
 307                                 "/etc/mailcap:/usr/etc/mailcap"
 308                                 "/usr/local/etc/mailcap") ":"))))
 309     (let ((fnames (reverse
 310                    (split-string
 311                     path (if (memq system-type
 312                                    '(ms-dos ms-windows windows-nt))
 313                              ";"
 314                            ":"))))
 315           fname)
 316       (while fnames
 317         (setq fname (car fnames))
 318         (if (and (file-exists-p fname) (file-readable-p fname))
 319             (mailcap-parse-mailcap (car fnames)))
 320         (setq fnames (cdr fnames))))
 321     (setq mailcap-parsed-p t)))
 322
 323 (defun mailcap-parse-mailcap (fname)
 324   ;; Parse out the mailcap file specified by FNAME
 325   (let (major                           ; The major mime type (image/audio/etc)
 326         minor                           ; The minor mime type (gif, basic, etc)
 327         save-pos                        ; Misc saved positions used in parsing
 328         viewer                          ; How to view this mime type
 329         info                            ; Misc info about this mime type
 330         )
 331     (with-temp-buffer
 332       (insert-file-contents fname)
 333       (set-syntax-table mailcap-parse-args-syntax-table)
 334       (mailcap-replace-regexp "#.*" "") ; Remove all comments
 335       (mailcap-replace-regexp "\n+" "\n") ; And blank lines
 336       (mailcap-replace-regexp "\\\\[ \t\n]+" " ") ; And collapse spaces
 337       (mailcap-replace-regexp (concat (regexp-quote "\\") "[ \t]*\n") "")
 338       (goto-char (point-max))
 339       (skip-chars-backward " \t\n")
 340       (delete-region (point) (point-max))
 341       (goto-char (point-min))
 342       (while (not (eobp))
 343         (skip-chars-forward " \t\n")
 344         (setq save-pos (point)
 345               info nil)
 346         (skip-chars-forward "^/;")
 347         (downcase-region save-pos (point))
 348         (setq major (buffer-substring save-pos (point)))
 349         (skip-chars-forward "/ \t\n")
 350         (setq save-pos (point))
 351         (skip-chars-forward "^;")
 352         (downcase-region save-pos (point))
 353         (setq minor
 354               (cond
 355                ((= ?* (or (char-after save-pos) 0)) ".*")
 356                ((= (point) save-pos) ".*")
 357                (t (buffer-substring save-pos (point)))))
 358         (skip-chars-forward "; \t\n")
 359         ;;; Got the major/minor chunks, now for the viewers/etc
 360         ;;; The first item _must_ be a viewer, according to the
 361         ;;; RFC for mailcap files (#1343)
 362         (skip-chars-forward "; \t\n")
 363         (setq save-pos (point))
 364         (skip-chars-forward "^;\n")
 365         (if (= (or (char-after save-pos) 0) ?')
 366             (setq viewer (progn
 367                            (narrow-to-region (1+ save-pos) (point))
 368                            (goto-char (point-min))
 369                            (prog1
 370                                (read (current-buffer))
 371                              (goto-char (point-max))
 372                              (widen))))
 373           (setq viewer (buffer-substring save-pos (point))))
 374         (setq save-pos (point))
 375         (end-of-line)
 376         (setq info (nconc (list (cons 'viewer viewer)
 377                                 (cons 'type (concat major "/"
 378                                                     (if (string= minor ".*")
 379                                                         "*" minor))))
 380                           (mailcap-parse-mailcap-extras save-pos (point))))
 381         (mailcap-mailcap-entry-passes-test info)
 382         (mailcap-add-mailcap-entry major minor info)))))
 383
 384 (defun mailcap-parse-mailcap-extras (st nd)
 385   ;; Grab all the extra stuff from a mailcap entry
 386   (let (
 387         name                            ; From name=
 388         value                           ; its value
 389         results                         ; Assoc list of results
 390         name-pos                        ; Start of XXXX= position
 391         val-pos                         ; Start of value position
 392         done                            ; Found end of \'d ;s?
 393         )
 394     (save-restriction
 395       (narrow-to-region st nd)
 396       (goto-char (point-min))
 397       (skip-chars-forward " \n\t;")
 398       (while (not (eobp))
 399         (setq done nil)
 400         (skip-chars-forward " \";\n\t")
 401         (setq name-pos (point))
 402         (skip-chars-forward "^ \n\t=")
 403         (downcase-region name-pos (point))
 404         (setq name (buffer-substring name-pos (point)))
 405         (skip-chars-forward " \t\n")
 406         (if (/= (or (char-after (point)) 0)  ?=) ; There is no value
 407             (setq value nil)
 408           (skip-chars-forward " \t\n=")
 409           (setq val-pos (point))
 410           (if (memq (char-after val-pos) '(?\" ?'))
 411               (progn
 412                 (setq val-pos (1+ val-pos))
 413                 (condition-case nil
 414                     (progn
 415                       (forward-sexp 1)
 416                       (backward-char 1))
 417                   (error (goto-char (point-max)))))
 418             (while (not done)
 419               (skip-chars-forward "^;")
 420               (if (= (or (char-after (1- (point))) 0) ?\\ )
 421                   (progn
 422                     (subst-char-in-region (1- (point)) (point) ?\\ ? )
 423                     (skip-chars-forward ";"))
 424                 (setq done t))))
 425           (setq value (buffer-substring val-pos (point))))
 426         (setq results (cons (cons name value) results)))
 427       results)))
 428
 429 (defun mailcap-mailcap-entry-passes-test (info)
 430   ;; Return t iff a mailcap entry passes its test clause or no test
 431   ;; clause is present.
 432   (let (status                          ; Call-process-regions return value
 433         (test (assq 'test info))        ; The test clause
 434         )
 435     (setq status (and test (split-string (cdr test) " ")))
 436     (if (and (assoc "needsx11" info) (not (getenv "DISPLAY")))
 437         (setq status nil)
 438       (cond
 439        ((and (equal (nth 0 status) "test")
 440              (equal (nth 1 status) "-n")
 441              (or (equal (nth 2 status) "$DISPLAY")
 442                  (equal (nth 2 status) "\"$DISPLAY\"")))
 443         (setq status (if (getenv "DISPLAY") t nil)))
 444        ((and (equal (nth 0 status) "test")
 445              (equal (nth 1 status) "-z")
 446              (or (equal (nth 2 status) "$DISPLAY")
 447                  (equal (nth 2 status) "\"$DISPLAY\"")))
 448         (setq status (if (getenv "DISPLAY") nil t)))
 449        (test nil)
 450        (t nil)))
 451     (and test (listp test) (setcdr test status))))
 452
 453 ;;;
 454 ;;; The action routines.
 455 ;;;
 456
 457 (defun mailcap-possible-viewers (major minor)
 458   ;; Return a list of possible viewers from MAJOR for minor type MINOR
 459   (let ((exact '())
 460         (wildcard '()))
 461     (while major
 462       (cond
 463        ((equal (car (car major)) minor)
 464         (setq exact (cons (cdr (car major)) exact)))
 465        ((string-match (car (car major)) minor)
 466         (setq wildcard (cons (cdr (car major)) wildcard))))
 467       (setq major (cdr major)))
 468     (nconc (nreverse exact) (nreverse wildcard))))
 469
 470 (defun mailcap-unescape-mime-test (test type-info)
 471   (let (save-pos save-chr subst)
 472     (cond
 473      ((symbolp test) test)
 474      ((and (listp test) (symbolp (car test))) test)
 475      ((or (stringp test)
 476           (and (listp test) (stringp (car test))
 477                (setq test (mapconcat 'identity test " "))))
 478       (with-temp-buffer
 479         (insert test)
 480         (goto-char (point-min))
 481         (while (not (eobp))
 482           (skip-chars-forward "^%")
 483           (if (/= (- (point)
 484                      (progn (skip-chars-backward "\\\\")
 485                             (point)))
 486                   0)                    ; It is an escaped %
 487               (progn
 488                 (delete-char 1)
 489                 (skip-chars-forward "%."))
 490             (setq save-pos (point))
 491             (skip-chars-forward "%")
 492             (setq save-chr (char-after (point)))
 493             (cond
 494              ((null save-chr) nil)
 495              ((= save-chr ?t)
 496               (delete-region save-pos (progn (forward-char 1) (point)))
 497               (insert (or (cdr (assq 'type type-info)) "\"\"")))
 498              ((= save-chr ?M)
 499               (delete-region save-pos (progn (forward-char 1) (point)))
 500               (insert "\"\""))
 501              ((= save-chr ?n)
 502               (delete-region save-pos (progn (forward-char 1) (point)))
 503               (insert "\"\""))
 504              ((= save-chr ?F)
 505               (delete-region save-pos (progn (forward-char 1) (point)))
 506               (insert "\"\""))
 507              ((= save-chr ?{)
 508               (forward-char 1)
 509               (skip-chars-forward "^}")
 510               (downcase-region (+ 2 save-pos) (point))
 511               (setq subst (buffer-substring (+ 2 save-pos) (point)))
 512               (delete-region save-pos (1+ (point)))
 513               (insert (or (cdr (assoc subst type-info)) "\"\"")))
 514              (t nil))))
 515         (buffer-string)))
 516      (t (error "Bad value to mailcap-unescape-mime-test. %s" test)))))
 517
 518 (defvar mailcap-viewer-test-cache nil)
 519
 520 (defun mailcap-viewer-passes-test (viewer-info type-info)
 521   ;; Return non-nil iff the viewer specified by VIEWER-INFO passes its
 522   ;; test clause (if any).
 523   (let* ((test-info (assq 'test viewer-info))
 524          (test (cdr test-info))
 525          (otest test)
 526          (viewer (cdr (assoc 'viewer viewer-info)))
 527          (default-directory (expand-file-name "~/"))
 528          status parsed-test cache result)
 529     (if (setq cache (assoc test mailcap-viewer-test-cache))
 530         (cadr cache)
 531       (setq
 532        result
 533        (cond
 534         ((not test-info) t)             ; No test clause
 535         ((not test) nil)                ; Already failed test
 536         ((eq test t) t)                 ; Already passed test
 537         ((and (symbolp test)            ; Lisp function as test
 538               (fboundp test))
 539          (funcall test type-info))
 540         ((and (symbolp test)            ; Lisp variable as test
 541               (boundp test))
 542          (symbol-value test))
 543         ((and (listp test)              ; List to be eval'd
 544               (symbolp (car test)))
 545          (eval test))
 546         (t
 547          (setq test (mailcap-unescape-mime-test test type-info)
 548                test (list shell-file-name nil nil nil
 549                           shell-command-switch test)
 550                status (apply 'call-process test))
 551          (= 0 status))))
 552       (push (list otest result) mailcap-viewer-test-cache)
 553       result)))
 554
 555 (defun mailcap-add-mailcap-entry (major minor info)
 556   (let ((old-major (assoc major mailcap-mime-data)))
 557     (if (null old-major)                ; New major area
 558         (setq mailcap-mime-data
 559               (cons (cons major (list (cons minor info)))
 560                     mailcap-mime-data))
 561       (let ((cur-minor (assoc minor old-major)))
 562         (cond
 563          ((or (null cur-minor)          ; New minor area, or
 564               (assq 'test info))        ; Has a test, insert at beginning
 565           (setcdr old-major (cons (cons minor info) (cdr old-major))))
 566          ((and (not (assq 'test info)) ; No test info, replace completely
 567                (not (assq 'test cur-minor)))
 568           (setcdr cur-minor info))
 569          (t
 570           (setcdr old-major (cons (cons minor info) (cdr old-major)))))))))
 571
 572 ;;;
 573 ;;; The main whabbo
 574 ;;;
 575
 576 (defun mailcap-viewer-lessp (x y)
 577   ;; Return t iff viewer X is more desirable than viewer Y
 578   (let ((x-wild (string-match "[*?]" (or (cdr-safe (assq 'type x)) "")))
 579         (y-wild (string-match "[*?]" (or (cdr-safe (assq 'type y)) "")))
 580         (x-lisp (not (stringp (or (cdr-safe (assq 'viewer x)) ""))))
 581         (y-lisp (not (stringp (or (cdr-safe (assq 'viewer y)) "")))))
 582     (cond
 583      ((and x-lisp (not y-lisp))
 584       t)
 585      ((and (not y-lisp) x-wild (not y-wild))
 586       t)
 587      ((and (not x-wild) y-wild)
 588       t)
 589      (t nil))))
 590
 591 (defun mailcap-mime-info (string &optional request)
 592   "Get the MIME viewer command for STRING, return nil if none found.
 593 Expects a complete content-type header line as its argument.
 594
 595 Second argument REQUEST specifies what information to return.  If it is
 596 nil or the empty string, the viewer (second field of the mailcap
 597 entry) will be returned.  If it is a string, then the mailcap field
 598 corresponding to that string will be returned (print, description,
 599 whatever).  If a number, then all the information for this specific
 600 viewer is returned.  If `all', then all possible viewers for
 601 this type is returned."
 602   (let (
 603         major                           ; Major encoding (text, etc)
 604         minor                           ; Minor encoding (html, etc)
 605         info                            ; Other info
 606         save-pos                        ; Misc. position during parse
 607         major-info                      ; (assoc major mailcap-mime-data)
 608         minor-info                      ; (assoc minor major-info)
 609         test                            ; current test proc.
 610         viewers                         ; Possible viewers
 611         passed                          ; Viewers that passed the test
 612         viewer                          ; The one and only viewer
 613         ctl)
 614     (save-excursion
 615       (setq ctl (mail-header-parse-content-type (or string "text/plain")))
 616       (setq major (split-string (car ctl) "/"))
 617       (setq minor (cadr major)
 618             major (car major))
 619       (when (setq major-info (cdr (assoc major mailcap-mime-data)))
 620         (when (setq viewers (mailcap-possible-viewers major-info minor))
 621           (setq info (mapcar (lambda (a) (cons (symbol-name (car a))
 622                                                (cdr a)))
 623                              (cdr ctl)))
 624           (while viewers
 625             (if (mailcap-viewer-passes-test (car viewers) info)
 626                 (setq passed (cons (car viewers) passed)))
 627             (setq viewers (cdr viewers)))
 628           (setq passed (sort (nreverse passed) 'mailcap-viewer-lessp))
 629           (setq viewer (car passed))))
 630       (when (and (stringp (cdr (assq 'viewer viewer)))
 631                  passed)
 632         (setq viewer (car passed)))
 633       (cond
 634        ((and (null viewer) (not (equal major "default")) request)
 635         (mailcap-mime-info "default" request))
 636        ((or (null request) (equal request ""))
 637         (mailcap-unescape-mime-test (cdr (assq 'viewer viewer)) info))
 638        ((stringp request)
 639         (if (or (eq request 'test) (eq request 'viewer))
 640             (mailcap-unescape-mime-test
 641              (cdr-safe (assoc request viewer)) info)))
 642        ((eq request 'all)
 643         passed)
 644        (t
 645         ;; MUST make a copy *sigh*, else we modify mailcap-mime-data
 646         (setq viewer (copy-tree viewer))
 647         (let ((view (assq 'viewer viewer))
 648               (test (assq 'test viewer)))
 649           (if view (setcdr view (mailcap-unescape-mime-test (cdr view) info)))
 650           (if test (setcdr test (mailcap-unescape-mime-test (cdr test) info))))
 651         viewer)))))
 652
 653 ;;;
 654 ;;; Experimental MIME-types parsing
 655 ;;;
 656
 657 (defvar mailcap-mime-extensions
 658   '((""          . "text/plain")
 659     (".abs"      . "audio/x-mpeg")
 660     (".aif"      . "audio/aiff")
 661     (".aifc"     . "audio/aiff")
 662     (".aiff"     . "audio/aiff")
 663     (".ano"      . "application/x-annotator")
 664     (".au"       . "audio/ulaw")
 665     (".avi"      . "video/x-msvideo")
 666     (".bcpio"    . "application/x-bcpio")
 667     (".bin"      . "application/octet-stream")
 668     (".cdf"      . "application/x-netcdr")
 669     (".cpio"     . "application/x-cpio")
 670     (".csh"      . "application/x-csh")
 671     (".dvi"      . "application/x-dvi")
 672     (".el"       . "application/emacs-lisp")
 673     (".eps"      . "application/postscript")
 674     (".etx"      . "text/x-setext")
 675     (".exe"      . "application/octet-stream")
 676     (".fax"      . "image/x-fax")
 677     (".gif"      . "image/gif")
 678     (".hdf"      . "application/x-hdf")
 679     (".hqx"      . "application/mac-binhex40")
 680     (".htm"      . "text/html")
 681     (".html"     . "text/html")
 682     (".icon"     . "image/x-icon")
 683     (".ief"      . "image/ief")
 684     (".jpg"      . "image/jpeg")
 685     (".macp"     . "image/x-macpaint")
 686     (".man"      . "application/x-troff-man")
 687     (".me"       . "application/x-troff-me")
 688     (".mif"      . "application/mif")
 689     (".mov"      . "video/quicktime")
 690     (".movie"    . "video/x-sgi-movie")
 691     (".mp2"      . "audio/x-mpeg")
 692     (".mp3"      . "audio/x-mpeg")
 693     (".mp2a"     . "audio/x-mpeg2")
 694     (".mpa"      . "audio/x-mpeg")
 695     (".mpa2"     . "audio/x-mpeg2")
 696     (".mpe"      . "video/mpeg")
 697     (".mpeg"     . "video/mpeg")
 698     (".mpega"    . "audio/x-mpeg")
 699     (".mpegv"    . "video/mpeg")
 700     (".mpg"      . "video/mpeg")
 701     (".mpv"      . "video/mpeg")
 702     (".ms"       . "application/x-troff-ms")
 703     (".nc"       . "application/x-netcdf")
 704     (".nc"       . "application/x-netcdf")
 705     (".oda"      . "application/oda")
 706     (".pbm"      . "image/x-portable-bitmap")
 707     (".pdf"      . "application/pdf")
 708     (".pgm"      . "image/portable-graymap")
 709     (".pict"     . "image/pict")
 710     (".png"      . "image/png")
 711     (".pnm"      . "image/x-portable-anymap")
 712     (".ppm"      . "image/portable-pixmap")
 713     (".ps"       . "application/postscript")
 714     (".qt"       . "video/quicktime")
 715     (".ras"      . "image/x-raster")
 716     (".rgb"      . "image/x-rgb")
 717     (".rtf"      . "application/rtf")
 718     (".rtx"      . "text/richtext")
 719     (".sh"       . "application/x-sh")
 720     (".sit"      . "application/x-stuffit")
 721     (".snd"      . "audio/basic")
 722     (".src"      . "application/x-wais-source")
 723     (".tar"      . "archive/tar")
 724     (".tcl"      . "application/x-tcl")
 725     (".tcl"      . "application/x-tcl")
 726     (".tex"      . "application/x-tex")
 727     (".texi"     . "application/texinfo")
 728     (".tga"      . "image/x-targa")
 729     (".tif"      . "image/tiff")
 730     (".tiff"     . "image/tiff")
 731     (".tr"       . "application/x-troff")
 732     (".troff"    . "application/x-troff")
 733     (".tsv"      . "text/tab-separated-values")
 734     (".txt"      . "text/plain")
 735     (".vbs"      . "video/mpeg")
 736     (".vox"      . "audio/basic")
 737     (".vrml"     . "x-world/x-vrml")
 738     (".wav"      . "audio/x-wav")
 739     (".wrl"      . "x-world/x-vrml")
 740     (".xbm"      . "image/xbm")
 741     (".xpm"      . "image/x-pixmap")
 742     (".xwd"      . "image/windowdump")
 743     (".zip"      . "application/zip")
 744     (".ai"       . "application/postscript")
 745     (".jpe"      . "image/jpeg")
 746     (".jpeg"     . "image/jpeg"))
 747   "*An assoc list of file extensions and the MIME content-types they
 748 correspond to.")
 749
 750 (defun mailcap-parse-mimetypes (&optional path)
 751   ;; Parse out all the mimetypes specified in a unix-style path string PATH
 752   (cond
 753    (path nil)
 754    ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES")))
 755    ((memq system-type '(ms-dos ms-windows windows-nt))
 756     (setq path (mapconcat 'expand-file-name
 757                           '("~/mime.typ" "~/etc/mime.typ") ";")))
 758    (t (setq path (mapconcat 'expand-file-name
 759                             '("~/.mime-types"
 760                               "/etc/mime-types:/usr/etc/mime-types"
 761                               "/usr/local/etc/mime-types"
 762                               "/usr/local/www/conf/mime-types") ":"))))
 763   (let ((fnames (reverse
 764                  (split-string path
 765                                (if (memq system-type
 766                                          '(ms-dos ms-windows windows-nt))
 767                                    ";" ":"))))
 768         fname)
 769     (while fnames
 770       (setq fname (car fnames))
 771       (if (and (file-exists-p fname) (file-readable-p fname))
 772           (mailcap-parse-mimetype-file (car fnames)))
 773       (setq fnames (cdr fnames)))))
 774
 775 (defun mailcap-parse-mimetype-file (fname)
 776   ;; Parse out a mime-types file
 777   (let (type                            ; The MIME type for this line
 778         extns                           ; The extensions for this line
 779         save-pos                        ; Misc. saved buffer positions
 780         )
 781     (with-temp-buffer
 782       (insert-file-contents fname)
 783       (mailcap-replace-regexp "#.*" "")
 784       (mailcap-replace-regexp "\n+" "\n")
 785       (mailcap-replace-regexp "[ \t]+$" "")
 786       (goto-char (point-max))
 787       (skip-chars-backward " \t\n")
 788       (delete-region (point) (point-max))
 789       (goto-char (point-min))
 790       (while (not (eobp))
 791         (skip-chars-forward " \t\n")
 792         (setq save-pos (point))
 793         (skip-chars-forward "^ \t")
 794         (downcase-region save-pos (point))
 795         (setq type (buffer-substring save-pos (point)))
 796         (while (not (eolp))
 797           (skip-chars-forward " \t")
 798           (setq save-pos (point))
 799           (skip-chars-forward "^ \t\n")
 800           (setq extns (cons (buffer-substring save-pos (point)) extns)))
 801         (while extns
 802           (setq mailcap-mime-extensions
 803                 (cons
 804                  (cons (if (= (string-to-char (car extns)) ?.)
 805                            (car extns)
 806                          (concat "." (car extns))) type)
 807                  mailcap-mime-extensions)
 808                 extns (cdr extns)))))))
 809
 810 (defun mailcap-extension-to-mime (extn)
 811   "Return the MIME content type of the file extensions EXTN."
 812   (if (and (stringp extn)
 813            (not (eq (string-to-char extn) ?.)))
 814       (setq extn (concat "." extn)))
 815   (cdr (assoc (downcase extn) mailcap-mime-extensions)))
 816
 817 (provide 'mailcap)
 818
 819 ;;; mailcap.el ends here