Importing Pterodactyl Gnus v0.95.
[elisp/gnus.git-] / lisp / mm.el
1 ;;; mm.el,v --- Mailcap parsing routines, and MIME handling
2 ;; Author: wmperry
3 ;; Created: 1996/05/28 02:46:51
4 ;; Version: 1.96
5 ;; Keywords: mail, news, hypermedia
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1994, 1995, 1996 by William M. Perry <wmperry@cs.indiana.edu>
9 ;;; Copyright (c) 1996 - 1998 Free Software Foundation, Inc.
10 ;;;
11 ;;; This file is not part of GNU Emacs, but the same permissions apply.
12 ;;;
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.
17 ;;;
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.
22 ;;;
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.
27 ;;;
28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
29 ;;; Generalized mailcap parsing and access routines
30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
31 ;;;
32 ;;; Data structures
33 ;;; ---------------
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)
37 ;;;
38 ;;; Which looks like:
39 ;;; -----------------
40 ;;; (
41 ;;;  ("application"
42 ;;;   ("postscript" . <info>)
43 ;;;  )
44 ;;;  ("text"
45 ;;;   ("plain" . <info>)
46 ;;;  )
47 ;;; )
48 ;;;
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")
55 ;;; )
56 ;;;
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.
61 ;;;
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
65 ;;; not.
66 ;;;
67 ;;; The main interface to this code is:
68 ;;;
69 ;;; To set everything up:
70 ;;;
71 ;;;  (mm-parse-mailcaps [path])
72 ;;;
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.
77 ;;;
78 ;;; To retrieve the information:
79 ;;;  (mm-mime-info st [nd] [request])
80 ;;;
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
84 ;;;  information.
85 ;;;
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.
92 ;;;
93 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
94 ;;; Variables, etc
95 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
96 (eval-and-compile
97   (require 'cl)
98 ;LMI was here
99   ;;(require 'devices)
100   )
101
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))
105                          x))
106   "Version # of MM package")
107
108 (defvar mm-parse-args-syntax-table
109   (copy-syntax-table emacs-lisp-mode-syntax-table)
110   "A syntax table for parsing sgml attributes.")
111
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)
116
117 (defvar mm-mime-data
118   '(
119     ("multipart"   . (
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/*")))
126                       )
127      )
128     ("application" . (
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))
142                                        ("needsx11")
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")
171                                        ("copiousoutput")))
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))
180                                        ("needsx11")))
181                       ("postscript" . (("viewer" . "ps2ascii %s")
182                                        ("type" . "application/postscript")
183                                        ("test" . (not (getenv "DISPLAY")))
184                                        ("copiousoutput")))
185                       ))
186     ("audio"       . (
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/*")))
195                       ))
196     ("message"     . (
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")))
208                       ))
209     ("image"       . (
210                       ("x-xwd" . (("viewer"  . "xwud -in %s")
211                                   ("type"    . "image/x-xwd")
212                                   ("compose" . "xwd -frame > %s")
213                                   ("test"    . (eq (device-type) 'x))
214                                   ("needsx11")))
215                       ("x11-dump" . (("viewer" . "xwud -in %s")
216                                      ("type" . "image/x-xwd")
217                                      ("compose" . "xwd -frame > %s")
218                                      ("test"   . (eq (device-type) 'x))
219                                      ("needsx11")))
220                       ("windowdump" . (("viewer" . "xwud -in %s")
221                                        ("type" . "image/x-xwd")
222                                        ("compose" . "xwd -frame > %s")
223                                        ("test"   . (eq (device-type) 'x))
224                                        ("needsx11")))
225                       (".*" . (("viewer" . "open %s")
226                                ("type"   . "image/*")
227                                ("test"   . (eq (device-type) 'ns))))
228                       (".*" . (("viewer" . "xv -perfect %s")
229                                ("type" . "image/*")
230                                ("test"   . (eq (device-type) 'x))
231                                ("needsx11")))
232                       ))
233     ("text"        . (
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)
243                                      ("test"   . (fboundp
244                                                   'enriched-decode-region))
245                                      ("type"   . "text/enriched")))
246                       ("html"  . (("viewer" . w3-prepare-buffer)
247                                   ("test"   . (fboundp 'w3-prepare-buffer))
248                                   ("type"   . "text/html")))
249                       ))
250     ("video"       . (
251                       ("mpeg" . (("viewer" . "mpeg_play %s")
252                                  ("type"   . "video/mpeg")
253                                  ("test"   . (eq (device-type) 'x))
254                                  ("needsx11")))
255                       ))
256     ("x-world"     . (
257                       ("x-vrml" . (("viewer"  . "webspace -remote %s -URL %u")
258                                    ("type"    . "x-world/x-vrml")
259                                    ("description"
260                                     "VRML document")))))
261     ("archive"     . (
262                       ("tar"  . (("viewer" . tar-mode)
263                                  ("type" . "archive/tar")
264                                  ("test" . (fboundp 'tar-mode))))
265                       ))
266     )
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)
270
271 Which looks like:
272 -----------------
273 (
274  (\"application\"
275   (\"postscript\" . <info>)
276  )
277  (\"text\"
278   (\"plain\" . <info>)
279  )
280 )
281
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\")
288 )
289
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.
294
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
298 not.")
299
300 (defvar mm-content-transfer-encodings
301   '(("base64"     . base64-decode-region)
302     ("7bit"       . ignore)
303     ("8bit"       . ignore)
304     ("binary"     . ignore)
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)
311     )
312   "*An assoc list of content-transfer-encodings and how to decode them.")
313
314 (defvar mm-download-directory nil
315   "*Where downloaded files should go by default.")
316
317 (defvar mm-temporary-directory (or (getenv "TMPDIR") "/tmp")
318   "*Where temporary files go.")
319
320 \f
321 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
322 ;;; A few things from w3 and url, just in case this is used without them
323 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
324
325 (defun mm-generate-unique-filename (&optional fmt)
326   "Generate a unique filename in mm-temporary-directory"
327   (if (not fmt)
328       (let ((base (format "mm-tmp.%d" (user-real-uid)))
329             (fname "")
330             (x 0))
331         (setq fname (format "%s%d" base x))
332         (while (file-exists-p
333                 (expand-file-name fname mm-temporary-directory))
334           (setq x (1+ x)
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))))
338           (fname "")
339           (x 0))
340       (setq fname (format fmt (concat base (int-to-string x))))
341       (while (file-exists-p
342               (expand-file-name fname mm-temporary-directory))
343         (setq x (1+ x)
344               fname (format fmt (concat base (int-to-string x)))))
345       (expand-file-name fname mm-temporary-directory))))
346
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)
351     (if (consp tree)
352         (cons (mm-copy-tree (car tree))
353               (mm-copy-tree (cdr tree)))
354       (if (vectorp tree)
355           (let* ((new (copy-sequence tree))
356                  (i (1- (length new))))
357             (while (>= i 0)
358               (aset new i (mm-copy-tree (aref new i)))
359               (setq i (1- i)))
360             new)
361         tree))))
362
363 ;LMI was here
364 ;(require 'mule-sysdp)
365
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))
377                                   nil
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))
384
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))
389     (emacs-lisp-mode)))
390
391 \f
392 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
393 ;;; The mailcap parser
394 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
395 (defun mm-viewer-unescape (format &optional filename url)
396   (save-excursion
397     (set-buffer (get-buffer-create " *mm-parse*"))
398     (erase-buffer)
399     (insert format)
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)
404          (case escape
405            (?% (insert "%"))
406            (?s (insert (or filename "\"\"")))
407            (?u (insert (or url "\"\""))))))
408     (buffer-string)))
409
410 (defun mm-in-assoc (elt list)
411   ;; Check to see if ELT matches any of the regexps in the car elements of LIST
412   (let (rslt)
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)))
418     rslt))
419
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)))
425
426 (defun mm-parse-mailcaps (&optional path)
427   ;; Parse out all the mailcaps specified in a unix-style path string PATH
428   (cond
429    (path nil)
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")
433                           ";")))
434    (t (setq path (mapconcat 'expand-file-name
435                             '("~/.mailcap"
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))
442                                           ?;
443                                         ?:))))
444         fname)
445     (while fnames
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)))))
450
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
458         )
459     (save-excursion
460       (set-buffer (get-buffer-create " *mailcap*"))
461       (erase-buffer)
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))
472       (while (not (eobp))
473         (skip-chars-forward " \t\n")
474         (setq save-pos (point)
475               info nil)
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))
483         (setq minor
484               (cond
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) ?')
496             (setq viewer (progn
497                            (narrow-to-region (1+ save-pos) (point))
498                            (goto-char (point-min))
499                            (prog1
500                                (read (current-buffer))
501                              (goto-char (point-max))
502                              (widen))))
503           (setq viewer (buffer-substring save-pos (point))))
504         (setq save-pos (point))
505         (end-of-line)
506         (setq info (nconc (list (cons "viewer" viewer)
507                                 (cons "type" (concat major "/"
508                                                      (if (string= minor ".*")
509                                                          "*" minor))))
510                           (mm-parse-mailcap-extras save-pos (point))))
511         (mm-mailcap-entry-passes-test info)
512         (mm-add-mailcap-entry major minor info)))))
513
514 (defun mm-parse-mailcap-extras (st nd)
515   ;; Grab all the extra stuff from a mailcap entry
516   (let (
517         name                            ; From name=
518         value                           ; its value
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?
523         )
524     (save-restriction
525       (narrow-to-region st nd)
526       (goto-char (point-min))
527       (skip-chars-forward " \n\t;")
528       (while (not (eobp))
529         (setq done nil)
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
537             (setq value nil)
538           (skip-chars-forward " \t\n=")
539           (setq val-pos (point))
540           (if (memq (char-after val-pos) '(?\" ?'))
541               (progn
542                 (setq val-pos (1+ val-pos))
543                 (condition-case nil
544                     (progn
545                       (forward-sexp 1)
546                       (backward-char 1))
547                   (error (goto-char (point-max)))))
548             (while (not done)
549               (skip-chars-forward "^;")
550               (if (= (or (char-after (1- (point))) 0) ?\\ )
551                   (progn
552                     (subst-char-in-region (1- (point)) (point) ?\\ ? )
553                     (skip-chars-forward ";"))
554                 (setq done t))))
555           (setq value (buffer-substring val-pos (point))))
556         (setq results (cons (cons name value) results)))
557       results)))  
558
559 (defun mm-string-to-tokens (str &optional delim)
560   "Return a list of words from the string STR"
561   (setq delim (or delim ? ))
562   (let (results y)
563     (mapcar
564      (function
565       (lambda (x)
566         (cond
567          ((and (= x delim) y) (setq results (cons y results) y nil))
568          ((/= x delim) (setq y (concat y (char-to-string x))))
569          (t nil)))) str)
570     (nreverse (cons y results))))
571
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
577         )
578     (setq status (and test (mm-string-to-tokens (cdr test))))
579     (if (and (assoc "needsx11" info) (not (getenv "DISPLAY")))
580         (setq status nil)
581       (cond
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)))
592        (test nil)
593        (t nil)))
594     (and test (listp test) (setcdr test status))))
595
596 (defun mm-parse-args (st &optional nd nodowncase)
597   ;; Return an assoc list of attribute/value pairs from an RFC822-type string
598   (let (
599         name                            ; From name=
600         value                           ; its value
601         results                         ; Assoc list of results
602         name-pos                        ; Start of XXXX= position
603         val-pos                         ; Start of value position
604         )
605     (save-excursion
606       (if (stringp st)
607           (progn
608             (set-buffer (get-buffer-create " *mm-temp*"))
609             (set-syntax-table mm-parse-args-syntax-table)
610             (erase-buffer)
611             (insert st)
612             (setq st (point-min)
613                   nd (point-max)))
614         (set-syntax-table mm-parse-args-syntax-table))
615       (save-restriction
616         (narrow-to-region st nd)
617         (goto-char (point-min))
618         (while (not (eobp))
619           (skip-chars-forward "; \n\t")
620           (setq name-pos (point))
621           (skip-chars-forward "^ \n\t=;")
622           (if (not nodowncase)
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
627               (setq value nil)
628             (skip-chars-forward " \t\n=")
629             (setq val-pos (point)
630                   value
631                   (cond
632                    ((or (= (or (char-after val-pos) 0) ?\")
633                         (= (or (char-after val-pos) 0) ?'))
634                     (buffer-substring (1+ val-pos)
635                                       (condition-case ()
636                                           (prog2
637                                               (forward-sexp 1)
638                                               (1- (point))
639                                             (skip-chars-forward "\""))
640                                         (error
641                                          (skip-chars-forward "^ \t\n")
642                                          (point)))))
643                    (t
644                     (buffer-substring val-pos
645                                       (progn
646                                         (skip-chars-forward "^;")
647                                         (skip-chars-backward " \t")
648                                         (point)))))))
649           (setq results (cons (cons name value) results))
650           (skip-chars-forward "; \n\t"))
651         results))))
652 \f
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
658   (let ((exact '())
659         (wildcard '()))
660     (while major
661       (cond
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))))
668
669 (defun mm-unescape-mime-test (test type-info)
670   (let ((buff (get-buffer-create " *unescape*"))
671         save-pos save-chr subst)
672     (cond
673      ((symbolp test) test)
674      ((and (listp test) (symbolp (car test))) test)
675      ((or (stringp test)
676           (and (listp test) (stringp (car test))
677                (setq test (mapconcat 'identity test " "))))
678       (save-excursion
679         (set-buffer buff)
680         (erase-buffer)
681         (insert test)
682         (goto-char (point-min))
683         (while (not (eobp))
684           (skip-chars-forward "^%")
685           (if (/= (- (point)
686                      (progn (skip-chars-backward "\\\\")
687                             (point)))
688                   0) ; It is an escaped %
689               (progn
690                 (delete-char 1)
691                 (skip-chars-forward "%."))
692             (setq save-pos (point))
693             (skip-chars-forward "%")
694             (setq save-chr (char-after (point)))
695             (cond
696              ((null save-chr) nil)
697              ((= save-chr ?t)
698               (delete-region save-pos (progn (forward-char 1) (point)))
699               (insert (or (cdr (assoc "type" type-info)) "\"\"")))
700              ((= save-chr ?M)
701               (delete-region save-pos (progn (forward-char 1) (point)))
702               (insert "\"\""))
703              ((= save-chr ?n)
704               (delete-region save-pos (progn (forward-char 1) (point)))
705               (insert "\"\""))
706              ((= save-chr ?F)
707               (delete-region save-pos (progn (forward-char 1) (point)))
708               (insert "\"\""))
709              ((= save-chr ?{)
710               (forward-char 1)
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)) "\"\"")))
716              (t nil))))
717         (buffer-string)))
718      (t (error "Bad value to mm-unescape-mime-test. %s" test)))))
719
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 "~/"))
727          status
728          parsed-test
729         )
730     (cond
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
735            (fboundp test))
736       (funcall test type-info))
737      ((and (symbolp test)               ; Lisp variable as test
738            (boundp test))
739       (symbol-value test))
740      ((and (listp test)                 ; List to be eval'd
741            (symbolp (car test)))
742       (eval test))
743      (t
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))
747       (= 0 status)))))
748
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
752         (setq mm-mime-data
753               (cons (cons major (list (cons minor info)))
754                     mm-mime-data))
755       (let ((cur-minor (assoc minor old-major)))
756         (cond
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))
763          (t
764           (setcdr old-major (cons (cons minor info) (cdr old-major)))))))))
765
766 \f
767 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
768 ;;; The main whabbo
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)) "")))))
776     (cond
777      ((and x-lisp (not y-lisp))
778       t)
779      ((and (not y-lisp) x-wild (not y-wild))
780       t)
781      ((and (not x-wild) y-wild)
782       t)
783      (t nil))))
784
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
789
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
795 viewer is returned."
796   (let (
797         major                           ; Major encoding (text, etc)
798         minor                           ; Minor encoding (html, etc)
799         info                            ; Other info
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
807         )
808     (save-excursion
809       (cond
810        ((null st)
811         (set-buffer (get-buffer-create " *mimeparse*"))
812         (erase-buffer)
813         (insert "text/plain")
814         (setq st (point-min)))
815        ((stringp st)
816         (set-buffer (get-buffer-create " *mimeparse*"))
817         (erase-buffer)
818         (insert st)
819         (setq st (point-min)))
820        ((null nd)
821         (narrow-to-region st (progn (goto-char st) (end-of-line) (point))))
822        (t (narrow-to-region st nd)))
823       (goto-char st)
824       (skip-chars-forward ": \t\n")
825       (buffer-enable-undo)
826       (setq viewer
827             (catch 'mm-exit
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)))
839               (if (not
840                    (setq viewers (mm-possible-viewers major-info minor)))
841                   (throw 'mm-exit nil))
842               (skip-chars-forward "; \t")
843               (if (eolp)
844                   nil                           ; No qualifiers
845                 (setq save-pos (point))
846                 (end-of-line)
847                 (setq info (mm-parse-args save-pos (point)))
848                 )
849               (while viewers
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))
854               (car passed)))
855       (if (and (stringp (cdr (assoc "viewer" viewer)))
856                passed)
857           (setq viewer (car passed)))
858       (widen)
859       (cond
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))
864        ((stringp request)
865         (if (or (string= request "test") (string= request "viewer"))
866             (mm-unescape-mime-test (cdr-safe (assoc request viewer)) info)))
867        (t
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))))
874         viewer)))))
875
876 \f
877 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
878 ;;; Experimental MIME-types parsing
879 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
880 (defvar mm-mime-extensions
881   '(
882     (""          . "text/plain")
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")
970     )
971   "*An assoc list of file extensions and the MIME content-types they
972 correspond to.")
973
974 (defun mm-parse-mimetypes (&optional path)
975   ;; Parse out all the mimetypes specified in a unix-style path string PATH
976   (cond
977    (path nil)
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
983                             '("~/.mime-types"
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))
991                                           ?;
992                                         ?:))))
993         fname)
994     (while fnames
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)))))
999
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
1005         )
1006     (save-excursion
1007       (set-buffer (get-buffer-create " *mime-types*"))
1008       (erase-buffer)
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))
1017       (while (not (eobp))
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)))
1023         (while (not (eolp))
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)))
1028         (while extns
1029           (setq mm-mime-extensions
1030                 (cons
1031                  (cons (if (= (string-to-char (car extns)) ?.)
1032                            (car extns)
1033                          (concat "." (car extns))) type) mm-mime-extensions)
1034                 extns (cdr extns)))))))
1035
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)))
1042
1043 \f
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*"))
1054          (typeit (not ctyp))
1055          (retval "")
1056          (usef nil))
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))
1061             usef t))
1062     (call-process shell-file-name nil
1063                   (if usef nil buff)
1064                   nil shell-command-switch comp)
1065     (setq retval
1066           (concat
1067            (if typeit (concat "Content-type: " type "\r\n\r\n") "")
1068            (if usef
1069                (save-excursion
1070                  (set-buffer buff)
1071                  (erase-buffer)
1072                  (insert-file-contents fnam)
1073                  (buffer-string))
1074              (save-excursion
1075                (set-buffer buff)
1076                (buffer-string)))
1077            "\r\n"))
1078     retval))    
1079 \f
1080 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1081 ;;; Misc.
1082 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1083 (defun mm-type-to-file (type)
1084   "Return the file extension for content-type TYPE"
1085   (rassoc type mm-mime-extensions))
1086
1087 \f
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)
1099     (condition-case ()
1100         (delete-file fname)
1101       (error nil))))
1102     
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))
1107          (nd (progn
1108                (goto-char (point-min))
1109                (skip-chars-forward " \t\n")
1110                (if (re-search-forward "^\r*$" nil t)
1111                    (1+ (point))
1112                  (point-max))))
1113          save-pos
1114          status
1115          hname
1116          hvalu
1117          result
1118          search
1119          )
1120     (narrow-to-region st (min nd (point-max)))
1121     (goto-char (point-min))
1122     (while (not (eobp))
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")
1131       (setq search t)
1132       (while search
1133         (skip-chars-forward "^\n\r")
1134         (save-excursion
1135           (skip-chars-forward "\n\r")
1136           
1137           (setq search
1138                 (string-match "[ \t]"
1139                               (char-to-string
1140                                (or (char-after (point)) ?a)))))
1141         (if search
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))
1146     result))
1147
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*$"))
1153         headers
1154         fname
1155         results)
1156     (save-excursion
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)
1161                               (progn
1162                                 (forward-line 1)
1163                                 (beginning-of-line)
1164                                 (point))))
1165               (nd (set-marker (make-marker)
1166                               (if (re-search-forward sep nil t)
1167                                   (1- (match-beginning 0))
1168                                 (point-max)))))
1169           (narrow-to-region st nd)
1170           (goto-char st)
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)
1180                                         (match-end 1))
1181                              mm-temporary-directory))))
1182           (widen)
1183           (if (assoc "content-transfer-encoding" headers)
1184               (let ((coding (cdr
1185                              (assoc "content-transfer-encoding" headers)))
1186                     (cmd nil))
1187                 (setq coding (and coding (downcase coding))
1188                       cmd (or (cdr (assoc coding
1189                                           mm-content-transfer-encodings))
1190                               (read-string
1191                                (concat "How shall I decode " coding "? ")
1192                                "cat")))
1193                 (if (string= cmd "") (setq cmd "cat"))
1194                 (if (stringp cmd)
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)
1200           (setq results (cons
1201                          (cons
1202                           (cons "mm-filename" fname) headers) results)))))
1203     results))
1204
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]+\\)"
1209                         type)
1210                        (regexp-quote
1211                         (substring type (match-beginning 1) (match-end 1)))))
1212          (parts    (mm-find-available-multiparts boundary)))
1213     (erase-buffer)
1214     (insert "<html>\n"
1215             " <head>\n"
1216             "  <title>Multipart Message</title>\n"
1217             " </head>\n"
1218             " <body>\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"
1223             "   </p>\n"
1224             "   <ul>\n"
1225             (mapconcat 
1226              (function (lambda (x)
1227                          (concat "    <li> <a href=\"file:"
1228                                  (cdr (assoc "mm-filename" x))
1229                                  "\">"
1230                                  (or (cdr (assoc "content-description" x)) "")
1231                                  "--"
1232                                  (or (cdr (assoc "content-type" x))
1233                                      "unknown type")
1234                                  "</a> </li>")))
1235              parts "\n")
1236             "   </ul>\n"
1237             " </body>\n"
1238             "</html>\n"
1239             "<!-- Automatically generated by MM v" mm-version "-->\n")))
1240
1241 (defun mm-multipart-viewer ()
1242   (mm-format-multipart-as-html
1243    (current-buffer)
1244    (cdr (assoc "content-type" url-current-mime-headers)))
1245   (let ((w3-working-buffer (current-buffer)))
1246     (w3-prepare-buffer)))
1247
1248 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1249 ;;; Transfer encodings we can decrypt automatically
1250 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1251 (defun mm-decode-quoted-printable (&optional st nd)
1252   (interactive)
1253   (setq st (or st (point-min))
1254         nd (or nd (point-max)))
1255   (save-restriction
1256     (narrow-to-region st nd)
1257     (save-excursion
1258       (let ((buffer-read-only nil))
1259         (goto-char (point-min))
1260         (while (re-search-forward "=[0-9A-F][0-9A-F]" nil t)
1261           (replace-match 
1262            (char-to-string 
1263             (+
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))))
1269
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))
1274       (- character ?0)
1275     (let ((ch (logior character 32)))
1276       (if (and (>= ch ?a) (<= ch ?f))
1277           (- ch (- ?a 10))
1278         (error (format "Invalid hex digit `%c'." ch))))))
1279
1280
1281 \f
1282 (require 'base64)
1283 (provide 'mm)