1 ;;; mm.el,v --- Mailcap parsing routines, and MIME handling
3 ;; Created: 1996/05/28 02:46:51
5 ;; Keywords: mail, news, hypermedia
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1994, 1995, 1996 by William M. Perry <wmperry@cs.indiana.edu>
9 ;;; Copyright (c) 1996 - 1998 Free Software Foundation, Inc.
11 ;;; This file is not part of GNU Emacs, but the same permissions apply.
13 ;;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;;; it under the terms of the GNU General Public License as published by
15 ;;; the Free Software Foundation; either version 2, or (at your option)
16 ;;; any later version.
18 ;;; GNU Emacs is distributed in the hope that it will be useful,
19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;;; GNU General Public License for more details.
23 ;;; You should have received a copy of the GNU General Public License
24 ;;; along with GNU Emacs; see the file COPYING. If not, write to the
25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26 ;;; Boston, MA 02111-1307, USA.
28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
29 ;;; Generalized mailcap parsing and access routines
30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
34 ;;; The mailcap structure is an assoc list of assoc lists.
35 ;;; 1st assoc list is keyed on the major content-type
36 ;;; 2nd assoc list is keyed on the minor content-type (which can be a regexp)
42 ;;; ("postscript" . <info>)
45 ;;; ("plain" . <info>)
49 ;;; Where <info> is another assoc list of the various information
50 ;;; related to the mailcap RFC. This is keyed on the lowercase
51 ;;; attribute name (viewer, test, etc). This looks like:
52 ;;; (("viewer" . viewerinfo)
53 ;;; ("test" . testinfo)
54 ;;; ("xxxx" . "string")
57 ;;; Where viewerinfo specifies how the content-type is viewed. Can be
58 ;;; a string, in which case it is run through a shell, with
59 ;;; appropriate parameters, or a symbol, in which case the symbol is
60 ;;; funcall'd, with the buffer as an argument.
62 ;;; testinfo is a list of strings, or nil. If nil, it means the
63 ;;; viewer specified is always valid. If it is a list of strings,
64 ;;; these are used to determine whether a viewer passes the 'test' or
67 ;;; The main interface to this code is:
69 ;;; To set everything up:
71 ;;; (mm-parse-mailcaps [path])
73 ;;; Where PATH is a unix-style path specification (: separated list
74 ;;; of strings). If PATH is nil, the environment variable MAILCAPS
75 ;;; will be consulted. If there is no environment variable, then a
76 ;;; default list of paths is used.
78 ;;; To retrieve the information:
79 ;;; (mm-mime-info st [nd] [request])
81 ;;; Where st and nd are positions in a buffer that contain the
82 ;;; content-type header information of a mail/news/whatever message.
83 ;;; st can optionally be a string that contains the content-type
86 ;;; Third argument REQUEST specifies what information to return. If
87 ;;; it is nil or the empty string, the viewer (second field of the
88 ;;; mailcap entry) will be returned. If it is a string, then the
89 ;;; mailcap field corresponding to that string will be returned
90 ;;; (print, description, whatever). If a number, then all the
91 ;;; information for this specific viewer is returned.
93 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
95 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
102 (defconst mm-version (let ((x "1.96"))
103 (if (string-match "Revision: \\([^ \t\n]+\\)" x)
104 (substring x (match-beginning 1) (match-end 1))
106 "Version # of MM package")
108 (defvar mm-parse-args-syntax-table
109 (copy-syntax-table emacs-lisp-mode-syntax-table)
110 "A syntax table for parsing sgml attributes.")
112 (modify-syntax-entry ?' "\"" mm-parse-args-syntax-table)
113 (modify-syntax-entry ?` "\"" mm-parse-args-syntax-table)
114 (modify-syntax-entry ?{ "(" mm-parse-args-syntax-table)
115 (modify-syntax-entry ?} ")" mm-parse-args-syntax-table)
120 ("alternative". (("viewer" . mm-multipart-viewer)
121 ("type" . "multipart/alternative")))
122 ("mixed" . (("viewer" . mm-multipart-viewer)
123 ("type" . "multipart/mixed")))
124 (".*" . (("viewer" . mm-save-binary-file)
125 ("type" . "multipart/*")))
129 ("x-x509-ca-cert" . (("viewer" . ssl-view-site-cert)
130 ("test" . (fboundp 'ssl-view-site-cert))
131 ("type" . "application/x-x509-ca-cert")))
132 ("x-x509-user-cert" . (("viewer" . ssl-view-user-cert)
133 ("test" . (fboundp 'ssl-view-user-cert))
134 ("type" . "application/x-x509-user-cert")))
135 ("octet-stream" . (("viewer" . mm-save-binary-file)
136 ("type" ."application/octet-stream")))
137 ("dvi" . (("viewer" . "open %s")
138 ("type" . "application/dvi")
139 ("test" . (eq (device-type) 'ns))))
140 ("dvi" . (("viewer" . "xdvi %s")
141 ("test" . (eq (device-type) 'x))
143 ("type" . "application/dvi")))
144 ("dvi" . (("viewer" . "dvitty %s")
145 ("test" . (not (getenv "DISPLAY")))
146 ("type" . "application/dvi")))
147 ("emacs-lisp" . (("viewer" . mm-maybe-eval)
148 ("type" . "application/emacs-lisp")))
149 ; ("x-tar" . (("viewer" . tar-mode)
150 ; ("test" . (fboundp 'tar-mode))
151 ; ("type" . "application/x-tar")))
152 ("x-tar" . (("viewer" . mm-save-binary-file)
153 ("type" . "application/x-tar")))
154 ("x-latex" . (("viewer" . tex-mode)
155 ("test" . (fboundp 'tex-mode))
156 ("type" . "application/x-latex")))
157 ("x-tex" . (("viewer" . tex-mode)
158 ("test" . (fboundp 'tex-mode))
159 ("type" . "application/x-tex")))
160 ("latex" . (("viewer" . tex-mode)
161 ("test" . (fboundp 'tex-mode))
162 ("type" . "application/latex")))
163 ("tex" . (("viewer" . tex-mode)
164 ("test" . (fboundp 'tex-mode))
165 ("type" . "application/tex")))
166 ("texinfo" . (("viewer" . texinfo-mode)
167 ("test" . (fboundp 'texinfo-mode))
168 ("type" . "application/tex")))
169 ("zip" . (("viewer" . mm-save-binary-file)
170 ("type" . "application/zip")
172 ("pdf" . (("viewer" . "acroread %s")
173 ("type" . "application/pdf")))
174 ("postscript" . (("viewer" . "open %s")
175 ("type" . "application/postscript")
176 ("test" . (eq (device-type) 'ns))))
177 ("postscript" . (("viewer" . "ghostview %s")
178 ("type" . "application/postscript")
179 ("test" . (eq (device-type) 'x))
181 ("postscript" . (("viewer" . "ps2ascii %s")
182 ("type" . "application/postscript")
183 ("test" . (not (getenv "DISPLAY")))
187 ("x-mpeg" . (("viewer" . "maplay %s")
188 ("type" . "audio/x-mpeg")))
189 (".*" . (("viewer" . mm-play-sound-file)
190 ("test" . (or (featurep 'nas-sound)
191 (featurep 'native-sound)))
192 ("type" . "audio/*")))
193 (".*" . (("viewer" . "showaudio")
194 ("type" . "audio/*")))
197 ("rfc-*822" . (("viewer" . vm-mode)
198 ("test" . (fboundp 'vm-mode))
199 ("type" . "message/rfc-822")))
200 ("rfc-*822" . (("viewer" . w3-mode)
201 ("test" . (fboundp 'w3-mode))
202 ("type" . "message/rfc-822")))
203 ("rfc-*822" . (("viewer" . view-mode)
204 ("test" . (fboundp 'view-mode))
205 ("type" . "message/rfc-822")))
206 ("rfc-*822" . (("viewer" . fundamental-mode)
207 ("type" . "message/rfc-822")))
210 ("x-xwd" . (("viewer" . "xwud -in %s")
211 ("type" . "image/x-xwd")
212 ("compose" . "xwd -frame > %s")
213 ("test" . (eq (device-type) 'x))
215 ("x11-dump" . (("viewer" . "xwud -in %s")
216 ("type" . "image/x-xwd")
217 ("compose" . "xwd -frame > %s")
218 ("test" . (eq (device-type) 'x))
220 ("windowdump" . (("viewer" . "xwud -in %s")
221 ("type" . "image/x-xwd")
222 ("compose" . "xwd -frame > %s")
223 ("test" . (eq (device-type) 'x))
225 (".*" . (("viewer" . "open %s")
227 ("test" . (eq (device-type) 'ns))))
228 (".*" . (("viewer" . "xv -perfect %s")
230 ("test" . (eq (device-type) 'x))
234 ("plain" . (("viewer" . w3-mode)
235 ("test" . (fboundp 'w3-mode))
236 ("type" . "text/plain")))
237 ("plain" . (("viewer" . view-mode)
238 ("test" . (fboundp 'view-mode))
239 ("type" . "text/plain")))
240 ("plain" . (("viewer" . fundamental-mode)
241 ("type" . "text/plain")))
242 ("enriched" . (("viewer" . enriched-decode-region)
244 'enriched-decode-region))
245 ("type" . "text/enriched")))
246 ("html" . (("viewer" . w3-prepare-buffer)
247 ("test" . (fboundp 'w3-prepare-buffer))
248 ("type" . "text/html")))
251 ("mpeg" . (("viewer" . "mpeg_play %s")
252 ("type" . "video/mpeg")
253 ("test" . (eq (device-type) 'x))
257 ("x-vrml" . (("viewer" . "webspace -remote %s -URL %u")
258 ("type" . "x-world/x-vrml")
262 ("tar" . (("viewer" . tar-mode)
263 ("type" . "archive/tar")
264 ("test" . (fboundp 'tar-mode))))
267 "*The mailcap structure is an assoc list of assoc lists.
268 1st assoc list is keyed on the major content-type
269 2nd assoc list is keyed on the minor content-type (which can be a regexp)
275 (\"postscript\" . <info>)
282 Where <info> is another assoc list of the various information
283 related to the mailcap RFC. This is keyed on the lowercase
284 attribute name (viewer, test, etc). This looks like:
285 ((\"viewer\" . viewerinfo)
286 (\"test\" . testinfo)
287 (\"xxxx\" . \"string\")
290 Where viewerinfo specifies how the content-type is viewed. Can be
291 a string, in which case it is run through a shell, with
292 appropriate parameters, or a symbol, in which case the symbol is
293 funcall'd, with the buffer as an argument.
295 testinfo is a list of strings, or nil. If nil, it means the
296 viewer specified is always valid. If it is a list of strings,
297 these are used to determine whether a viewer passes the 'test' or
300 (defvar mm-content-transfer-encodings
301 '(("base64" . base64-decode-region)
305 ("x-compress" . ("uncompress" "-c"))
306 ("x-gzip" . ("gzip" "-dc"))
307 ("compress" . ("uncompress" "-c"))
308 ("gzip" . ("gzip" "-dc"))
309 ("x-hqx" . ("mcvert" "-P" "-s" "-S"))
310 ("quoted-printable" . mm-decode-quoted-printable)
312 "*An assoc list of content-transfer-encodings and how to decode them.")
314 (defvar mm-download-directory nil
315 "*Where downloaded files should go by default.")
317 (defvar mm-temporary-directory (or (getenv "TMPDIR") "/tmp")
318 "*Where temporary files go.")
321 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
322 ;;; A few things from w3 and url, just in case this is used without them
323 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
325 (defun mm-generate-unique-filename (&optional fmt)
326 "Generate a unique filename in mm-temporary-directory"
328 (let ((base (format "mm-tmp.%d" (user-real-uid)))
331 (setq fname (format "%s%d" base x))
332 (while (file-exists-p
333 (expand-file-name fname mm-temporary-directory))
335 fname (concat base (int-to-string x))))
336 (expand-file-name fname mm-temporary-directory))
337 (let ((base (concat "mm" (int-to-string (user-real-uid))))
340 (setq fname (format fmt (concat base (int-to-string x))))
341 (while (file-exists-p
342 (expand-file-name fname mm-temporary-directory))
344 fname (format fmt (concat base (int-to-string x)))))
345 (expand-file-name fname mm-temporary-directory))))
347 (if (and (fboundp 'copy-tree)
348 (subrp (symbol-function 'copy-tree)))
349 (fset 'mm-copy-tree 'copy-tree)
350 (defun mm-copy-tree (tree)
352 (cons (mm-copy-tree (car tree))
353 (mm-copy-tree (cdr tree)))
355 (let* ((new (copy-sequence tree))
356 (i (1- (length new))))
358 (aset new i (mm-copy-tree (aref new i)))
364 ;(require 'mule-sysdp)
366 (if (not (fboundp 'w3-save-binary-file))
367 (defun mm-save-binary-file ()
368 ;; Ok, this is truly fucked. In XEmacs, if you use the mouse to select
369 ;; a URL that gets saved via this function, read-file-name will pop up a
370 ;; dialog box for file selection. For some reason which buffer we are in
371 ;; gets royally screwed (even with save-excursions and the whole nine
372 ;; yards). SO, we just keep the old buffer name around and away we go.
373 (let ((old-buff (current-buffer))
374 (file (read-file-name "Filename to save as: "
375 (or mm-download-directory "~/")
376 (file-name-nondirectory (url-view-url t))
378 (file-name-nondirectory (url-view-url t))))
379 (require-final-newline nil))
380 (set-buffer old-buff)
381 (mule-write-region-no-coding-system (point-min) (point-max) file)
382 (kill-buffer (current-buffer))))
383 (fset 'mm-save-binary-file 'w3-save-binary-file))
385 (defun mm-maybe-eval ()
386 "Maybe evaluate a buffer of emacs lisp code"
387 (if (yes-or-no-p "This is emacs-lisp code, evaluate it? ")
388 (eval-buffer (current-buffer))
392 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
393 ;;; The mailcap parser
394 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
395 (defun mm-viewer-unescape (format &optional filename url)
397 (set-buffer (get-buffer-create " *mm-parse*"))
400 (goto-char (point-min))
401 (while (re-search-forward "%\\(.\\)" nil t)
402 (let ((escape (aref (match-string 1) 0)))
403 (replace-match "" t t)
406 (?s (insert (or filename "\"\"")))
407 (?u (insert (or url "\"\""))))))
410 (defun mm-in-assoc (elt list)
411 ;; Check to see if ELT matches any of the regexps in the car elements of LIST
413 (while (and list (not rslt))
414 (and (car (car list))
415 (string-match (car (car list)) elt)
416 (setq rslt (car list)))
417 (setq list (cdr list)))
420 (defun mm-replace-regexp (regexp to-string)
421 ;; Quiet replace-regexp.
422 (goto-char (point-min))
423 (while (re-search-forward regexp nil t)
424 (replace-match to-string t nil)))
426 (defun mm-parse-mailcaps (&optional path)
427 ;; Parse out all the mailcaps specified in a unix-style path string PATH
430 ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS")))
431 ((memq system-type '(ms-dos ms-windows windows-nt))
432 (setq path (mapconcat 'expand-file-name '("~/mail.cap" "~/etc/mail.cap")
434 (t (setq path (mapconcat 'expand-file-name
436 "/etc/mailcap:/usr/etc/mailcap"
437 "/usr/local/etc/mailcap") ":"))))
438 (let ((fnames (reverse
439 (mm-string-to-tokens path
440 (if (memq system-type
441 '(ms-dos ms-windows windows-nt))
446 (setq fname (car fnames))
447 (if (and (file-exists-p fname) (file-readable-p fname))
448 (mm-parse-mailcap (car fnames)))
449 (setq fnames (cdr fnames)))))
451 (defun mm-parse-mailcap (fname)
452 ;; Parse out the mailcap file specified by FNAME
453 (let (major ; The major mime type (image/audio/etc)
454 minor ; The minor mime type (gif, basic, etc)
455 save-pos ; Misc saved positions used in parsing
456 viewer ; How to view this mime type
457 info ; Misc info about this mime type
460 (set-buffer (get-buffer-create " *mailcap*"))
462 (insert-file-contents fname)
463 (set-syntax-table mm-parse-args-syntax-table)
464 (mm-replace-regexp "#.*" "") ; Remove all comments
465 (mm-replace-regexp "\n+" "\n") ; And blank lines
466 (mm-replace-regexp "\\\\[ \t\n]+" " ") ; And collapse spaces
467 (mm-replace-regexp (concat (regexp-quote "\\") "[ \t]*\n") "")
468 (goto-char (point-max))
469 (skip-chars-backward " \t\n")
470 (delete-region (point) (point-max))
471 (goto-char (point-min))
473 (skip-chars-forward " \t\n")
474 (setq save-pos (point)
476 (skip-chars-forward "^/;")
477 (downcase-region save-pos (point))
478 (setq major (buffer-substring save-pos (point)))
479 (skip-chars-forward "/ \t\n")
480 (setq save-pos (point))
481 (skip-chars-forward "^;")
482 (downcase-region save-pos (point))
485 ((= ?* (or (char-after save-pos) 0)) ".*")
486 ((= (point) save-pos) ".*")
487 (t (buffer-substring save-pos (point)))))
488 (skip-chars-forward "; \t\n")
489 ;;; Got the major/minor chunks, now for the viewers/etc
490 ;;; The first item _must_ be a viewer, according to the
491 ;;; RFC for mailcap files (#1343)
492 (skip-chars-forward "; \t\n")
493 (setq save-pos (point))
494 (skip-chars-forward "^;\n")
495 (if (= (or (char-after save-pos) 0) ?')
497 (narrow-to-region (1+ save-pos) (point))
498 (goto-char (point-min))
500 (read (current-buffer))
501 (goto-char (point-max))
503 (setq viewer (buffer-substring save-pos (point))))
504 (setq save-pos (point))
506 (setq info (nconc (list (cons "viewer" viewer)
507 (cons "type" (concat major "/"
508 (if (string= minor ".*")
510 (mm-parse-mailcap-extras save-pos (point))))
511 (mm-mailcap-entry-passes-test info)
512 (mm-add-mailcap-entry major minor info)))))
514 (defun mm-parse-mailcap-extras (st nd)
515 ;; Grab all the extra stuff from a mailcap entry
519 results ; Assoc list of results
520 name-pos ; Start of XXXX= position
521 val-pos ; Start of value position
522 done ; Found end of \'d ;s?
525 (narrow-to-region st nd)
526 (goto-char (point-min))
527 (skip-chars-forward " \n\t;")
530 (skip-chars-forward " \";\n\t")
531 (setq name-pos (point))
532 (skip-chars-forward "^ \n\t=")
533 (downcase-region name-pos (point))
534 (setq name (buffer-substring name-pos (point)))
535 (skip-chars-forward " \t\n")
536 (if (/= (or (char-after (point)) 0) ?=) ; There is no value
538 (skip-chars-forward " \t\n=")
539 (setq val-pos (point))
540 (if (memq (char-after val-pos) '(?\" ?'))
542 (setq val-pos (1+ val-pos))
547 (error (goto-char (point-max)))))
549 (skip-chars-forward "^;")
550 (if (= (or (char-after (1- (point))) 0) ?\\ )
552 (subst-char-in-region (1- (point)) (point) ?\\ ? )
553 (skip-chars-forward ";"))
555 (setq value (buffer-substring val-pos (point))))
556 (setq results (cons (cons name value) results)))
559 (defun mm-string-to-tokens (str &optional delim)
560 "Return a list of words from the string STR"
561 (setq delim (or delim ? ))
567 ((and (= x delim) y) (setq results (cons y results) y nil))
568 ((/= x delim) (setq y (concat y (char-to-string x))))
570 (nreverse (cons y results))))
572 (defun mm-mailcap-entry-passes-test (info)
573 ;; Return t iff a mailcap entry passes its test clause or no test
574 ;; clause is present.
575 (let (status ; Call-process-regions return value
576 (test (assoc "test" info)); The test clause
578 (setq status (and test (mm-string-to-tokens (cdr test))))
579 (if (and (assoc "needsx11" info) (not (getenv "DISPLAY")))
582 ((and (equal (nth 0 status) "test")
583 (equal (nth 1 status) "-n")
584 (or (equal (nth 2 status) "$DISPLAY")
585 (equal (nth 2 status) "\"$DISPLAY\"")))
586 (setq status (if (getenv "DISPLAY") t nil)))
587 ((and (equal (nth 0 status) "test")
588 (equal (nth 1 status) "-z")
589 (or (equal (nth 2 status) "$DISPLAY")
590 (equal (nth 2 status) "\"$DISPLAY\"")))
591 (setq status (if (getenv "DISPLAY") nil t)))
594 (and test (listp test) (setcdr test status))))
596 (defun mm-parse-args (st &optional nd nodowncase)
597 ;; Return an assoc list of attribute/value pairs from an RFC822-type string
601 results ; Assoc list of results
602 name-pos ; Start of XXXX= position
603 val-pos ; Start of value position
608 (set-buffer (get-buffer-create " *mm-temp*"))
609 (set-syntax-table mm-parse-args-syntax-table)
614 (set-syntax-table mm-parse-args-syntax-table))
616 (narrow-to-region st nd)
617 (goto-char (point-min))
619 (skip-chars-forward "; \n\t")
620 (setq name-pos (point))
621 (skip-chars-forward "^ \n\t=;")
623 (downcase-region name-pos (point)))
624 (setq name (buffer-substring name-pos (point)))
625 (skip-chars-forward " \t\n")
626 (if (/= (or (char-after (point)) 0) ?=) ; There is no value
628 (skip-chars-forward " \t\n=")
629 (setq val-pos (point)
632 ((or (= (or (char-after val-pos) 0) ?\")
633 (= (or (char-after val-pos) 0) ?'))
634 (buffer-substring (1+ val-pos)
639 (skip-chars-forward "\""))
641 (skip-chars-forward "^ \t\n")
644 (buffer-substring val-pos
646 (skip-chars-forward "^;")
647 (skip-chars-backward " \t")
649 (setq results (cons (cons name value) results))
650 (skip-chars-forward "; \n\t"))
653 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
654 ;;; The action routines.
655 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
656 (defun mm-possible-viewers (major minor)
657 ;; Return a list of possible viewers from MAJOR for minor type MINOR
662 ((equal (car (car major)) minor)
663 (setq exact (cons (cdr (car major)) exact)))
664 ((string-match (car (car major)) minor)
665 (setq wildcard (cons (cdr (car major)) wildcard))))
666 (setq major (cdr major)))
667 (nconc (nreverse exact) (nreverse wildcard))))
669 (defun mm-unescape-mime-test (test type-info)
670 (let ((buff (get-buffer-create " *unescape*"))
671 save-pos save-chr subst)
673 ((symbolp test) test)
674 ((and (listp test) (symbolp (car test))) test)
676 (and (listp test) (stringp (car test))
677 (setq test (mapconcat 'identity test " "))))
682 (goto-char (point-min))
684 (skip-chars-forward "^%")
686 (progn (skip-chars-backward "\\\\")
688 0) ; It is an escaped %
691 (skip-chars-forward "%."))
692 (setq save-pos (point))
693 (skip-chars-forward "%")
694 (setq save-chr (char-after (point)))
696 ((null save-chr) nil)
698 (delete-region save-pos (progn (forward-char 1) (point)))
699 (insert (or (cdr (assoc "type" type-info)) "\"\"")))
701 (delete-region save-pos (progn (forward-char 1) (point)))
704 (delete-region save-pos (progn (forward-char 1) (point)))
707 (delete-region save-pos (progn (forward-char 1) (point)))
711 (skip-chars-forward "^}")
712 (downcase-region (+ 2 save-pos) (point))
713 (setq subst (buffer-substring (+ 2 save-pos) (point)))
714 (delete-region save-pos (1+ (point)))
715 (insert (or (cdr (assoc subst type-info)) "\"\"")))
718 (t (error "Bad value to mm-unescape-mime-test. %s" test)))))
720 (defun mm-viewer-passes-test (viewer-info type-info)
721 ;; Return non-nil iff the viewer specified by VIEWER-INFO passes its
722 ;; test clause (if any).
723 (let* ((test-info (assoc "test" viewer-info))
724 (test (cdr test-info))
725 (viewer (cdr (assoc "viewer" viewer-info)))
726 (default-directory (expand-file-name "~/"))
731 ((not test-info) t) ; No test clause
732 ((not test) nil) ; Already failed test
733 ((eq test t) t) ; Already passed test
734 ((and (symbolp test) ; Lisp function as test
736 (funcall test type-info))
737 ((and (symbolp test) ; Lisp variable as test
740 ((and (listp test) ; List to be eval'd
741 (symbolp (car test)))
744 (setq test (mm-unescape-mime-test test type-info)
745 test (list shell-file-name nil nil nil shell-command-switch test)
746 status (apply 'call-process test))
749 (defun mm-add-mailcap-entry (major minor info)
750 (let ((old-major (assoc major mm-mime-data)))
751 (if (null old-major) ; New major area
753 (cons (cons major (list (cons minor info)))
755 (let ((cur-minor (assoc minor old-major)))
757 ((or (null cur-minor) ; New minor area, or
758 (assoc "test" info)) ; Has a test, insert at beginning
759 (setcdr old-major (cons (cons minor info) (cdr old-major))))
760 ((and (not (assoc "test" info)); No test info, replace completely
761 (not (assoc "test" cur-minor)))
762 (setcdr cur-minor info))
764 (setcdr old-major (cons (cons minor info) (cdr old-major)))))))))
767 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
769 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
770 (defun mm-viewer-lessp (x y)
771 ;; Return t iff viewer X is more desirable than viewer Y
772 (let ((x-wild (string-match "[*?]" (or (cdr-safe (assoc "type" x)) "")))
773 (y-wild (string-match "[*?]" (or (cdr-safe (assoc "type" y)) "")))
774 (x-lisp (not (stringp (or (cdr-safe (assoc "viewer" x)) ""))))
775 (y-lisp (not (stringp (or (cdr-safe (assoc "viewer" y)) "")))))
777 ((and x-lisp (not y-lisp))
779 ((and (not y-lisp) x-wild (not y-wild))
781 ((and (not x-wild) y-wild)
785 (defun mm-mime-info (st &optional nd request)
786 "Get the mime viewer command for HEADERLINE, return nil if none found.
787 Expects a complete content-type header line as its argument. This can
788 be simple like text/html, or complex like text/plain; charset=blah; foo=bar
790 Third argument REQUEST specifies what information to return. If it is
791 nil or the empty string, the viewer (second field of the mailcap
792 entry) will be returned. If it is a string, then the mailcap field
793 corresponding to that string will be returned (print, description,
794 whatever). If a number, then all the information for this specific
797 major ; Major encoding (text, etc)
798 minor ; Minor encoding (html, etc)
800 save-pos ; Misc. position during parse
801 major-info ; (assoc major mm-mime-data)
802 minor-info ; (assoc minor major-info)
803 test ; current test proc.
804 viewers ; Possible viewers
805 passed ; Viewers that passed the test
806 viewer ; The one and only viewer
811 (set-buffer (get-buffer-create " *mimeparse*"))
813 (insert "text/plain")
814 (setq st (point-min)))
816 (set-buffer (get-buffer-create " *mimeparse*"))
819 (setq st (point-min)))
821 (narrow-to-region st (progn (goto-char st) (end-of-line) (point))))
822 (t (narrow-to-region st nd)))
824 (skip-chars-forward ": \t\n")
828 (setq save-pos (point))
829 (skip-chars-forward "^/")
830 (downcase-region save-pos (point))
831 (setq major (buffer-substring save-pos (point)))
832 (if (not (setq major-info (cdr (assoc major mm-mime-data))))
833 (throw 'mm-exit nil))
834 (skip-chars-forward "/ \t\n")
835 (setq save-pos (point))
836 (skip-chars-forward "^ \t\n;")
837 (downcase-region save-pos (point))
838 (setq minor (buffer-substring save-pos (point)))
840 (setq viewers (mm-possible-viewers major-info minor)))
841 (throw 'mm-exit nil))
842 (skip-chars-forward "; \t")
845 (setq save-pos (point))
847 (setq info (mm-parse-args save-pos (point)))
850 (if (mm-viewer-passes-test (car viewers) info)
851 (setq passed (cons (car viewers) passed)))
852 (setq viewers (cdr viewers)))
853 (setq passed (sort (nreverse passed) 'mm-viewer-lessp))
855 (if (and (stringp (cdr (assoc "viewer" viewer)))
857 (setq viewer (car passed)))
860 ((and (null viewer) (not (equal major "default")))
861 (mm-mime-info "default" nil request))
862 ((or (null request) (equal request ""))
863 (mm-unescape-mime-test (cdr (assoc "viewer" viewer)) info))
865 (if (or (string= request "test") (string= request "viewer"))
866 (mm-unescape-mime-test (cdr-safe (assoc request viewer)) info)))
868 ;; MUST make a copy *sigh*, else we modify mm-mime-data
869 (setq viewer (mm-copy-tree viewer))
870 (let ((view (assoc "viewer" viewer))
871 (test (assoc "test" viewer)))
872 (if view (setcdr view (mm-unescape-mime-test (cdr view) info)))
873 (if test (setcdr test (mm-unescape-mime-test (cdr test) info))))
877 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
878 ;;; Experimental MIME-types parsing
879 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
880 (defvar mm-mime-extensions
883 (".abs" . "audio/x-mpeg")
884 (".aif" . "audio/aiff")
885 (".aifc" . "audio/aiff")
886 (".aiff" . "audio/aiff")
887 (".ano" . "application/x-annotator")
888 (".au" . "audio/ulaw")
889 (".avi" . "video/x-msvideo")
890 (".bcpio" . "application/x-bcpio")
891 (".bin" . "application/octet-stream")
892 (".cdf" . "application/x-netcdr")
893 (".cpio" . "application/x-cpio")
894 (".csh" . "application/x-csh")
895 (".dvi" . "application/x-dvi")
896 (".el" . "application/emacs-lisp")
897 (".eps" . "application/postscript")
898 (".etx" . "text/x-setext")
899 (".exe" . "application/octet-stream")
900 (".fax" . "image/x-fax")
901 (".gif" . "image/gif")
902 (".hdf" . "application/x-hdf")
903 (".hqx" . "application/mac-binhex40")
904 (".htm" . "text/html")
905 (".html" . "text/html")
906 (".icon" . "image/x-icon")
907 (".ief" . "image/ief")
908 (".jpg" . "image/jpeg")
909 (".macp" . "image/x-macpaint")
910 (".man" . "application/x-troff-man")
911 (".me" . "application/x-troff-me")
912 (".mif" . "application/mif")
913 (".mov" . "video/quicktime")
914 (".movie" . "video/x-sgi-movie")
915 (".mp2" . "audio/x-mpeg")
916 (".mp2a" . "audio/x-mpeg2")
917 (".mpa" . "audio/x-mpeg")
918 (".mpa2" . "audio/x-mpeg2")
919 (".mpe" . "video/mpeg")
920 (".mpeg" . "video/mpeg")
921 (".mpega" . "audio/x-mpeg")
922 (".mpegv" . "video/mpeg")
923 (".mpg" . "video/mpeg")
924 (".mpv" . "video/mpeg")
925 (".ms" . "application/x-troff-ms")
926 (".nc" . "application/x-netcdf")
927 (".nc" . "application/x-netcdf")
928 (".oda" . "application/oda")
929 (".pbm" . "image/x-portable-bitmap")
930 (".pdf" . "application/pdf")
931 (".pgm" . "image/portable-graymap")
932 (".pict" . "image/pict")
933 (".png" . "image/png")
934 (".pnm" . "image/x-portable-anymap")
935 (".ppm" . "image/portable-pixmap")
936 (".ps" . "application/postscript")
937 (".qt" . "video/quicktime")
938 (".ras" . "image/x-raster")
939 (".rgb" . "image/x-rgb")
940 (".rtf" . "application/rtf")
941 (".rtx" . "text/richtext")
942 (".sh" . "application/x-sh")
943 (".sit" . "application/x-stuffit")
944 (".snd" . "audio/basic")
945 (".src" . "application/x-wais-source")
946 (".tar" . "archive/tar")
947 (".tcl" . "application/x-tcl")
948 (".tcl" . "application/x-tcl")
949 (".tex" . "application/x-tex")
950 (".texi" . "application/texinfo")
951 (".tga" . "image/x-targa")
952 (".tif" . "image/tiff")
953 (".tiff" . "image/tiff")
954 (".tr" . "application/x-troff")
955 (".troff" . "application/x-troff")
956 (".tsv" . "text/tab-separated-values")
957 (".txt" . "text/plain")
958 (".vbs" . "video/mpeg")
959 (".vox" . "audio/basic")
960 (".vrml" . "x-world/x-vrml")
961 (".wav" . "audio/x-wav")
962 (".wrl" . "x-world/x-vrml")
963 (".xbm" . "image/xbm")
964 (".xpm" . "image/x-pixmap")
965 (".xwd" . "image/windowdump")
966 (".zip" . "application/zip")
967 (".ai" . "application/postscript")
968 (".jpe" . "image/jpeg")
969 (".jpeg" . "image/jpeg")
971 "*An assoc list of file extensions and the MIME content-types they
974 (defun mm-parse-mimetypes (&optional path)
975 ;; Parse out all the mimetypes specified in a unix-style path string PATH
978 ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES")))
979 ((memq system-type '(ms-dos ms-windows windows-nt))
980 (setq path (mapconcat 'expand-file-name
981 '("~/mime.typ" "~/etc/mime.typ") ";")))
982 (t (setq path (mapconcat 'expand-file-name
984 "/etc/mime-types:/usr/etc/mime-types"
985 "/usr/local/etc/mime-types"
986 "/usr/local/www/conf/mime-types") ":"))))
987 (let ((fnames (reverse
988 (mm-string-to-tokens path
989 (if (memq system-type
990 '(ms-dos ms-windows windows-nt))
995 (setq fname (car fnames))
996 (if (and (file-exists-p fname) (file-readable-p fname))
997 (mm-parse-mimetype-file (car fnames)))
998 (setq fnames (cdr fnames)))))
1000 (defun mm-parse-mimetype-file (fname)
1001 ;; Parse out a mime-types file
1002 (let (type ; The MIME type for this line
1003 extns ; The extensions for this line
1004 save-pos ; Misc. saved buffer positions
1007 (set-buffer (get-buffer-create " *mime-types*"))
1009 (insert-file-contents fname)
1010 (mm-replace-regexp "#.*" "")
1011 (mm-replace-regexp "\n+" "\n")
1012 (mm-replace-regexp "[ \t]+$" "")
1013 (goto-char (point-max))
1014 (skip-chars-backward " \t\n")
1015 (delete-region (point) (point-max))
1016 (goto-char (point-min))
1018 (skip-chars-forward " \t\n")
1019 (setq save-pos (point))
1020 (skip-chars-forward "^ \t")
1021 (downcase-region save-pos (point))
1022 (setq type (buffer-substring save-pos (point)))
1024 (skip-chars-forward " \t")
1025 (setq save-pos (point))
1026 (skip-chars-forward "^ \t\n")
1027 (setq extns (cons (buffer-substring save-pos (point)) extns)))
1029 (setq mm-mime-extensions
1031 (cons (if (= (string-to-char (car extns)) ?.)
1033 (concat "." (car extns))) type) mm-mime-extensions)
1034 extns (cdr extns)))))))
1036 (defun mm-extension-to-mime (extn)
1037 "Return the MIME content type of the file extensions EXTN"
1038 (if (and (stringp extn)
1039 (not (eq (string-to-char extn) ?.)))
1040 (setq extn (concat "." extn)))
1041 (cdr (assoc (downcase extn) mm-mime-extensions)))
1044 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1045 ;;; Editing/Composition of body parts
1046 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1047 (defun mm-compose-type (type)
1048 ;; Compose a body section of MIME-type TYPE.
1049 (let* ((info (mm-mime-info type nil 5))
1050 (fnam (mm-generate-unique-filename))
1051 (comp (or (cdr (assoc "compose" info))))
1052 (ctyp (cdr (assoc "composetyped" info)))
1053 (buff (get-buffer-create " *mimecompose*"))
1057 (setq comp (mm-unescape-mime-test (or comp ctyp) info))
1058 (while (string-match "\\([^\\\\]\\)%s" comp)
1059 (setq comp (concat (substring comp 0 (match-end 1)) fnam
1060 (substring comp (match-end 0) nil))
1062 (call-process shell-file-name nil
1064 nil shell-command-switch comp)
1067 (if typeit (concat "Content-type: " type "\r\n\r\n") "")
1072 (insert-file-contents fnam)
1080 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1082 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1083 (defun mm-type-to-file (type)
1084 "Return the file extension for content-type TYPE"
1085 (rassoc type mm-mime-extensions))
1088 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1089 ;;; Miscellaneous MIME viewers written in elisp
1090 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1091 (defun mm-play-sound-file (&optional buff)
1092 "Play a sound file in buffer BUFF (defaults to current buffer)"
1093 (setq buff (or buff (current-buffer)))
1094 (let ((fname (mm-generate-unique-filename "%s.au"))
1095 (synchronous-sounds t)) ; Play synchronously
1096 (mule-write-region-no-coding-system (point-min) (point-max) fname)
1097 (kill-buffer (current-buffer))
1098 (play-sound-file fname)
1103 (defun mm-parse-mime-headers (&optional no-delete)
1104 "Return a list of the MIME headers at the top of this buffer. If
1105 optional argument NO-DELETE is non-nil, don't delete the headers."
1106 (let* ((st (point-min))
1108 (goto-char (point-min))
1109 (skip-chars-forward " \t\n")
1110 (if (re-search-forward "^\r*$" nil t)
1120 (narrow-to-region st (min nd (point-max)))
1121 (goto-char (point-min))
1123 (skip-chars-forward " \t\n\r")
1124 (setq save-pos (point))
1125 (skip-chars-forward "^:\n\r")
1126 (downcase-region save-pos (point))
1127 (setq hname (buffer-substring save-pos (point)))
1128 (skip-chars-forward ": \t ")
1129 (setq save-pos (point))
1130 (skip-chars-forward "^\n\r")
1133 (skip-chars-forward "^\n\r")
1135 (skip-chars-forward "\n\r")
1138 (string-match "[ \t]"
1140 (or (char-after (point)) ?a)))))
1142 (skip-chars-forward "\n\r")))
1143 (setq hvalu (buffer-substring save-pos (point))
1144 result (cons (cons hname hvalu) result)))
1145 (or no-delete (delete-region st nd))
1148 (defun mm-find-available-multiparts (separator &optional buf)
1149 "Return a list of mime-headers for the various body parts of a
1150 multipart message in buffer BUF with separator SEPARATOR.
1151 The different multipart specs are put in `mm-temporary-directory'."
1152 (let ((sep (concat "^--" separator "\r*$"))
1157 (and buf (set-buffer buf))
1158 (goto-char (point-min))
1159 (while (re-search-forward sep nil t)
1160 (let ((st (set-marker (make-marker)
1165 (nd (set-marker (make-marker)
1166 (if (re-search-forward sep nil t)
1167 (1- (match-beginning 0))
1169 (narrow-to-region st nd)
1171 (if (looking-at "^\r*$")
1172 (insert "Content-type: text/plain\n"
1173 "Content-length: " (int-to-string (- nd st)) "\n"))
1174 (setq headers (mm-parse-mime-headers)
1175 fname (mm-generate-unique-filename))
1176 (let ((x (or (cdr (assoc "content-type" headers)) "text/plain")))
1177 (if (string-match "name=\"*\\([^ \"]+\\)\"*" x)
1178 (setq fname (expand-file-name
1179 (substring x (match-beginning 1)
1181 mm-temporary-directory))))
1183 (if (assoc "content-transfer-encoding" headers)
1185 (assoc "content-transfer-encoding" headers)))
1187 (setq coding (and coding (downcase coding))
1188 cmd (or (cdr (assoc coding
1189 mm-content-transfer-encodings))
1191 (concat "How shall I decode " coding "? ")
1193 (if (string= cmd "") (setq cmd "cat"))
1195 (shell-command-on-region st nd cmd t)
1196 (funcall cmd st nd))
1197 (or (eq cmd 'ignore) (set-marker nd (point)))))
1198 (write-region st nd fname nil 5)
1199 (delete-region st nd)
1202 (cons "mm-filename" fname) headers) results)))))
1205 (defun mm-format-multipart-as-html (&optional buf type)
1206 (if buf (set-buffer buf))
1207 (let* ((boundary (if (string-match
1208 "boundary[ \t]*=[ \t\"]*\\([^ \"\t\n]+\\)"
1211 (substring type (match-beginning 1) (match-end 1)))))
1212 (parts (mm-find-available-multiparts boundary)))
1216 " <title>Multipart Message</title>\n"
1219 " <h1> Multipart message encountered </h1>\n"
1220 " <p> I have encountered a multipart MIME message.\n"
1221 " The following parts have been detected. Please\n"
1222 " select which one you want to view.\n"
1226 (function (lambda (x)
1227 (concat " <li> <a href=\"file:"
1228 (cdr (assoc "mm-filename" x))
1230 (or (cdr (assoc "content-description" x)) "")
1232 (or (cdr (assoc "content-type" x))
1239 "<!-- Automatically generated by MM v" mm-version "-->\n")))
1241 (defun mm-multipart-viewer ()
1242 (mm-format-multipart-as-html
1244 (cdr (assoc "content-type" url-current-mime-headers)))
1245 (let ((w3-working-buffer (current-buffer)))
1246 (w3-prepare-buffer)))
1248 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1249 ;;; Transfer encodings we can decrypt automatically
1250 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1251 (defun mm-decode-quoted-printable (&optional st nd)
1253 (setq st (or st (point-min))
1254 nd (or nd (point-max)))
1256 (narrow-to-region st nd)
1258 (let ((buffer-read-only nil))
1259 (goto-char (point-min))
1260 (while (re-search-forward "=[0-9A-F][0-9A-F]" nil t)
1264 (* 16 (mm-hex-char-to-integer
1265 (char-after (1+ (match-beginning 0)))))
1266 (mm-hex-char-to-integer
1267 (char-after (1- (match-end 0))))))))))
1268 (goto-char (point-max))))
1270 ;; Taken from hexl.el.
1271 (defun mm-hex-char-to-integer (character)
1272 "Take a char and return its value as if it was a hex digit."
1273 (if (and (>= character ?0) (<= character ?9))
1275 (let ((ch (logior character 32)))
1276 (if (and (>= ch ?a) (<= ch ?f))
1278 (error (format "Invalid hex digit `%c'." ch))))))