Mercurial > hg > xemacs-beta
comparison lisp/w3/mm.el @ 14:9ee227acff29 r19-15b90
Import from CVS: tag r19-15b90
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:48:42 +0200 |
| parents | |
| children | 0293115a14e9 6a378aca36af |
comparison
equal
deleted
inserted
replaced
| 13:13c6d0aaafe5 | 14:9ee227acff29 |
|---|---|
| 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 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 | |
| 99 (defconst mm-version (let ((x "1.96")) | |
| 100 (if (string-match "Revision: \\([^ \t\n]+\\)" x) | |
| 101 (substring x (match-beginning 1) (match-end 1)) | |
| 102 x)) | |
| 103 "Version # of MM package") | |
| 104 | |
| 105 (defvar mm-parse-args-syntax-table | |
| 106 (copy-syntax-table emacs-lisp-mode-syntax-table) | |
| 107 "A syntax table for parsing sgml attributes.") | |
| 108 | |
| 109 (modify-syntax-entry ?' "\"" mm-parse-args-syntax-table) | |
| 110 (modify-syntax-entry ?` "\"" mm-parse-args-syntax-table) | |
| 111 (modify-syntax-entry ?{ "(" mm-parse-args-syntax-table) | |
| 112 (modify-syntax-entry ?} ")" mm-parse-args-syntax-table) | |
| 113 | |
| 114 (defvar mm-mime-data | |
| 115 '( | |
| 116 ("multipart" . ( | |
| 117 ("alternative". (("viewer" . mm-multipart-viewer) | |
| 118 ("type" . "multipart/alternative"))) | |
| 119 ("mixed" . (("viewer" . mm-multipart-viewer) | |
| 120 ("type" . "multipart/mixed"))) | |
| 121 (".*" . (("viewer" . mm-save-binary-file) | |
| 122 ("type" . "multipart/*"))) | |
| 123 ) | |
| 124 ) | |
| 125 ("application" . ( | |
| 126 ("octet-stream" . (("viewer" . mm-save-binary-file) | |
| 127 ("type" ."application/octet-stream"))) | |
| 128 ("dvi" . (("viewer" . "open %s") | |
| 129 ("type" . "application/dvi") | |
| 130 ("test" . (eq (device-type) 'ns)))) | |
| 131 ("dvi" . (("viewer" . "xdvi %s") | |
| 132 ("test" . (eq (device-type) 'x)) | |
| 133 ("needsx11") | |
| 134 ("type" . "application/dvi"))) | |
| 135 ("dvi" . (("viewer" . "dvitty %s") | |
| 136 ("test" . (not (getenv "DISPLAY"))) | |
| 137 ("type" . "application/dvi"))) | |
| 138 ("emacs-lisp" . (("viewer" . mm-maybe-eval) | |
| 139 ("type" . "application/emacs-lisp"))) | |
| 140 ; ("x-tar" . (("viewer" . tar-mode) | |
| 141 ; ("test" . (fboundp 'tar-mode)) | |
| 142 ; ("type" . "application/x-tar"))) | |
| 143 ("x-tar" . (("viewer" . mm-save-binary-file) | |
| 144 ("type" . "application/x-tar"))) | |
| 145 ("x-latex" . (("viewer" . tex-mode) | |
| 146 ("test" . (fboundp 'tex-mode)) | |
| 147 ("type" . "application/x-latex"))) | |
| 148 ("x-tex" . (("viewer" . tex-mode) | |
| 149 ("test" . (fboundp 'tex-mode)) | |
| 150 ("type" . "application/x-tex"))) | |
| 151 ("latex" . (("viewer" . tex-mode) | |
| 152 ("test" . (fboundp 'tex-mode)) | |
| 153 ("type" . "application/latex"))) | |
| 154 ("tex" . (("viewer" . tex-mode) | |
| 155 ("test" . (fboundp 'tex-mode)) | |
| 156 ("type" . "application/tex"))) | |
| 157 ("texinfo" . (("viewer" . texinfo-mode) | |
| 158 ("test" . (fboundp 'texinfo-mode)) | |
| 159 ("type" . "application/tex"))) | |
| 160 ("zip" . (("viewer" . mm-save-binary-file) | |
| 161 ("type" . "application/zip") | |
| 162 ("copiousoutput"))) | |
| 163 ("pdf" . (("viewer" . "acroread %s") | |
| 164 ("type" . "application/pdf"))) | |
| 165 ("postscript" . (("viewer" . "open %s") | |
| 166 ("type" . "application/postscript") | |
| 167 ("test" . (eq (device-type) 'ns)))) | |
| 168 ("postscript" . (("viewer" . "ghostview %s") | |
| 169 ("type" . "application/postscript") | |
| 170 ("test" . (eq (device-type) 'x)) | |
| 171 ("needsx11"))) | |
| 172 ("postscript" . (("viewer" . "ps2ascii %s") | |
| 173 ("type" . "application/postscript") | |
| 174 ("test" . (not (getenv "DISPLAY"))) | |
| 175 ("copiousoutput"))) | |
| 176 ("x-www-pem-reply" . | |
| 177 (("viewer" . (w3-decode-pgp/pem "pem")) | |
| 178 ("test" . (fboundp 'w3-decode-pgp/pem)) | |
| 179 ("type" . "application/x-www-pem-reply") | |
| 180 )) | |
| 181 ("x-www-pgp-reply" . | |
| 182 (("viewer" . (w3-decode-pgp/pem "pgp")) | |
| 183 ("test" . (fboundp 'w3-decode-pgp/pem)) | |
| 184 ("type" . "application/x-www-pgp-reply"))) | |
| 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) | |
| 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 "/tmp" | |
| 318 "*Where temporary files go.") | |
| 319 | |
| 320 | |
| 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 (require 'mule-sysdp) | |
| 364 | |
| 365 (if (not (fboundp 'w3-save-binary-file)) | |
| 366 (defun mm-save-binary-file () | |
| 367 ;; Ok, this is truly fucked. In XEmacs, if you use the mouse to select | |
| 368 ;; a URL that gets saved via this function, read-file-name will pop up a | |
| 369 ;; dialog box for file selection. For some reason which buffer we are in | |
| 370 ;; gets royally screwed (even with save-excursions and the whole nine | |
| 371 ;; yards). SO, we just keep the old buffer name around and away we go. | |
| 372 (let ((old-buff (current-buffer)) | |
| 373 (file (read-file-name "Filename to save as: " | |
| 374 (or mm-download-directory "~/") | |
| 375 (file-name-nondirectory (url-view-url t)) | |
| 376 nil | |
| 377 (file-name-nondirectory (url-view-url t)))) | |
| 378 (require-final-newline nil)) | |
| 379 (set-buffer old-buff) | |
| 380 (mule-write-region-no-coding-system (point-min) (point-max) file) | |
| 381 (kill-buffer (current-buffer)))) | |
| 382 (fset 'mm-save-binary-file 'w3-save-binary-file)) | |
| 383 | |
| 384 (defun mm-maybe-eval () | |
| 385 "Maybe evaluate a buffer of emacs lisp code" | |
| 386 (if (yes-or-no-p "This is emacs-lisp code, evaluate it? ") | |
| 387 (eval-buffer (current-buffer)) | |
| 388 (emacs-lisp-mode))) | |
| 389 | |
| 390 | |
| 391 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 392 ;;; The mailcap parser | |
| 393 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 394 (defun mm-viewer-unescape (format &optional filename url) | |
| 395 (save-excursion | |
| 396 (set-buffer (get-buffer-create " *mm-parse*")) | |
| 397 (erase-buffer) | |
| 398 (insert format) | |
| 399 (goto-char (point-min)) | |
| 400 (while (re-search-forward "%\\(.\\)" nil t) | |
| 401 (let ((escape (aref (match-string 1) 0))) | |
| 402 (replace-match "" t t) | |
| 403 (case escape | |
| 404 (?% (insert "%")) | |
| 405 (?s (insert (or filename "\"\""))) | |
| 406 (?u (insert (or url "\"\"")))))) | |
| 407 (buffer-string))) | |
| 408 | |
| 409 (defun mm-in-assoc (elt list) | |
| 410 ;; Check to see if ELT matches any of the regexps in the car elements of LIST | |
| 411 (let (rslt) | |
| 412 (while (and list (not rslt)) | |
| 413 (and (car (car list)) | |
| 414 (string-match (car (car list)) elt) | |
| 415 (setq rslt (car list))) | |
| 416 (setq list (cdr list))) | |
| 417 rslt)) | |
| 418 | |
| 419 (defun mm-replace-regexp (regexp to-string) | |
| 420 ;; Quiet replace-regexp. | |
| 421 (goto-char (point-min)) | |
| 422 (while (re-search-forward regexp nil t) | |
| 423 (replace-match to-string t nil))) | |
| 424 | |
| 425 (defun mm-parse-mailcaps (&optional path) | |
| 426 ;; Parse out all the mailcaps specified in a unix-style path string PATH | |
| 427 (cond | |
| 428 (path nil) | |
| 429 ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS"))) | |
| 430 ((memq system-type '(ms-dos ms-windows windows-nt)) | |
| 431 (setq path (mapconcat 'expand-file-name '("~/mail.cap" "~/etc/mail.cap") | |
| 432 ";"))) | |
| 433 (t (setq path (concat "/etc/mailcap:/usr/etc/mailcap:" | |
| 434 "/usr/local/etc/mailcap:" | |
| 435 (expand-file-name "~/.mailcap"))))) | |
| 436 (let ((fnames (mm-string-to-tokens path | |
| 437 (if (memq system-type | |
| 438 '(ms-dos ms-windows windows-nt)) | |
| 439 ?; | |
| 440 ?:))) fname) | |
| 441 (while fnames | |
| 442 (setq fname (car fnames)) | |
| 443 (if (and (file-exists-p fname) (file-readable-p fname)) | |
| 444 (mm-parse-mailcap (car fnames))) | |
| 445 (setq fnames (cdr fnames))))) | |
| 446 | |
| 447 (defun mm-parse-mailcap (fname) | |
| 448 ;; Parse out the mailcap file specified by FNAME | |
| 449 (let (major ; The major mime type (image/audio/etc) | |
| 450 minor ; The minor mime type (gif, basic, etc) | |
| 451 save-pos ; Misc saved positions used in parsing | |
| 452 viewer ; How to view this mime type | |
| 453 info ; Misc info about this mime type | |
| 454 ) | |
| 455 (save-excursion | |
| 456 (set-buffer (get-buffer-create " *mailcap*")) | |
| 457 (erase-buffer) | |
| 458 (insert-file-contents fname) | |
| 459 (set-syntax-table mm-parse-args-syntax-table) | |
| 460 (mm-replace-regexp "#.*" "") ; Remove all comments | |
| 461 (mm-replace-regexp "\n+" "\n") ; And blank lines | |
| 462 (mm-replace-regexp "\\\\[ \t\n]+" " ") ; And collapse spaces | |
| 463 (mm-replace-regexp (concat (regexp-quote "\\") "[ \t]*\n") "") | |
| 464 (goto-char (point-max)) | |
| 465 (skip-chars-backward " \t\n") | |
| 466 (delete-region (point) (point-max)) | |
| 467 (goto-char (point-min)) | |
| 468 (while (not (eobp)) | |
| 469 (skip-chars-forward " \t\n") | |
| 470 (setq save-pos (point) | |
| 471 info nil) | |
| 472 (skip-chars-forward "^/;") | |
| 473 (downcase-region save-pos (point)) | |
| 474 (setq major (buffer-substring save-pos (point))) | |
| 475 (skip-chars-forward "/ \t\n") | |
| 476 (setq save-pos (point)) | |
| 477 (skip-chars-forward "^;") | |
| 478 (downcase-region save-pos (point)) | |
| 479 (setq minor | |
| 480 (cond | |
| 481 ((= ?* (or (char-after save-pos) 0)) ".*") | |
| 482 ((= (point) save-pos) ".*") | |
| 483 (t (buffer-substring save-pos (point))))) | |
| 484 (skip-chars-forward "; \t\n") | |
| 485 ;;; Got the major/minor chunks, now for the viewers/etc | |
| 486 ;;; The first item _must_ be a viewer, according to the | |
| 487 ;;; RFC for mailcap files (#1343) | |
| 488 (skip-chars-forward "; \t\n") | |
| 489 (setq save-pos (point)) | |
| 490 (skip-chars-forward "^;\n") | |
| 491 (if (= (or (char-after save-pos) 0) ?') | |
| 492 (setq viewer (progn | |
| 493 (narrow-to-region (1+ save-pos) (point)) | |
| 494 (goto-char (point-min)) | |
| 495 (prog1 | |
| 496 (read (current-buffer)) | |
| 497 (goto-char (point-max)) | |
| 498 (widen)))) | |
| 499 (setq viewer (buffer-substring save-pos (point)))) | |
| 500 (setq save-pos (point)) | |
| 501 (end-of-line) | |
| 502 (setq info (nconc (list (cons "viewer" viewer) | |
| 503 (cons "type" (concat major "/" | |
| 504 (if (string= minor ".*") | |
| 505 "*" minor)))) | |
| 506 (mm-parse-mailcap-extras save-pos (point)))) | |
| 507 (mm-mailcap-entry-passes-test info) | |
| 508 (mm-add-mailcap-entry major minor info))))) | |
| 509 | |
| 510 (defun mm-parse-mailcap-extras (st nd) | |
| 511 ;; Grab all the extra stuff from a mailcap entry | |
| 512 (let ( | |
| 513 name ; From name= | |
| 514 value ; its value | |
| 515 results ; Assoc list of results | |
| 516 name-pos ; Start of XXXX= position | |
| 517 val-pos ; Start of value position | |
| 518 done ; Found end of \'d ;s? | |
| 519 ) | |
| 520 (save-restriction | |
| 521 (narrow-to-region st nd) | |
| 522 (goto-char (point-min)) | |
| 523 (skip-chars-forward " \n\t;") | |
| 524 (while (not (eobp)) | |
| 525 (setq done nil) | |
| 526 (skip-chars-forward " \";\n\t") | |
| 527 (setq name-pos (point)) | |
| 528 (skip-chars-forward "^ \n\t=") | |
| 529 (downcase-region name-pos (point)) | |
| 530 (setq name (buffer-substring name-pos (point))) | |
| 531 (skip-chars-forward " \t\n") | |
| 532 (if (/= (or (char-after (point)) 0) ?=) ; There is no value | |
| 533 (setq value nil) | |
| 534 (skip-chars-forward " \t\n=") | |
| 535 (setq val-pos (point)) | |
| 536 (if (memq (char-after val-pos) '(?\" ?')) | |
| 537 (progn | |
| 538 (setq val-pos (1+ val-pos)) | |
| 539 (condition-case nil | |
| 540 (progn | |
| 541 (forward-sexp 1) | |
| 542 (backward-char 1)) | |
| 543 (error (goto-char (point-max))))) | |
| 544 (while (not done) | |
| 545 (skip-chars-forward "^;") | |
| 546 (if (= (or (char-after (1- (point))) 0) ?\\ ) | |
| 547 (progn | |
| 548 (subst-char-in-region (1- (point)) (point) ?\\ ? ) | |
| 549 (skip-chars-forward ";")) | |
| 550 (setq done t)))) | |
| 551 (setq value (buffer-substring val-pos (point)))) | |
| 552 (setq results (cons (cons name value) results))) | |
| 553 results))) | |
| 554 | |
| 555 (defun mm-string-to-tokens (str &optional delim) | |
| 556 "Return a list of words from the string STR" | |
| 557 (setq delim (or delim ? )) | |
| 558 (let (results y) | |
| 559 (mapcar | |
| 560 (function | |
| 561 (lambda (x) | |
| 562 (cond | |
| 563 ((and (= x delim) y) (setq results (cons y results) y nil)) | |
| 564 ((/= x delim) (setq y (concat y (char-to-string x)))) | |
| 565 (t nil)))) str) | |
| 566 (nreverse (cons y results)))) | |
| 567 | |
| 568 (defun mm-mailcap-entry-passes-test (info) | |
| 569 ;; Return t iff a mailcap entry passes its test clause or no test | |
| 570 ;; clause is present. | |
| 571 (let (status ; Call-process-regions return value | |
| 572 (test (assoc "test" info)); The test clause | |
| 573 ) | |
| 574 (setq status (and test (mm-string-to-tokens (cdr test)))) | |
| 575 (if (and (assoc "needsx11" info) (not (getenv "DISPLAY"))) | |
| 576 (setq status nil) | |
| 577 (cond | |
| 578 ((and (equal (nth 0 status) "test") | |
| 579 (equal (nth 1 status) "-n") | |
| 580 (or (equal (nth 2 status) "$DISPLAY") | |
| 581 (equal (nth 2 status) "\"$DISPLAY\""))) | |
| 582 (setq status (if (getenv "DISPLAY") t nil))) | |
| 583 ((and (equal (nth 0 status) "test") | |
| 584 (equal (nth 1 status) "-z") | |
| 585 (or (equal (nth 2 status) "$DISPLAY") | |
| 586 (equal (nth 2 status) "\"$DISPLAY\""))) | |
| 587 (setq status (if (getenv "DISPLAY") nil t))) | |
| 588 (test nil) | |
| 589 (t nil))) | |
| 590 (and test (listp test) (setcdr test status)))) | |
| 591 | |
| 592 (defun mm-parse-args (st &optional nd nodowncase) | |
| 593 ;; Return an assoc list of attribute/value pairs from an RFC822-type string | |
| 594 (let ( | |
| 595 name ; From name= | |
| 596 value ; its value | |
| 597 results ; Assoc list of results | |
| 598 name-pos ; Start of XXXX= position | |
| 599 val-pos ; Start of value position | |
| 600 ) | |
| 601 (save-excursion | |
| 602 (if (stringp st) | |
| 603 (progn | |
| 604 (set-buffer (get-buffer-create " *mm-temp*")) | |
| 605 (set-syntax-table mm-parse-args-syntax-table) | |
| 606 (erase-buffer) | |
| 607 (insert st) | |
| 608 (setq st (point-min) | |
| 609 nd (point-max))) | |
| 610 (set-syntax-table mm-parse-args-syntax-table)) | |
| 611 (save-restriction | |
| 612 (narrow-to-region st nd) | |
| 613 (goto-char (point-min)) | |
| 614 (while (not (eobp)) | |
| 615 (skip-chars-forward "; \n\t") | |
| 616 (setq name-pos (point)) | |
| 617 (skip-chars-forward "^ \n\t=;") | |
| 618 (if (not nodowncase) | |
| 619 (downcase-region name-pos (point))) | |
| 620 (setq name (buffer-substring name-pos (point))) | |
| 621 (skip-chars-forward " \t\n") | |
| 622 (if (/= (or (char-after (point)) 0) ?=) ; There is no value | |
| 623 (setq value nil) | |
| 624 (skip-chars-forward " \t\n=") | |
| 625 (setq val-pos (point) | |
| 626 value | |
| 627 (cond | |
| 628 ((or (= (or (char-after val-pos) 0) ?\") | |
| 629 (= (or (char-after val-pos) 0) ?')) | |
| 630 (buffer-substring (1+ val-pos) | |
| 631 (condition-case () | |
| 632 (prog2 | |
| 633 (forward-sexp 1) | |
| 634 (1- (point)) | |
| 635 (skip-chars-forward "\"")) | |
| 636 (error | |
| 637 (skip-chars-forward "^ \t\n") | |
| 638 (point))))) | |
| 639 (t | |
| 640 (buffer-substring val-pos | |
| 641 (progn | |
| 642 (skip-chars-forward "^;") | |
| 643 (skip-chars-backward " \t") | |
| 644 (point))))))) | |
| 645 (setq results (cons (cons name value) results)) | |
| 646 (skip-chars-forward "; \n\t")) | |
| 647 results)))) | |
| 648 | |
| 649 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 650 ;;; The action routines. | |
| 651 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 652 (defun mm-possible-viewers (major minor) | |
| 653 ;; Return a list of possible viewers from MAJOR for minor type MINOR | |
| 654 (let ((exact '()) | |
| 655 (wildcard '())) | |
| 656 (while major | |
| 657 (cond | |
| 658 ((equal (car (car major)) minor) | |
| 659 (setq exact (cons (cdr (car major)) exact))) | |
| 660 ((string-match (car (car major)) minor) | |
| 661 (setq wildcard (cons (cdr (car major)) wildcard)))) | |
| 662 (setq major (cdr major))) | |
| 663 (nconc (nreverse exact) (nreverse wildcard)))) | |
| 664 | |
| 665 (defun mm-unescape-mime-test (test type-info) | |
| 666 (let ((buff (get-buffer-create " *unescape*")) | |
| 667 save-pos save-chr subst) | |
| 668 (cond | |
| 669 ((symbolp test) test) | |
| 670 ((and (listp test) (symbolp (car test))) test) | |
| 671 ((or (stringp test) | |
| 672 (and (listp test) (stringp (car test)) | |
| 673 (setq test (mapconcat 'identity test " ")))) | |
| 674 (save-excursion | |
| 675 (set-buffer buff) | |
| 676 (erase-buffer) | |
| 677 (insert test) | |
| 678 (goto-char (point-min)) | |
| 679 (while (not (eobp)) | |
| 680 (skip-chars-forward "^%") | |
| 681 (if (/= (- (point) | |
| 682 (progn (skip-chars-backward "\\\\") | |
| 683 (point))) | |
| 684 0) ; It is an escaped % | |
| 685 (progn | |
| 686 (delete-char 1) | |
| 687 (skip-chars-forward "%.")) | |
| 688 (setq save-pos (point)) | |
| 689 (skip-chars-forward "%") | |
| 690 (setq save-chr (char-after (point))) | |
| 691 (cond | |
| 692 ((null save-chr) nil) | |
| 693 ((= save-chr ?t) | |
| 694 (delete-region save-pos (progn (forward-char 1) (point))) | |
| 695 (insert (or (cdr (assoc "type" type-info)) "\"\""))) | |
| 696 ((= save-chr ?M) | |
| 697 (delete-region save-pos (progn (forward-char 1) (point))) | |
| 698 (insert "\"\"")) | |
| 699 ((= save-chr ?n) | |
| 700 (delete-region save-pos (progn (forward-char 1) (point))) | |
| 701 (insert "\"\"")) | |
| 702 ((= save-chr ?F) | |
| 703 (delete-region save-pos (progn (forward-char 1) (point))) | |
| 704 (insert "\"\"")) | |
| 705 ((= save-chr ?{) | |
| 706 (forward-char 1) | |
| 707 (skip-chars-forward "^}") | |
| 708 (downcase-region (+ 2 save-pos) (point)) | |
| 709 (setq subst (buffer-substring (+ 2 save-pos) (point))) | |
| 710 (delete-region save-pos (1+ (point))) | |
| 711 (insert (or (cdr (assoc subst type-info)) "\"\""))) | |
| 712 (t nil)))) | |
| 713 (buffer-string))) | |
| 714 (t (error "Bad value to mm-unescape-mime-test. %s" test))))) | |
| 715 | |
| 716 (defun mm-viewer-passes-test (viewer-info type-info) | |
| 717 ;; Return non-nil iff the viewer specified by VIEWER-INFO passes its | |
| 718 ;; test clause (if any). | |
| 719 (let* ((test-info (assoc "test" viewer-info)) | |
| 720 (test (cdr test-info)) | |
| 721 (viewer (cdr (assoc "viewer" viewer-info))) | |
| 722 status | |
| 723 parsed-test | |
| 724 ) | |
| 725 (cond | |
| 726 ((not test-info) t) ; No test clause | |
| 727 ((not test) nil) ; Already failed test | |
| 728 ((eq test t) t) ; Already passed test | |
| 729 ((and (symbolp test) ; Lisp function as test | |
| 730 (fboundp test)) | |
| 731 (funcall test type-info)) | |
| 732 ((and (symbolp test) ; Lisp variable as test | |
| 733 (boundp test)) | |
| 734 (symbol-value test)) | |
| 735 ((and (listp test) ; List to be eval'd | |
| 736 (symbolp (car test))) | |
| 737 (eval test)) | |
| 738 (t | |
| 739 (setq test (mm-unescape-mime-test test type-info) | |
| 740 test (list "/bin/sh" nil nil nil "-c" test) | |
| 741 status (apply 'call-process test)) | |
| 742 (= 0 status))))) | |
| 743 | |
| 744 (defun mm-add-mailcap-entry (major minor info) | |
| 745 (let ((old-major (assoc major mm-mime-data))) | |
| 746 (if (null old-major) ; New major area | |
| 747 (setq mm-mime-data | |
| 748 (cons (cons major (list (cons minor info))) | |
| 749 mm-mime-data)) | |
| 750 (let ((cur-minor (assoc minor old-major))) | |
| 751 (cond | |
| 752 ((or (null cur-minor) ; New minor area, or | |
| 753 (assoc "test" info)) ; Has a test, insert at beginning | |
| 754 (setcdr old-major (cons (cons minor info) (cdr old-major)))) | |
| 755 ((and (not (assoc "test" info)); No test info, replace completely | |
| 756 (not (assoc "test" cur-minor))) | |
| 757 (setcdr cur-minor info)) | |
| 758 (t | |
| 759 (setcdr old-major (cons (cons minor info) (cdr old-major))))))))) | |
| 760 | |
| 761 | |
| 762 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 763 ;;; The main whabbo | |
| 764 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 765 (defun mm-viewer-lessp (x y) | |
| 766 ;; Return t iff viewer X is more desirable than viewer Y | |
| 767 (let ((x-wild (string-match "[*?]" (or (cdr-safe (assoc "type" x)) ""))) | |
| 768 (y-wild (string-match "[*?]" (or (cdr-safe (assoc "type" y)) ""))) | |
| 769 (x-lisp (not (stringp (or (cdr-safe (assoc "viewer" x)) "")))) | |
| 770 (y-lisp (not (stringp (or (cdr-safe (assoc "viewer" y)) ""))))) | |
| 771 (cond | |
| 772 ((and x-lisp (not y-lisp)) | |
| 773 t) | |
| 774 ((and (not y-lisp) x-wild (not y-wild)) | |
| 775 t) | |
| 776 ((and (not x-wild) y-wild) | |
| 777 t) | |
| 778 (t nil)))) | |
| 779 | |
| 780 (defun mm-mime-info (st &optional nd request) | |
| 781 "Get the mime viewer command for HEADERLINE, return nil if none found. | |
| 782 Expects a complete content-type header line as its argument. This can | |
| 783 be simple like text/html, or complex like text/plain; charset=blah; foo=bar | |
| 784 | |
| 785 Third argument REQUEST specifies what information to return. If it is | |
| 786 nil or the empty string, the viewer (second field of the mailcap | |
| 787 entry) will be returned. If it is a string, then the mailcap field | |
| 788 corresponding to that string will be returned (print, description, | |
| 789 whatever). If a number, then all the information for this specific | |
| 790 viewer is returned." | |
| 791 (let ( | |
| 792 major ; Major encoding (text, etc) | |
| 793 minor ; Minor encoding (html, etc) | |
| 794 info ; Other info | |
| 795 save-pos ; Misc. position during parse | |
| 796 major-info ; (assoc major mm-mime-data) | |
| 797 minor-info ; (assoc minor major-info) | |
| 798 test ; current test proc. | |
| 799 viewers ; Possible viewers | |
| 800 passed ; Viewers that passed the test | |
| 801 viewer ; The one and only viewer | |
| 802 ) | |
| 803 (save-excursion | |
| 804 (cond | |
| 805 ((null st) | |
| 806 (set-buffer (get-buffer-create " *mimeparse*")) | |
| 807 (erase-buffer) | |
| 808 (insert "text/plain") | |
| 809 (setq st (point-min))) | |
| 810 ((stringp st) | |
| 811 (set-buffer (get-buffer-create " *mimeparse*")) | |
| 812 (erase-buffer) | |
| 813 (insert st) | |
| 814 (setq st (point-min))) | |
| 815 ((null nd) | |
| 816 (narrow-to-region st (progn (goto-char st) (end-of-line) (point)))) | |
| 817 (t (narrow-to-region st nd))) | |
| 818 (goto-char st) | |
| 819 (skip-chars-forward ": \t\n") | |
| 820 (buffer-enable-undo) | |
| 821 (setq viewer | |
| 822 (catch 'mm-exit | |
| 823 (setq save-pos (point)) | |
| 824 (skip-chars-forward "^/") | |
| 825 (downcase-region save-pos (point)) | |
| 826 (setq major (buffer-substring save-pos (point))) | |
| 827 (if (not (setq major-info (cdr (assoc major mm-mime-data)))) | |
| 828 (throw 'mm-exit nil)) | |
| 829 (skip-chars-forward "/ \t\n") | |
| 830 (setq save-pos (point)) | |
| 831 (skip-chars-forward "^ \t\n;") | |
| 832 (downcase-region save-pos (point)) | |
| 833 (setq minor (buffer-substring save-pos (point))) | |
| 834 (if (not | |
| 835 (setq viewers (mm-possible-viewers major-info minor))) | |
| 836 (throw 'mm-exit nil)) | |
| 837 (skip-chars-forward "; \t") | |
| 838 (if (eolp) | |
| 839 nil ; No qualifiers | |
| 840 (setq save-pos (point)) | |
| 841 (end-of-line) | |
| 842 (setq info (mm-parse-args save-pos (point))) | |
| 843 ) | |
| 844 (while viewers | |
| 845 (if (mm-viewer-passes-test (car viewers) info) | |
| 846 (setq passed (cons (car viewers) passed))) | |
| 847 (setq viewers (cdr viewers))) | |
| 848 (setq passed (sort (nreverse passed) 'mm-viewer-lessp)) | |
| 849 (car passed))) | |
| 850 (if (and (stringp (cdr (assoc "viewer" viewer))) | |
| 851 passed) | |
| 852 (setq viewer (car passed))) | |
| 853 (widen) | |
| 854 (cond | |
| 855 ((and (null viewer) (not (equal major "default"))) | |
| 856 (mm-mime-info "default" nil request)) | |
| 857 ((or (null request) (equal request "")) | |
| 858 (mm-unescape-mime-test (cdr (assoc "viewer" viewer)) info)) | |
| 859 ((stringp request) | |
| 860 (if (or (string= request "test") (string= request "viewer")) | |
| 861 (mm-unescape-mime-test (cdr-safe (assoc request viewer)) info))) | |
| 862 (t | |
| 863 ;; MUST make a copy *sigh*, else we modify mm-mime-data | |
| 864 (setq viewer (mm-copy-tree viewer)) | |
| 865 (let ((view (assoc "viewer" viewer)) | |
| 866 (test (assoc "test" viewer))) | |
| 867 (if view (setcdr view (mm-unescape-mime-test (cdr view) info))) | |
| 868 (if test (setcdr test (mm-unescape-mime-test (cdr test) info)))) | |
| 869 viewer))))) | |
| 870 | |
| 871 | |
| 872 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 873 ;;; Experimental MIME-types parsing | |
| 874 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 875 (defvar mm-mime-extensions | |
| 876 '( | |
| 877 ("" . "text/plain") | |
| 878 (".abs" . "audio/x-mpeg") | |
| 879 (".aif" . "audio/aiff") | |
| 880 (".aifc" . "audio/aiff") | |
| 881 (".aiff" . "audio/aiff") | |
| 882 (".ano" . "application/x-annotator") | |
| 883 (".au" . "audio/ulaw") | |
| 884 (".avi" . "video/x-msvideo") | |
| 885 (".bcpio" . "application/x-bcpio") | |
| 886 (".bin" . "application/octet-stream") | |
| 887 (".cdf" . "application/x-netcdr") | |
| 888 (".cpio" . "application/x-cpio") | |
| 889 (".csh" . "application/x-csh") | |
| 890 (".dvi" . "application/x-dvi") | |
| 891 (".el" . "application/emacs-lisp") | |
| 892 (".eps" . "application/postscript") | |
| 893 (".etx" . "text/x-setext") | |
| 894 (".exe" . "application/octet-stream") | |
| 895 (".fax" . "image/x-fax") | |
| 896 (".gif" . "image/gif") | |
| 897 (".hdf" . "application/x-hdf") | |
| 898 (".hqx" . "application/mac-binhex40") | |
| 899 (".htm" . "text/html") | |
| 900 (".html" . "text/html") | |
| 901 (".icon" . "image/x-icon") | |
| 902 (".ief" . "image/ief") | |
| 903 (".jpg" . "image/jpeg") | |
| 904 (".macp" . "image/x-macpaint") | |
| 905 (".man" . "application/x-troff-man") | |
| 906 (".me" . "application/x-troff-me") | |
| 907 (".mif" . "application/mif") | |
| 908 (".mov" . "video/quicktime") | |
| 909 (".movie" . "video/x-sgi-movie") | |
| 910 (".mp2" . "audio/x-mpeg") | |
| 911 (".mp2a" . "audio/x-mpeg2") | |
| 912 (".mpa" . "audio/x-mpeg") | |
| 913 (".mpa2" . "audio/x-mpeg2") | |
| 914 (".mpe" . "video/mpeg") | |
| 915 (".mpeg" . "video/mpeg") | |
| 916 (".mpega" . "audio/x-mpeg") | |
| 917 (".mpegv" . "video/mpeg") | |
| 918 (".mpg" . "video/mpeg") | |
| 919 (".mpv" . "video/mpeg") | |
| 920 (".ms" . "application/x-troff-ms") | |
| 921 (".nc" . "application/x-netcdf") | |
| 922 (".nc" . "application/x-netcdf") | |
| 923 (".oda" . "application/oda") | |
| 924 (".pbm" . "image/x-portable-bitmap") | |
| 925 (".pdf" . "application/pdf") | |
| 926 (".pgm" . "image/portable-graymap") | |
| 927 (".pict" . "image/pict") | |
| 928 (".pnm" . "image/x-portable-anymap") | |
| 929 (".ppm" . "image/portable-pixmap") | |
| 930 (".ps" . "application/postscript") | |
| 931 (".qt" . "video/quicktime") | |
| 932 (".ras" . "image/x-raster") | |
| 933 (".rgb" . "image/x-rgb") | |
| 934 (".rtf" . "application/rtf") | |
| 935 (".rtx" . "text/richtext") | |
| 936 (".sh" . "application/x-sh") | |
| 937 (".sit" . "application/x-stuffit") | |
| 938 (".snd" . "audio/basic") | |
| 939 (".src" . "application/x-wais-source") | |
| 940 (".tar" . "archive/tar") | |
| 941 (".tcl" . "application/x-tcl") | |
| 942 (".tcl" . "application/x-tcl") | |
| 943 (".tex" . "application/x-tex") | |
| 944 (".texi" . "application/texinfo") | |
| 945 (".tga" . "image/x-targa") | |
| 946 (".tif" . "image/tiff") | |
| 947 (".tiff" . "image/tiff") | |
| 948 (".tr" . "application/x-troff") | |
| 949 (".troff" . "application/x-troff") | |
| 950 (".tsv" . "text/tab-separated-values") | |
| 951 (".txt" . "text/plain") | |
| 952 (".vbs" . "video/mpeg") | |
| 953 (".vox" . "audio/basic") | |
| 954 (".vrml" . "x-world/x-vrml") | |
| 955 (".wav" . "audio/x-wav") | |
| 956 (".wrl" . "x-world/x-vrml") | |
| 957 (".xbm" . "image/xbm") | |
| 958 (".xpm" . "image/x-pixmap") | |
| 959 (".xwd" . "image/windowdump") | |
| 960 (".zip" . "application/zip") | |
| 961 (".ai" . "application/postscript") | |
| 962 (".jpe" . "image/jpeg") | |
| 963 (".jpeg" . "image/jpeg") | |
| 964 ) | |
| 965 "*An assoc list of file extensions and the MIME content-types they | |
| 966 correspond to.") | |
| 967 | |
| 968 (defun mm-parse-mimetypes (&optional path) | |
| 969 ;; Parse out all the mimetypes specified in a unix-style path string PATH | |
| 970 (cond | |
| 971 (path nil) | |
| 972 ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES"))) | |
| 973 ((memq system-type '(ms-dos ms-windows windows-nt)) | |
| 974 (setq path (mapconcat 'expand-file-name | |
| 975 '("~/mime.typ" "~/etc/mime.typ") ";"))) | |
| 976 (t (setq path (concat (expand-file-name "~/.mime-types") ":" | |
| 977 "/etc/mime-types:/usr/etc/mime-types:" | |
| 978 "/usr/local/etc/mime-types:" | |
| 979 "/usr/local/www/conf/mime-types")))) | |
| 980 (let ((fnames (mm-string-to-tokens path | |
| 981 (if (memq system-type | |
| 982 '(ms-dos ms-windows windows-nt)) | |
| 983 ?; | |
| 984 ?:))) fname) | |
| 985 (while fnames | |
| 986 (setq fname (car fnames)) | |
| 987 (if (and (file-exists-p fname) (file-readable-p fname)) | |
| 988 (mm-parse-mimetype-file (car fnames))) | |
| 989 (setq fnames (cdr fnames))))) | |
| 990 | |
| 991 (defun mm-parse-mimetype-file (fname) | |
| 992 ;; Parse out a mime-types file | |
| 993 (let (type ; The MIME type for this line | |
| 994 extns ; The extensions for this line | |
| 995 save-pos ; Misc. saved buffer positions | |
| 996 ) | |
| 997 (save-excursion | |
| 998 (set-buffer (get-buffer-create " *mime-types*")) | |
| 999 (erase-buffer) | |
| 1000 (insert-file-contents fname) | |
| 1001 (mm-replace-regexp "#.*" "") | |
| 1002 (mm-replace-regexp "\n+" "\n") | |
| 1003 (mm-replace-regexp "[ \t]+$" "") | |
| 1004 (goto-char (point-max)) | |
| 1005 (skip-chars-backward " \t\n") | |
| 1006 (delete-region (point) (point-max)) | |
| 1007 (goto-char (point-min)) | |
| 1008 (while (not (eobp)) | |
| 1009 (skip-chars-forward " \t\n") | |
| 1010 (setq save-pos (point)) | |
| 1011 (skip-chars-forward "^ \t") | |
| 1012 (downcase-region save-pos (point)) | |
| 1013 (setq type (buffer-substring save-pos (point))) | |
| 1014 (while (not (eolp)) | |
| 1015 (skip-chars-forward " \t") | |
| 1016 (setq save-pos (point)) | |
| 1017 (skip-chars-forward "^ \t\n") | |
| 1018 (setq extns (cons (buffer-substring save-pos (point)) extns))) | |
| 1019 (while extns | |
| 1020 (setq mm-mime-extensions | |
| 1021 (cons | |
| 1022 (cons (if (= (string-to-char (car extns)) ?.) | |
| 1023 (car extns) | |
| 1024 (concat "." (car extns))) type) mm-mime-extensions) | |
| 1025 extns (cdr extns))))))) | |
| 1026 | |
| 1027 (defun mm-extension-to-mime (extn) | |
| 1028 "Return the MIME content type of the file extensions EXTN" | |
| 1029 (if (and (stringp extn) | |
| 1030 (not (= (string-to-char extn) ?.))) | |
| 1031 (setq extn (concat "." extn))) | |
| 1032 (cdr (assoc (downcase extn) mm-mime-extensions))) | |
| 1033 | |
| 1034 | |
| 1035 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1036 ;;; Editing/Composition of body parts | |
| 1037 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1038 (defun mm-compose-type (type) | |
| 1039 ;; Compose a body section of MIME-type TYPE. | |
| 1040 (let* ((info (mm-mime-info type nil 5)) | |
| 1041 (fnam (mm-generate-unique-filename)) | |
| 1042 (comp (or (cdr (assoc "compose" info)))) | |
| 1043 (ctyp (cdr (assoc "composetyped" info))) | |
| 1044 (buff (get-buffer-create " *mimecompose*")) | |
| 1045 (typeit (not ctyp)) | |
| 1046 (retval "") | |
| 1047 (usef nil)) | |
| 1048 (setq comp (mm-unescape-mime-test (or comp ctyp) info)) | |
| 1049 (while (string-match "\\([^\\\\]\\)%s" comp) | |
| 1050 (setq comp (concat (substring comp 0 (match-end 1)) fnam | |
| 1051 (substring comp (match-end 0) nil)) | |
| 1052 usef t)) | |
| 1053 (call-process (or shell-file-name | |
| 1054 (getenv "ESHELL") (getenv "SHELL") "/bin/sh") | |
| 1055 nil (if usef nil buff) nil "-c" comp) | |
| 1056 (setq retval | |
| 1057 (concat | |
| 1058 (if typeit (concat "Content-type: " type "\r\n\r\n") "") | |
| 1059 (if usef | |
| 1060 (save-excursion | |
| 1061 (set-buffer buff) | |
| 1062 (erase-buffer) | |
| 1063 (insert-file-contents fnam) | |
| 1064 (buffer-string)) | |
| 1065 (save-excursion | |
| 1066 (set-buffer buff) | |
| 1067 (buffer-string))) | |
| 1068 "\r\n")) | |
| 1069 retval)) | |
| 1070 | |
| 1071 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1072 ;;; Misc. | |
| 1073 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1074 (defun mm-type-to-file (type) | |
| 1075 "Return the file extension for content-type TYPE" | |
| 1076 (rassoc type mm-mime-extensions)) | |
| 1077 | |
| 1078 | |
| 1079 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1080 ;;; Miscellaneous MIME viewers written in elisp | |
| 1081 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1082 (defun mm-play-sound-file (&optional buff) | |
| 1083 "Play a sound file in buffer BUFF (defaults to current buffer)" | |
| 1084 (setq buff (or buff (current-buffer))) | |
| 1085 (let ((fname (mm-generate-unique-filename "%s.au")) | |
| 1086 (synchronous-sounds t)) ; Play synchronously | |
| 1087 (mm-write-region-no-coding-system (point-min) (point-max) fname) | |
| 1088 (kill-buffer (current-buffer)) | |
| 1089 (play-sound-file fname) | |
| 1090 (condition-case () | |
| 1091 (delete-file fname) | |
| 1092 (error nil)))) | |
| 1093 | |
| 1094 (defun mm-parse-mime-headers (&optional no-delete) | |
| 1095 "Return a list of the MIME headers at the top of this buffer. If | |
| 1096 optional argument NO-DELETE is non-nil, don't delete the headers." | |
| 1097 (let* ((st (point-min)) | |
| 1098 (nd (progn | |
| 1099 (goto-char (point-min)) | |
| 1100 (skip-chars-forward " \t\n") | |
| 1101 (if (re-search-forward "^\r*$" nil t) | |
| 1102 (1+ (point)) | |
| 1103 (point-max)))) | |
| 1104 save-pos | |
| 1105 status | |
| 1106 hname | |
| 1107 hvalu | |
| 1108 result | |
| 1109 ) | |
| 1110 (narrow-to-region st nd) | |
| 1111 (goto-char (point-min)) | |
| 1112 (while (not (eobp)) | |
| 1113 (skip-chars-forward " \t\n\r") | |
| 1114 (setq save-pos (point)) | |
| 1115 (skip-chars-forward "^:\n\r") | |
| 1116 (downcase-region save-pos (point)) | |
| 1117 (setq hname (buffer-substring save-pos (point))) | |
| 1118 (skip-chars-forward ": \t ") | |
| 1119 (setq save-pos (point)) | |
| 1120 (skip-chars-forward "^\n\r") | |
| 1121 (setq hvalu (buffer-substring save-pos (point)) | |
| 1122 result (cons (cons hname hvalu) result))) | |
| 1123 (or no-delete (delete-region st nd)) | |
| 1124 result)) | |
| 1125 | |
| 1126 (defun mm-find-available-multiparts (separator &optional buf) | |
| 1127 "Return a list of mime-headers for the various body parts of a | |
| 1128 multipart message in buffer BUF with separator SEPARATOR. | |
| 1129 The different multipart specs are put in `mm-temporary-directory'." | |
| 1130 (let ((sep (concat "^--" separator "\r*$")) | |
| 1131 headers | |
| 1132 fname | |
| 1133 results) | |
| 1134 (save-excursion | |
| 1135 (and buf (set-buffer buf)) | |
| 1136 (goto-char (point-min)) | |
| 1137 (while (re-search-forward sep nil t) | |
| 1138 (let ((st (set-marker (make-marker) | |
| 1139 (progn | |
| 1140 (forward-line 1) | |
| 1141 (beginning-of-line) | |
| 1142 (point)))) | |
| 1143 (nd (set-marker (make-marker) | |
| 1144 (if (re-search-forward sep nil t) | |
| 1145 (1- (match-beginning 0)) | |
| 1146 (point-max))))) | |
| 1147 (narrow-to-region st nd) | |
| 1148 (goto-char st) | |
| 1149 (if (looking-at "^\r*$") | |
| 1150 (insert "Content-type: text/plain\n" | |
| 1151 "Content-length: " (int-to-string (- nd st)) "\n")) | |
| 1152 (setq headers (mm-parse-mime-headers) | |
| 1153 fname (mm-generate-unique-filename)) | |
| 1154 (let ((x (or (cdr (assoc "content-type" headers)) "text/plain"))) | |
| 1155 (if (string-match "name=\"*\\([^ \"]+\\)\"*" x) | |
| 1156 (setq fname (expand-file-name | |
| 1157 (substring x (match-beginning 1) | |
| 1158 (match-end 1)) | |
| 1159 mm-temporary-directory)))) | |
| 1160 (widen) | |
| 1161 (if (assoc "content-transfer-encoding" headers) | |
| 1162 (let ((coding (cdr | |
| 1163 (assoc "content-transfer-encoding" headers))) | |
| 1164 (cmd nil)) | |
| 1165 (setq coding (and coding (downcase coding)) | |
| 1166 cmd (or (cdr (assoc coding | |
| 1167 mm-content-transfer-encodings)) | |
| 1168 (read-string | |
| 1169 (concat "How shall I decode " coding "? ") | |
| 1170 "cat"))) | |
| 1171 (if (string= cmd "") (setq cmd "cat")) | |
| 1172 (if (stringp cmd) | |
| 1173 (shell-command-on-region st nd cmd t) | |
| 1174 (funcall cmd st nd)) | |
| 1175 (set-marker nd (point)))) | |
| 1176 (write-region st nd fname nil 5) | |
| 1177 (delete-region st nd) | |
| 1178 (setq results (cons | |
| 1179 (cons | |
| 1180 (cons "mm-filename" fname) headers) results))))) | |
| 1181 results)) | |
| 1182 | |
| 1183 (defun mm-format-multipart-as-html (&optional buf type) | |
| 1184 (if buf (set-buffer buf)) | |
| 1185 (let* ((boundary (if (string-match | |
| 1186 "boundary[ \t]*=[ \t\"]*\\([^ \"\t\n]+\\)" | |
| 1187 type) | |
| 1188 (regexp-quote | |
| 1189 (substring type (match-beginning 1) (match-end 1))))) | |
| 1190 (parts (mm-find-available-multiparts boundary))) | |
| 1191 (erase-buffer) | |
| 1192 (insert "<html>\n" | |
| 1193 " <head>\n" | |
| 1194 " <title>Multipart Message</title>\n" | |
| 1195 " </head>\n" | |
| 1196 " <body>\n" | |
| 1197 " <h1> Multipart message encountered </h1>\n" | |
| 1198 " <p> I have encountered a multipart MIME message.\n" | |
| 1199 " The following parts have been detected. Please\n" | |
| 1200 " select which one you want to view.\n" | |
| 1201 " </p>\n" | |
| 1202 " <ul>\n" | |
| 1203 (mapconcat | |
| 1204 (function (lambda (x) | |
| 1205 (concat " <li> <a href=\"file:" | |
| 1206 (cdr (assoc "mm-filename" x)) | |
| 1207 "\">" | |
| 1208 (or (cdr (assoc "content-description" x)) "") | |
| 1209 "--" | |
| 1210 (or (cdr (assoc "content-type" x)) | |
| 1211 "unknown type") | |
| 1212 "</a> </li>"))) | |
| 1213 parts "\n") | |
| 1214 " </ul>\n" | |
| 1215 " </body>\n" | |
| 1216 "</html>\n" | |
| 1217 "<!-- Automatically generated by MM v" mm-version "-->\n"))) | |
| 1218 | |
| 1219 (defun mm-multipart-viewer () | |
| 1220 (mm-format-multipart-as-html | |
| 1221 (current-buffer) | |
| 1222 (cdr (assoc "content-type" url-current-mime-headers))) | |
| 1223 (let ((w3-working-buffer (current-buffer))) | |
| 1224 (w3-prepare-buffer))) | |
| 1225 | |
| 1226 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1227 ;;; Transfer encodings we can decrypt automatically | |
| 1228 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1229 (defun mm-decode-quoted-printable (&optional st nd) | |
| 1230 (interactive) | |
| 1231 (setq st (or st (point-min)) | |
| 1232 nd (or nd (point-max))) | |
| 1233 (save-restriction | |
| 1234 (narrow-to-region st nd) | |
| 1235 (save-excursion | |
| 1236 (let ((buffer-read-only nil)) | |
| 1237 (goto-char (point-min)) | |
| 1238 (while (re-search-forward "=[0-9A-F][0-9A-F]" nil t) | |
| 1239 (replace-match | |
| 1240 (char-to-string | |
| 1241 (+ | |
| 1242 (* 16 (mm-hex-char-to-integer | |
| 1243 (char-after (1+ (match-beginning 0))))) | |
| 1244 (mm-hex-char-to-integer | |
| 1245 (char-after (1- (match-end 0)))))))))))) | |
| 1246 | |
| 1247 ;; Taken from hexl.el. | |
| 1248 (defun mm-hex-char-to-integer (character) | |
| 1249 "Take a char and return its value as if it was a hex digit." | |
| 1250 (if (and (>= character ?0) (<= character ?9)) | |
| 1251 (- character ?0) | |
| 1252 (let ((ch (logior character 32))) | |
| 1253 (if (and (>= ch ?a) (<= ch ?f)) | |
| 1254 (- ch (- ?a 10)) | |
| 1255 (error (format "Invalid hex digit `%c'." ch)))))) | |
| 1256 | |
| 1257 | |
| 1258 (require 'base64) | |
| 1259 (provide 'mm) |