Mercurial > hg > xemacs-beta
comparison lisp/url/mm.el @ 70:131b0175ea99 r20-0b30
Import from CVS: tag r20-0b30
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 09:02:59 +0200 |
| parents | |
| children |
comparison
equal
deleted
inserted
replaced
| 69:804d1389bcd6 | 70:131b0175ea99 |
|---|---|
| 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 ;;; | |
| 9 ;;; Copyright (c) 1994, 1995 by William M. Perry (wmperry@spry.com) | |
| 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 | |
| 25 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
| 26 ;;; | |
| 27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 28 ;;; Generalized mailcap parsing and access routines | |
| 29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 30 ;;; | |
| 31 ;;; Data structures | |
| 32 ;;; --------------- | |
| 33 ;;; The mailcap structure is an assoc list of assoc lists. | |
| 34 ;;; 1st assoc list is keyed on the major content-type | |
| 35 ;;; 2nd assoc list is keyed on the minor content-type (which can be a regexp) | |
| 36 ;;; | |
| 37 ;;; Which looks like: | |
| 38 ;;; ----------------- | |
| 39 ;;; ( | |
| 40 ;;; ("application" | |
| 41 ;;; ("postscript" . <info>) | |
| 42 ;;; ) | |
| 43 ;;; ("text" | |
| 44 ;;; ("plain" . <info>) | |
| 45 ;;; ) | |
| 46 ;;; ) | |
| 47 ;;; | |
| 48 ;;; Where <info> is another assoc list of the various information | |
| 49 ;;; related to the mailcap RFC. This is keyed on the lowercase | |
| 50 ;;; attribute name (viewer, test, etc). This looks like: | |
| 51 ;;; (("viewer" . viewerinfo) | |
| 52 ;;; ("test" . testinfo) | |
| 53 ;;; ("xxxx" . "string") | |
| 54 ;;; ) | |
| 55 ;;; | |
| 56 ;;; Where viewerinfo specifies how the content-type is viewed. Can be | |
| 57 ;;; a string, in which case it is run through a shell, with | |
| 58 ;;; appropriate parameters, or a symbol, in which case the symbol is | |
| 59 ;;; funcall'd, with the buffer as an argument. | |
| 60 ;;; | |
| 61 ;;; testinfo is a list of strings, or nil. If nil, it means the | |
| 62 ;;; viewer specified is always valid. If it is a list of strings, | |
| 63 ;;; these are used to determine whether a viewer passes the 'test' or | |
| 64 ;;; not. | |
| 65 ;;; | |
| 66 ;;; The main interface to this code is: | |
| 67 ;;; | |
| 68 ;;; To set everything up: | |
| 69 ;;; | |
| 70 ;;; (mm-parse-mailcaps [path]) | |
| 71 ;;; | |
| 72 ;;; Where PATH is a unix-style path specification (: separated list | |
| 73 ;;; of strings). If PATH is nil, the environment variable MAILCAPS | |
| 74 ;;; will be consulted. If there is no environment variable, then a | |
| 75 ;;; default list of paths is used. | |
| 76 ;;; | |
| 77 ;;; To retrieve the information: | |
| 78 ;;; (mm-mime-info st [nd] [request]) | |
| 79 ;;; | |
| 80 ;;; Where st and nd are positions in a buffer that contain the | |
| 81 ;;; content-type header information of a mail/news/whatever message. | |
| 82 ;;; st can optionally be a string that contains the content-type | |
| 83 ;;; information. | |
| 84 ;;; | |
| 85 ;;; Third argument REQUEST specifies what information to return. If | |
| 86 ;;; it is nil or the empty string, the viewer (second field of the | |
| 87 ;;; mailcap entry) will be returned. If it is a string, then the | |
| 88 ;;; mailcap field corresponding to that string will be returned | |
| 89 ;;; (print, description, whatever). If a number, then all the | |
| 90 ;;; information for this specific viewer is returned. | |
| 91 ;;; | |
| 92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 93 ;;; Variables, etc | |
| 94 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 95 (eval-and-compile | |
| 96 (require 'cl)) | |
| 97 | |
| 98 (defconst mm-version (let ((x "1.96")) | |
| 99 (if (string-match "Revision: \\([^ \t\n]+\\)" x) | |
| 100 (substring x (match-beginning 1) (match-end 1)) | |
| 101 x)) | |
| 102 "Version # of MM package") | |
| 103 | |
| 104 (defvar mm-parse-args-syntax-table | |
| 105 (copy-syntax-table emacs-lisp-mode-syntax-table) | |
| 106 "A syntax table for parsing sgml attributes.") | |
| 107 | |
| 108 (modify-syntax-entry ?' "\"" mm-parse-args-syntax-table) | |
| 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 | |
| 113 ;;; This is so we can use a consistent method of checking for mule support | |
| 114 ;;; Emacs-based mule uses (boundp 'MULE), but XEmacs-based mule uses | |
| 115 ;;; (featurep 'mule) - I choose to use the latter. | |
| 116 | |
| 117 (if (boundp 'MULE) | |
| 118 (provide 'mule)) | |
| 119 | |
| 120 (defvar mm-mime-data | |
| 121 '( | |
| 122 ("multipart" . ( | |
| 123 ("alternative". (("viewer" . mm-multipart-viewer) | |
| 124 ("type" . "multipart/alternative"))) | |
| 125 ("mixed" . (("viewer" . mm-multipart-viewer) | |
| 126 ("type" . "multipart/mixed"))) | |
| 127 (".*" . (("viewer" . mm-save-binary-file) | |
| 128 ("type" . "multipart/*"))) | |
| 129 ) | |
| 130 ) | |
| 131 ("application" . ( | |
| 132 ("octet-stream" . (("viewer" . mm-save-binary-file) | |
| 133 ("type" ."application/octet-stream"))) | |
| 134 ("dvi" . (("viewer" . "open %s") | |
| 135 ("type" . "application/dvi") | |
| 136 ("test" . (eq (device-type) 'ns)))) | |
| 137 ("dvi" . (("viewer" . "xdvi %s") | |
| 138 ("test" . (eq (device-type) 'x)) | |
| 139 ("needsx11") | |
| 140 ("type" . "application/dvi"))) | |
| 141 ("dvi" . (("viewer" . "dvitty %s") | |
| 142 ("test" . (not (getenv "DISPLAY"))) | |
| 143 ("type" . "application/dvi"))) | |
| 144 ("emacs-lisp" . (("viewer" . mm-maybe-eval) | |
| 145 ("type" . "application/emacs-lisp"))) | |
| 146 ; ("x-tar" . (("viewer" . tar-mode) | |
| 147 ; ("test" . (fboundp 'tar-mode)) | |
| 148 ; ("type" . "application/x-tar"))) | |
| 149 ("x-tar" . (("viewer" . mm-save-binary-file) | |
| 150 ("type" . "application/x-tar"))) | |
| 151 ("x-latex" . (("viewer" . tex-mode) | |
| 152 ("test" . (fboundp 'tex-mode)) | |
| 153 ("type" . "application/x-latex"))) | |
| 154 ("x-tex" . (("viewer" . tex-mode) | |
| 155 ("test" . (fboundp 'tex-mode)) | |
| 156 ("type" . "application/x-tex"))) | |
| 157 ("latex" . (("viewer" . tex-mode) | |
| 158 ("test" . (fboundp 'tex-mode)) | |
| 159 ("type" . "application/latex"))) | |
| 160 ("tex" . (("viewer" . tex-mode) | |
| 161 ("test" . (fboundp 'tex-mode)) | |
| 162 ("type" . "application/tex"))) | |
| 163 ("texinfo" . (("viewer" . texinfo-mode) | |
| 164 ("test" . (fboundp 'texinfo-mode)) | |
| 165 ("type" . "application/tex"))) | |
| 166 ("zip" . (("viewer" . mm-save-binary-file) | |
| 167 ("type" . "application/zip") | |
| 168 ("copiousoutput"))) | |
| 169 ("pdf" . (("viewer" . "acroread %s") | |
| 170 ("type" . "application/pdf"))) | |
| 171 ("postscript" . (("viewer" . "open %s") | |
| 172 ("type" . "application/postscript") | |
| 173 ("test" . (eq (device-type) 'ns)))) | |
| 174 ("postscript" . (("viewer" . "ghostview %s") | |
| 175 ("type" . "application/postscript") | |
| 176 ("test" . (eq (device-type) 'x)) | |
| 177 ("needsx11"))) | |
| 178 ("postscript" . (("viewer" . "ps2ascii %s") | |
| 179 ("type" . "application/postscript") | |
| 180 ("test" . (not (getenv "DISPLAY"))) | |
| 181 ("copiousoutput"))) | |
| 182 ("x-www-pem-reply" . | |
| 183 (("viewer" . (w3-decode-pgp/pem "pem")) | |
| 184 ("test" . (fboundp 'w3-decode-pgp/pem)) | |
| 185 ("type" . "application/x-www-pem-reply") | |
| 186 )) | |
| 187 ("x-www-pgp-reply" . | |
| 188 (("viewer" . (w3-decode-pgp/pem "pgp")) | |
| 189 ("test" . (fboundp 'w3-decode-pgp/pem)) | |
| 190 ("type" . "application/x-www-pgp-reply"))) | |
| 191 )) | |
| 192 ("audio" . ( | |
| 193 ("x-mpeg" . (("viewer" . "maplay %s") | |
| 194 ("type" . "audio/x-mpeg"))) | |
| 195 (".*" . (("viewer" . mm-play-sound-file) | |
| 196 ("test" . (or (featurep 'nas-sound) | |
| 197 (featurep 'native-sound))) | |
| 198 ("type" . "audio/*"))) | |
| 199 (".*" . (("viewer" . "showaudio") | |
| 200 ("type" . "audio/*"))) | |
| 201 )) | |
| 202 ("message" . ( | |
| 203 ("rfc-*822" . (("viewer" . vm-mode) | |
| 204 ("test" . (fboundp 'vm-mode)) | |
| 205 ("type" . "message/rfc-822"))) | |
| 206 ("rfc-*822" . (("viewer" . w3-mode) | |
| 207 ("test" . (fboundp 'w3-mode)) | |
| 208 ("type" . "message/rfc-822"))) | |
| 209 ("rfc-*822" . (("viewer" . view-mode) | |
| 210 ("test" . (fboundp 'view-mode)) | |
| 211 ("type" . "message/rfc-822"))) | |
| 212 ("rfc-*822" . (("viewer" . fundamental-mode) | |
| 213 ("type" . "message/rfc-822"))) | |
| 214 )) | |
| 215 ("image" . ( | |
| 216 ("x-xwd" . (("viewer" . "xwud -in %s") | |
| 217 ("type" . "image/x-xwd") | |
| 218 ("compose" . "xwd -frame > %s") | |
| 219 ("test" . (eq (device-type) 'x)) | |
| 220 ("needsx11"))) | |
| 221 ("x11-dump" . (("viewer" . "xwud -in %s") | |
| 222 ("type" . "image/x-xwd") | |
| 223 ("compose" . "xwd -frame > %s") | |
| 224 ("test" . (eq (device-type) 'x)) | |
| 225 ("needsx11"))) | |
| 226 ("windowdump" . (("viewer" . "xwud -in %s") | |
| 227 ("type" . "image/x-xwd") | |
| 228 ("compose" . "xwd -frame > %s") | |
| 229 ("test" . (eq (device-type) 'x)) | |
| 230 ("needsx11"))) | |
| 231 (".*" . (("viewer" . "open %s") | |
| 232 ("type" . "image/*") | |
| 233 ("test" . (eq (device-type) 'ns)))) | |
| 234 (".*" . (("viewer" . "xv -perfect %s") | |
| 235 ("type" . "image/*") | |
| 236 ("test" . (eq (device-type) 'x)) | |
| 237 ("needsx11"))) | |
| 238 )) | |
| 239 ("text" . ( | |
| 240 ("plain" . (("viewer" . w3-mode) | |
| 241 ("test" . (fboundp 'w3-mode)) | |
| 242 ("type" . "text/plain"))) | |
| 243 ("plain" . (("viewer" . view-mode) | |
| 244 ("test" . (fboundp 'view-mode)) | |
| 245 ("type" . "text/plain"))) | |
| 246 ("plain" . (("viewer" . fundamental-mode) | |
| 247 ("type" . "text/plain"))) | |
| 248 ("enriched" . (("viewer" . enriched-decode-region) | |
| 249 ("test" . (fboundp | |
| 250 'enriched-decode-region)) | |
| 251 ("type" . "text/enriched"))) | |
| 252 ("html" . (("viewer" . w3-prepare-buffer) | |
| 253 ("test" . (fboundp 'w3-prepare-buffer)) | |
| 254 ("type" . "text/html"))) | |
| 255 )) | |
| 256 ("video" . ( | |
| 257 ("mpeg" . (("viewer" . "mpeg_play %s") | |
| 258 ("type" . "video/mpeg") | |
| 259 ("test" . (eq (device-type) 'x)) | |
| 260 ("needsx11"))) | |
| 261 )) | |
| 262 ("x-world" . ( | |
| 263 ("x-vrml" . (("viewer" . "webspace -remote %s -URL %u") | |
| 264 ("type" . "x-world/x-vrml") | |
| 265 ("description" | |
| 266 "VRML document"))))) | |
| 267 ("archive" . ( | |
| 268 ("tar" . (("viewer" . tar-mode) | |
| 269 ("type" . "archive/tar") | |
| 270 ("test" . (fboundp 'tar-mode)))) | |
| 271 )) | |
| 272 ) | |
| 273 "*The mailcap structure is an assoc list of assoc lists. | |
| 274 1st assoc list is keyed on the major content-type | |
| 275 2nd assoc list is keyed on the minor content-type (which can be a regexp) | |
| 276 | |
| 277 Which looks like: | |
| 278 ----------------- | |
| 279 ( | |
| 280 (\"application\" | |
| 281 (\"postscript\" . <info>) | |
| 282 ) | |
| 283 (\"text\" | |
| 284 (\"plain\" . <info>) | |
| 285 ) | |
| 286 ) | |
| 287 | |
| 288 Where <info> is another assoc list of the various information | |
| 289 related to the mailcap RFC. This is keyed on the lowercase | |
| 290 attribute name (viewer, test, etc). This looks like: | |
| 291 ((\"viewer\" . viewerinfo) | |
| 292 (\"test\" . testinfo) | |
| 293 (\"xxxx\" . \"string\") | |
| 294 ) | |
| 295 | |
| 296 Where viewerinfo specifies how the content-type is viewed. Can be | |
| 297 a string, in which case it is run through a shell, with | |
| 298 appropriate parameters, or a symbol, in which case the symbol is | |
| 299 funcall'd, with the buffer as an argument. | |
| 300 | |
| 301 testinfo is a list of strings, or nil. If nil, it means the | |
| 302 viewer specified is always valid. If it is a list of strings, | |
| 303 these are used to determine whether a viewer passes the 'test' or | |
| 304 not.") | |
| 305 | |
| 306 (defvar mm-content-transfer-encodings | |
| 307 '(("base64" . base64-decode) | |
| 308 ("7bit" . ignore) | |
| 309 ("8bit" . ignore) | |
| 310 ("binary" . ignore) | |
| 311 ("x-compress" . ("uncompress" "-c")) | |
| 312 ("x-gzip" . ("gzip" "-dc")) | |
| 313 ("compress" . ("uncompress" "-c")) | |
| 314 ("gzip" . ("gzip" "-dc")) | |
| 315 ("x-hqx" . ("mcvert" "-P" "-s" "-S")) | |
| 316 ("quoted-printable" . mm-decode-quoted-printable) | |
| 317 ) | |
| 318 "*An assoc list of content-transfer-encodings and how to decode them.") | |
| 319 | |
| 320 (defvar mm-download-directory nil | |
| 321 "*Where downloaded files should go by default.") | |
| 322 | |
| 323 (defvar mm-temporary-directory "/tmp" | |
| 324 "*Where temporary files go.") | |
| 325 | |
| 326 | |
| 327 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 328 ;;; A few things from w3 and url, just in case this is used without them | |
| 329 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 330 | |
| 331 (defun mm-generate-unique-filename (&optional fmt) | |
| 332 "Generate a unique filename in mm-temporary-directory" | |
| 333 (if (not fmt) | |
| 334 (let ((base (format "mm-tmp.%d" (user-real-uid))) | |
| 335 (fname "") | |
| 336 (x 0)) | |
| 337 (setq fname (format "%s%d" base x)) | |
| 338 (while (file-exists-p | |
| 339 (expand-file-name fname mm-temporary-directory)) | |
| 340 (setq x (1+ x) | |
| 341 fname (concat base (int-to-string x)))) | |
| 342 (expand-file-name fname mm-temporary-directory)) | |
| 343 (let ((base (concat "mm" (int-to-string (user-real-uid)))) | |
| 344 (fname "") | |
| 345 (x 0)) | |
| 346 (setq fname (format fmt (concat base (int-to-string x)))) | |
| 347 (while (file-exists-p | |
| 348 (expand-file-name fname mm-temporary-directory)) | |
| 349 (setq x (1+ x) | |
| 350 fname (format fmt (concat base (int-to-string x))))) | |
| 351 (expand-file-name fname mm-temporary-directory)))) | |
| 352 | |
| 353 (if (and (fboundp 'copy-tree) | |
| 354 (subrp (symbol-function 'copy-tree))) | |
| 355 (fset 'mm-copy-tree 'copy-tree) | |
| 356 (defun mm-copy-tree (tree) | |
| 357 (if (consp tree) | |
| 358 (cons (mm-copy-tree (car tree)) | |
| 359 (mm-copy-tree (cdr tree))) | |
| 360 (if (vectorp tree) | |
| 361 (let* ((new (copy-sequence tree)) | |
| 362 (i (1- (length new)))) | |
| 363 (while (>= i 0) | |
| 364 (aset new i (mm-copy-tree (aref new i))) | |
| 365 (setq i (1- i))) | |
| 366 new) | |
| 367 tree)))) | |
| 368 | |
| 369 (if (not (fboundp 'w3-save-binary-file)) | |
| 370 (defun mm-save-binary-file () | |
| 371 ;; Ok, this is truly fucked. In XEmacs, if you use the mouse to select | |
| 372 ;; a URL that gets saved via this function, read-file-name will pop up a | |
| 373 ;; dialog box for file selection. For some reason which buffer we are in | |
| 374 ;; gets royally screwed (even with save-excursions and the whole nine | |
| 375 ;; yards). SO, we just keep the old buffer name around and away we go. | |
| 376 (let ((old-buff (current-buffer)) | |
| 377 (file (read-file-name "Filename to save as: " | |
| 378 (or mm-download-directory "~/") | |
| 379 (file-name-nondirectory (url-view-url t)) | |
| 380 nil | |
| 381 (file-name-nondirectory (url-view-url t)))) | |
| 382 (require-final-newline nil)) | |
| 383 (set-buffer old-buff) | |
| 384 (if (featurep 'mule) | |
| 385 (let ((mc-flag t)) | |
| 386 (write-region (point-min) (point-max) file nil nil *noconv*)) | |
| 387 (write-region (point-min) (point-max) file)) | |
| 388 (kill-buffer (current-buffer)))) | |
| 389 (fset 'mm-save-binary-file 'w3-save-binary-file)) | |
| 390 | |
| 391 (if (not (fboundp 'w3-maybe-eval)) | |
| 392 (defun mm-maybe-eval () | |
| 393 "Maybe evaluate a buffer of emacs lisp code" | |
| 394 (if (yes-or-no-p "This is emacs-lisp code, evaluate it? ") | |
| 395 (eval-buffer (current-buffer)) | |
| 396 (emacs-lisp-mode))) | |
| 397 (fset 'mm-maybe-eval 'w3-maybe-eval)) | |
| 398 | |
| 399 | |
| 400 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 401 ;;; The mailcap parser | |
| 402 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 403 (defun mm-viewer-unescape (format &optional filename url) | |
| 404 (save-excursion | |
| 405 (set-buffer (get-buffer-create " *mm-parse*")) | |
| 406 (erase-buffer) | |
| 407 (insert format) | |
| 408 (goto-char (point-min)) | |
| 409 (while (re-search-forward "%\\(.\\)" nil t) | |
| 410 (let ((escape (aref (match-string 1) 0))) | |
| 411 (replace-match "" t t) | |
| 412 (case escape | |
| 413 (?% (insert "%")) | |
| 414 (?s (insert (or filename "\"\""))) | |
| 415 (?u (insert (or url "\"\"")))))) | |
| 416 (buffer-string))) | |
| 417 | |
| 418 (defun mm-in-assoc (elt list) | |
| 419 ;; Check to see if ELT matches any of the regexps in the car elements of LIST | |
| 420 (let (rslt) | |
| 421 (while (and list (not rslt)) | |
| 422 (and (car (car list)) | |
| 423 (string-match (car (car list)) elt) | |
| 424 (setq rslt (car list))) | |
| 425 (setq list (cdr list))) | |
| 426 rslt)) | |
| 427 | |
| 428 (defun mm-replace-regexp (regexp to-string) | |
| 429 ;; Quiet replace-regexp. | |
| 430 (goto-char (point-min)) | |
| 431 (while (re-search-forward regexp nil t) | |
| 432 (replace-match to-string t nil))) | |
| 433 | |
| 434 (defun mm-parse-mailcaps (&optional path) | |
| 435 ;; Parse out all the mailcaps specified in a unix-style path string PATH | |
| 436 (cond | |
| 437 (path nil) | |
| 438 ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS"))) | |
| 439 ((memq system-type '(ms-dos ms-windows windows-nt)) | |
| 440 (setq path (mapconcat 'expand-file-name '("~/mail.cap" "~/etc/mail.cap") | |
| 441 ";"))) | |
| 442 (t (setq path (concat "/etc/mailcap:/usr/etc/mailcap:" | |
| 443 "/usr/local/etc/mailcap:" | |
| 444 (expand-file-name "~/.mailcap"))))) | |
| 445 (let ((fnames (mm-string-to-tokens path | |
| 446 (if (memq system-type | |
| 447 '(ms-dos ms-windows windows-nt)) | |
| 448 ?; | |
| 449 ?:))) fname) | |
| 450 (while fnames | |
| 451 (setq fname (car fnames)) | |
| 452 (if (and (file-exists-p fname) (file-readable-p fname)) | |
| 453 (mm-parse-mailcap (car fnames))) | |
| 454 (setq fnames (cdr fnames))))) | |
| 455 | |
| 456 (defun mm-parse-mailcap (fname) | |
| 457 ;; Parse out the mailcap file specified by FNAME | |
| 458 (let (major ; The major mime type (image/audio/etc) | |
| 459 minor ; The minor mime type (gif, basic, etc) | |
| 460 save-pos ; Misc saved positions used in parsing | |
| 461 viewer ; How to view this mime type | |
| 462 info ; Misc info about this mime type | |
| 463 ) | |
| 464 (save-excursion | |
| 465 (set-buffer (get-buffer-create " *mailcap*")) | |
| 466 (erase-buffer) | |
| 467 (insert-file-contents fname) | |
| 468 (set-syntax-table mm-parse-args-syntax-table) | |
| 469 (mm-replace-regexp "#.*" "") ; Remove all comments | |
| 470 (mm-replace-regexp "\n+" "\n") ; And blank lines | |
| 471 (mm-replace-regexp "\\\\[ \t\n]+" " ") ; And collapse spaces | |
| 472 (mm-replace-regexp (concat (regexp-quote "\\") "[ \t]*\n") "") | |
| 473 (goto-char (point-max)) | |
| 474 (skip-chars-backward " \t\n") | |
| 475 (delete-region (point) (point-max)) | |
| 476 (goto-char (point-min)) | |
| 477 (while (not (eobp)) | |
| 478 (skip-chars-forward " \t\n") | |
| 479 (setq save-pos (point) | |
| 480 info nil) | |
| 481 (skip-chars-forward "^/;") | |
| 482 (downcase-region save-pos (point)) | |
| 483 (setq major (buffer-substring save-pos (point))) | |
| 484 (skip-chars-forward "/ \t\n") | |
| 485 (setq save-pos (point)) | |
| 486 (skip-chars-forward "^;") | |
| 487 (downcase-region save-pos (point)) | |
| 488 (setq minor | |
| 489 (cond | |
| 490 ((= ?* (or (char-after save-pos) 0)) ".*") | |
| 491 ((= (point) save-pos) ".*") | |
| 492 (t (buffer-substring save-pos (point))))) | |
| 493 (skip-chars-forward "; \t\n") | |
| 494 ;;; Got the major/minor chunks, now for the viewers/etc | |
| 495 ;;; The first item _must_ be a viewer, according to the | |
| 496 ;;; RFC for mailcap files (#1343) | |
| 497 (skip-chars-forward "; \t\n") | |
| 498 (setq save-pos (point)) | |
| 499 (skip-chars-forward "^;\n") | |
| 500 (if (= (or (char-after save-pos) 0) ?') | |
| 501 (setq viewer (progn | |
| 502 (narrow-to-region (1+ save-pos) (point)) | |
| 503 (goto-char (point-min)) | |
| 504 (prog1 | |
| 505 (read (current-buffer)) | |
| 506 (goto-char (point-max)) | |
| 507 (widen)))) | |
| 508 (setq viewer (buffer-substring save-pos (point)))) | |
| 509 (setq save-pos (point)) | |
| 510 (end-of-line) | |
| 511 (setq info (nconc (list (cons "viewer" viewer) | |
| 512 (cons "type" (concat major "/" | |
| 513 (if (string= minor ".*") | |
| 514 "*" minor)))) | |
| 515 (mm-parse-mailcap-extras save-pos (point)))) | |
| 516 (mm-mailcap-entry-passes-test info) | |
| 517 (mm-add-mailcap-entry major minor info))))) | |
| 518 | |
| 519 (defun mm-parse-mailcap-extras (st nd) | |
| 520 ;; Grab all the extra stuff from a mailcap entry | |
| 521 (let ( | |
| 522 name ; From name= | |
| 523 value ; its value | |
| 524 results ; Assoc list of results | |
| 525 name-pos ; Start of XXXX= position | |
| 526 val-pos ; Start of value position | |
| 527 done ; Found end of \'d ;s? | |
| 528 ) | |
| 529 (save-restriction | |
| 530 (narrow-to-region st nd) | |
| 531 (goto-char (point-min)) | |
| 532 (skip-chars-forward " \n\t;") | |
| 533 (while (not (eobp)) | |
| 534 (setq done nil) | |
| 535 (skip-chars-forward " \";\n\t") | |
| 536 (setq name-pos (point)) | |
| 537 (skip-chars-forward "^ \n\t=") | |
| 538 (downcase-region name-pos (point)) | |
| 539 (setq name (buffer-substring name-pos (point))) | |
| 540 (skip-chars-forward " \t\n") | |
| 541 (if (/= (or (char-after (point)) 0) ?=) ; There is no value | |
| 542 (setq value nil) | |
| 543 (skip-chars-forward " \t\n=") | |
| 544 (setq val-pos (point)) | |
| 545 (if (memq (char-after val-pos) '(?\" ?')) | |
| 546 (progn | |
| 547 (setq val-pos (1+ val-pos)) | |
| 548 (condition-case nil | |
| 549 (progn | |
| 550 (forward-sexp 1) | |
| 551 (backward-char 1)) | |
| 552 (error (goto-char (point-max))))) | |
| 553 (while (not done) | |
| 554 (skip-chars-forward "^;") | |
| 555 (if (= (or (char-after (1- (point))) 0) ?\\ ) | |
| 556 (progn | |
| 557 (subst-char-in-region (1- (point)) (point) ?\\ ? ) | |
| 558 (skip-chars-forward ";")) | |
| 559 (setq done t)))) | |
| 560 (setq value (buffer-substring val-pos (point)))) | |
| 561 (setq results (cons (cons name value) results))) | |
| 562 results))) | |
| 563 | |
| 564 (defun mm-string-to-tokens (str &optional delim) | |
| 565 "Return a list of words from the string STR" | |
| 566 (setq delim (or delim ? )) | |
| 567 (let (results y) | |
| 568 (mapcar | |
| 569 (function | |
| 570 (lambda (x) | |
| 571 (cond | |
| 572 ((and (= x delim) y) (setq results (cons y results) y nil)) | |
| 573 ((/= x delim) (setq y (concat y (char-to-string x)))) | |
| 574 (t nil)))) str) | |
| 575 (nreverse (cons y results)))) | |
| 576 | |
| 577 (defun mm-mailcap-entry-passes-test (info) | |
| 578 ;; Return t iff a mailcap entry passes its test clause or no test | |
| 579 ;; clause is present. | |
| 580 (let (status ; Call-process-regions return value | |
| 581 (test (assoc "test" info)); The test clause | |
| 582 ) | |
| 583 (setq status (and test (mm-string-to-tokens (cdr test)))) | |
| 584 (if (and (assoc "needsx11" info) (not (getenv "DISPLAY"))) | |
| 585 (setq status nil) | |
| 586 (cond | |
| 587 ((and (equal (nth 0 status) "test") | |
| 588 (equal (nth 1 status) "-n") | |
| 589 (or (equal (nth 2 status) "$DISPLAY") | |
| 590 (equal (nth 2 status) "\"$DISPLAY\""))) | |
| 591 (setq status (if (getenv "DISPLAY") t nil))) | |
| 592 ((and (equal (nth 0 status) "test") | |
| 593 (equal (nth 1 status) "-z") | |
| 594 (or (equal (nth 2 status) "$DISPLAY") | |
| 595 (equal (nth 2 status) "\"$DISPLAY\""))) | |
| 596 (setq status (if (getenv "DISPLAY") nil t))) | |
| 597 (test nil) | |
| 598 (t nil))) | |
| 599 (and test (listp test) (setcdr test status)))) | |
| 600 | |
| 601 (defun mm-parse-args (st &optional nd nodowncase) | |
| 602 ;; Return an assoc list of attribute/value pairs from an RFC822-type string | |
| 603 (let ( | |
| 604 name ; From name= | |
| 605 value ; its value | |
| 606 results ; Assoc list of results | |
| 607 name-pos ; Start of XXXX= position | |
| 608 val-pos ; Start of value position | |
| 609 ) | |
| 610 (save-excursion | |
| 611 (if (stringp st) | |
| 612 (progn | |
| 613 (set-buffer (get-buffer-create " *mm-temp*")) | |
| 614 (set-syntax-table mm-parse-args-syntax-table) | |
| 615 (erase-buffer) | |
| 616 (insert st) | |
| 617 (setq st (point-min) | |
| 618 nd (point-max))) | |
| 619 (set-syntax-table mm-parse-args-syntax-table)) | |
| 620 (save-restriction | |
| 621 (narrow-to-region st nd) | |
| 622 (goto-char (point-min)) | |
| 623 (while (not (eobp)) | |
| 624 (skip-chars-forward "; \n\t") | |
| 625 (setq name-pos (point)) | |
| 626 (skip-chars-forward "^ \n\t=;") | |
| 627 (if (not nodowncase) | |
| 628 (downcase-region name-pos (point))) | |
| 629 (setq name (buffer-substring name-pos (point))) | |
| 630 (skip-chars-forward " \t\n") | |
| 631 (if (/= (or (char-after (point)) 0) ?=) ; There is no value | |
| 632 (setq value nil) | |
| 633 (skip-chars-forward " \t\n=") | |
| 634 (setq val-pos (point) | |
| 635 value | |
| 636 (cond | |
| 637 ((or (= (or (char-after val-pos) 0) ?\") | |
| 638 (= (or (char-after val-pos) 0) ?')) | |
| 639 (buffer-substring (1+ val-pos) | |
| 640 (condition-case () | |
| 641 (prog2 | |
| 642 (forward-sexp 1) | |
| 643 (1- (point)) | |
| 644 (skip-chars-forward "\"")) | |
| 645 (error | |
| 646 (skip-chars-forward "^ \t\n") | |
| 647 (point))))) | |
| 648 (t | |
| 649 (buffer-substring val-pos | |
| 650 (progn | |
| 651 (skip-chars-forward "^;") | |
| 652 (skip-chars-backward " \t") | |
| 653 (point))))))) | |
| 654 (setq results (cons (cons name value) results)) | |
| 655 (skip-chars-forward "; \n\t")) | |
| 656 results)))) | |
| 657 | |
| 658 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 659 ;;; The action routines. | |
| 660 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 661 (defun mm-possible-viewers (major minor) | |
| 662 ;; Return a list of possible viewers from MAJOR for minor type MINOR | |
| 663 (let ((exact '()) | |
| 664 (wildcard '())) | |
| 665 (while major | |
| 666 (cond | |
| 667 ((equal (car (car major)) minor) | |
| 668 (setq exact (cons (cdr (car major)) exact))) | |
| 669 ((string-match (car (car major)) minor) | |
| 670 (setq wildcard (cons (cdr (car major)) wildcard)))) | |
| 671 (setq major (cdr major))) | |
| 672 (nconc (nreverse exact) (nreverse wildcard)))) | |
| 673 | |
| 674 (defun mm-unescape-mime-test (test type-info) | |
| 675 (let ((buff (get-buffer-create " *unescape*")) | |
| 676 save-pos save-chr subst) | |
| 677 (cond | |
| 678 ((symbolp test) test) | |
| 679 ((and (listp test) (symbolp (car test))) test) | |
| 680 ((or (stringp test) | |
| 681 (and (listp test) (stringp (car test)) | |
| 682 (setq test (mapconcat 'identity test " ")))) | |
| 683 (save-excursion | |
| 684 (set-buffer buff) | |
| 685 (erase-buffer) | |
| 686 (insert test) | |
| 687 (goto-char (point-min)) | |
| 688 (while (not (eobp)) | |
| 689 (skip-chars-forward "^%") | |
| 690 (if (/= (- (point) | |
| 691 (progn (skip-chars-backward "\\\\") | |
| 692 (point))) | |
| 693 0) ; It is an escaped % | |
| 694 (progn | |
| 695 (delete-char 1) | |
| 696 (skip-chars-forward "%.")) | |
| 697 (setq save-pos (point)) | |
| 698 (skip-chars-forward "%") | |
| 699 (setq save-chr (char-after (point))) | |
| 700 (cond | |
| 701 ((null save-chr) nil) | |
| 702 ((= save-chr ?t) | |
| 703 (delete-region save-pos (progn (forward-char 1) (point))) | |
| 704 (insert (or (cdr (assoc "type" type-info)) "\"\""))) | |
| 705 ((= save-chr ?M) | |
| 706 (delete-region save-pos (progn (forward-char 1) (point))) | |
| 707 (insert "\"\"")) | |
| 708 ((= save-chr ?n) | |
| 709 (delete-region save-pos (progn (forward-char 1) (point))) | |
| 710 (insert "\"\"")) | |
| 711 ((= save-chr ?F) | |
| 712 (delete-region save-pos (progn (forward-char 1) (point))) | |
| 713 (insert "\"\"")) | |
| 714 ((= save-chr ?{) | |
| 715 (forward-char 1) | |
| 716 (skip-chars-forward "^}") | |
| 717 (downcase-region (+ 2 save-pos) (point)) | |
| 718 (setq subst (buffer-substring (+ 2 save-pos) (point))) | |
| 719 (delete-region save-pos (1+ (point))) | |
| 720 (insert (or (cdr (assoc subst type-info)) "\"\""))) | |
| 721 (t nil)))) | |
| 722 (buffer-string))) | |
| 723 (t (error "Bad value to mm-unescape-mime-test. %s" test))))) | |
| 724 | |
| 725 (defun mm-viewer-passes-test (viewer-info type-info) | |
| 726 ;; Return non-nil iff the viewer specified by VIEWER-INFO passes its | |
| 727 ;; test clause (if any). | |
| 728 (let* ((test-info (assoc "test" viewer-info)) | |
| 729 (test (cdr test-info)) | |
| 730 (viewer (cdr (assoc "viewer" viewer-info))) | |
| 731 status | |
| 732 parsed-test | |
| 733 ) | |
| 734 (cond | |
| 735 ((not test-info) t) ; No test clause | |
| 736 ((not test) nil) ; Already failed test | |
| 737 ((eq test t) t) ; Already passed test | |
| 738 ((and (symbolp test) ; Lisp function as test | |
| 739 (fboundp test)) | |
| 740 (funcall test type-info)) | |
| 741 ((and (symbolp test) ; Lisp variable as test | |
| 742 (boundp test)) | |
| 743 (symbol-value test)) | |
| 744 ((and (listp test) ; List to be eval'd | |
| 745 (symbolp (car test))) | |
| 746 (eval test)) | |
| 747 (t | |
| 748 (setq test (mm-unescape-mime-test test type-info) | |
| 749 test (list "/bin/sh" nil nil nil "-c" test) | |
| 750 status (apply 'call-process test)) | |
| 751 (= 0 status))))) | |
| 752 | |
| 753 (defun mm-add-mailcap-entry (major minor info) | |
| 754 (let ((old-major (assoc major mm-mime-data))) | |
| 755 (if (null old-major) ; New major area | |
| 756 (setq mm-mime-data | |
| 757 (cons (cons major (list (cons minor info))) | |
| 758 mm-mime-data)) | |
| 759 (let ((cur-minor (assoc minor old-major))) | |
| 760 (cond | |
| 761 ((or (null cur-minor) ; New minor area, or | |
| 762 (assoc "test" info)) ; Has a test, insert at beginning | |
| 763 (setcdr old-major (cons (cons minor info) (cdr old-major)))) | |
| 764 ((and (not (assoc "test" info)); No test info, replace completely | |
| 765 (not (assoc "test" cur-minor))) | |
| 766 (setcdr cur-minor info)) | |
| 767 (t | |
| 768 (setcdr old-major (cons (cons minor info) (cdr old-major))))))))) | |
| 769 | |
| 770 | |
| 771 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 772 ;;; The main whabbo | |
| 773 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 774 (defun mm-viewer-lessp (x y) | |
| 775 ;; Return t iff viewer X is more desirable than viewer Y | |
| 776 (let ((x-wild (string-match "[*?]" (or (cdr-safe (assoc "type" x)) ""))) | |
| 777 (y-wild (string-match "[*?]" (or (cdr-safe (assoc "type" y)) ""))) | |
| 778 (x-lisp (not (stringp (or (cdr-safe (assoc "viewer" x)) "")))) | |
| 779 (y-lisp (not (stringp (or (cdr-safe (assoc "viewer" y)) ""))))) | |
| 780 (cond | |
| 781 ((and x-lisp (not y-lisp)) | |
| 782 t) | |
| 783 ((and (not y-lisp) x-wild (not y-wild)) | |
| 784 t) | |
| 785 ((and (not x-wild) y-wild) | |
| 786 t) | |
| 787 (t nil)))) | |
| 788 | |
| 789 (defun mm-mime-info (st &optional nd request) | |
| 790 "Get the mime viewer command for HEADERLINE, return nil if none found. | |
| 791 Expects a complete content-type header line as its argument. This can | |
| 792 be simple like text/html, or complex like text/plain; charset=blah; foo=bar | |
| 793 | |
| 794 Third argument REQUEST specifies what information to return. If it is | |
| 795 nil or the empty string, the viewer (second field of the mailcap | |
| 796 entry) will be returned. If it is a string, then the mailcap field | |
| 797 corresponding to that string will be returned (print, description, | |
| 798 whatever). If a number, then all the information for this specific | |
| 799 viewer is returned." | |
| 800 (let ( | |
| 801 major ; Major encoding (text, etc) | |
| 802 minor ; Minor encoding (html, etc) | |
| 803 info ; Other info | |
| 804 save-pos ; Misc. position during parse | |
| 805 major-info ; (assoc major mm-mime-data) | |
| 806 minor-info ; (assoc minor major-info) | |
| 807 test ; current test proc. | |
| 808 viewers ; Possible viewers | |
| 809 passed ; Viewers that passed the test | |
| 810 viewer ; The one and only viewer | |
| 811 ) | |
| 812 (save-excursion | |
| 813 (cond | |
| 814 ((null st) | |
| 815 (set-buffer (get-buffer-create " *mimeparse*")) | |
| 816 (erase-buffer) | |
| 817 (insert "text/plain") | |
| 818 (setq st (point-min))) | |
| 819 ((stringp st) | |
| 820 (set-buffer (get-buffer-create " *mimeparse*")) | |
| 821 (erase-buffer) | |
| 822 (insert st) | |
| 823 (setq st (point-min))) | |
| 824 ((null nd) | |
| 825 (narrow-to-region st (progn (goto-char st) (end-of-line) (point)))) | |
| 826 (t (narrow-to-region st nd))) | |
| 827 (goto-char st) | |
| 828 (skip-chars-forward ": \t\n") | |
| 829 (buffer-enable-undo) | |
| 830 (setq viewer | |
| 831 (catch 'mm-exit | |
| 832 (setq save-pos (point)) | |
| 833 (skip-chars-forward "^/") | |
| 834 (downcase-region save-pos (point)) | |
| 835 (setq major (buffer-substring save-pos (point))) | |
| 836 (if (not (setq major-info (cdr (assoc major mm-mime-data)))) | |
| 837 (throw 'mm-exit nil)) | |
| 838 (skip-chars-forward "/ \t\n") | |
| 839 (setq save-pos (point)) | |
| 840 (skip-chars-forward "^ \t\n;") | |
| 841 (downcase-region save-pos (point)) | |
| 842 (setq minor (buffer-substring save-pos (point))) | |
| 843 (if (not | |
| 844 (setq viewers (mm-possible-viewers major-info minor))) | |
| 845 (throw 'mm-exit nil)) | |
| 846 (skip-chars-forward "; \t") | |
| 847 (if (eolp) | |
| 848 nil ; No qualifiers | |
| 849 (setq save-pos (point)) | |
| 850 (end-of-line) | |
| 851 (setq info (mm-parse-args save-pos (point))) | |
| 852 ) | |
| 853 (while viewers | |
| 854 (if (mm-viewer-passes-test (car viewers) info) | |
| 855 (setq passed (cons (car viewers) passed))) | |
| 856 (setq viewers (cdr viewers))) | |
| 857 (setq passed (sort (nreverse passed) 'mm-viewer-lessp)) | |
| 858 (car passed))) | |
| 859 (if (and (stringp (cdr (assoc "viewer" viewer))) | |
| 860 passed) | |
| 861 (setq viewer (car passed))) | |
| 862 (widen) | |
| 863 (cond | |
| 864 ((and (null viewer) (not (equal major "default"))) | |
| 865 (mm-mime-info "default" nil request)) | |
| 866 ((or (null request) (equal request "")) | |
| 867 (mm-unescape-mime-test (cdr (assoc "viewer" viewer)) info)) | |
| 868 ((stringp request) | |
| 869 (if (or (string= request "test") (string= request "viewer")) | |
| 870 (mm-unescape-mime-test (cdr-safe (assoc request viewer)) info))) | |
| 871 (t | |
| 872 ;; MUST make a copy *sigh*, else we modify mm-mime-data | |
| 873 (setq viewer (mm-copy-tree viewer)) | |
| 874 (let ((view (assoc "viewer" viewer)) | |
| 875 (test (assoc "test" viewer))) | |
| 876 (if view (setcdr view (mm-unescape-mime-test (cdr view) info))) | |
| 877 (if test (setcdr test (mm-unescape-mime-test (cdr test) info)))) | |
| 878 viewer))))) | |
| 879 | |
| 880 | |
| 881 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 882 ;;; Experimental MIME-types parsing | |
| 883 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 884 (defvar mm-mime-extensions | |
| 885 '( | |
| 886 ("" . "text/plain") | |
| 887 (".abs" . "audio/x-mpeg") | |
| 888 (".aif" . "audio/aiff") | |
| 889 (".aifc" . "audio/aiff") | |
| 890 (".aiff" . "audio/aiff") | |
| 891 (".ano" . "application/x-annotator") | |
| 892 (".au" . "audio/ulaw") | |
| 893 (".avi" . "video/x-msvideo") | |
| 894 (".bcpio" . "application/x-bcpio") | |
| 895 (".bin" . "application/octet-stream") | |
| 896 (".cdf" . "application/x-netcdr") | |
| 897 (".cpio" . "application/x-cpio") | |
| 898 (".csh" . "application/x-csh") | |
| 899 (".dvi" . "application/x-dvi") | |
| 900 (".el" . "application/emacs-lisp") | |
| 901 (".eps" . "application/postscript") | |
| 902 (".etx" . "text/x-setext") | |
| 903 (".exe" . "application/octet-stream") | |
| 904 (".fax" . "image/x-fax") | |
| 905 (".gif" . "image/gif") | |
| 906 (".hdf" . "application/x-hdf") | |
| 907 (".hqx" . "application/mac-binhex40") | |
| 908 (".htm" . "text/html") | |
| 909 (".html" . "text/html") | |
| 910 (".icon" . "image/x-icon") | |
| 911 (".ief" . "image/ief") | |
| 912 (".jpg" . "image/jpeg") | |
| 913 (".macp" . "image/x-macpaint") | |
| 914 (".man" . "application/x-troff-man") | |
| 915 (".me" . "application/x-troff-me") | |
| 916 (".mif" . "application/mif") | |
| 917 (".mov" . "video/quicktime") | |
| 918 (".movie" . "video/x-sgi-movie") | |
| 919 (".mp2" . "audio/x-mpeg") | |
| 920 (".mp2a" . "audio/x-mpeg2") | |
| 921 (".mpa" . "audio/x-mpeg") | |
| 922 (".mpa2" . "audio/x-mpeg2") | |
| 923 (".mpe" . "video/mpeg") | |
| 924 (".mpeg" . "video/mpeg") | |
| 925 (".mpega" . "audio/x-mpeg") | |
| 926 (".mpegv" . "video/mpeg") | |
| 927 (".mpg" . "video/mpeg") | |
| 928 (".mpv" . "video/mpeg") | |
| 929 (".ms" . "application/x-troff-ms") | |
| 930 (".nc" . "application/x-netcdf") | |
| 931 (".nc" . "application/x-netcdf") | |
| 932 (".oda" . "application/oda") | |
| 933 (".pbm" . "image/x-portable-bitmap") | |
| 934 (".pdf" . "application/pdf") | |
| 935 (".pgm" . "image/portable-graymap") | |
| 936 (".pict" . "image/pict") | |
| 937 (".pnm" . "image/x-portable-anymap") | |
| 938 (".ppm" . "image/portable-pixmap") | |
| 939 (".ps" . "application/postscript") | |
| 940 (".qt" . "video/quicktime") | |
| 941 (".ras" . "image/x-raster") | |
| 942 (".rgb" . "image/x-rgb") | |
| 943 (".rtf" . "application/rtf") | |
| 944 (".rtx" . "text/richtext") | |
| 945 (".sh" . "application/x-sh") | |
| 946 (".sit" . "application/x-stuffit") | |
| 947 (".snd" . "audio/basic") | |
| 948 (".src" . "application/x-wais-source") | |
| 949 (".tar" . "archive/tar") | |
| 950 (".tcl" . "application/x-tcl") | |
| 951 (".tcl" . "application/x-tcl") | |
| 952 (".tex" . "application/x-tex") | |
| 953 (".texi" . "application/texinfo") | |
| 954 (".tga" . "image/x-targa") | |
| 955 (".tif" . "image/tiff") | |
| 956 (".tiff" . "image/tiff") | |
| 957 (".tr" . "application/x-troff") | |
| 958 (".troff" . "application/x-troff") | |
| 959 (".tsv" . "text/tab-separated-values") | |
| 960 (".txt" . "text/plain") | |
| 961 (".vbs" . "video/mpeg") | |
| 962 (".vox" . "audio/basic") | |
| 963 (".vrml" . "x-world/x-vrml") | |
| 964 (".wav" . "audio/x-wav") | |
| 965 (".wrl" . "x-world/x-vrml") | |
| 966 (".xbm" . "image/xbm") | |
| 967 (".xpm" . "image/x-pixmap") | |
| 968 (".xwd" . "image/windowdump") | |
| 969 (".zip" . "application/zip") | |
| 970 (".ai" . "application/postscript") | |
| 971 (".jpe" . "image/jpeg") | |
| 972 (".jpeg" . "image/jpeg") | |
| 973 ) | |
| 974 "*An assoc list of file extensions and the MIME content-types they | |
| 975 correspond to.") | |
| 976 | |
| 977 (defun mm-parse-mimetypes (&optional path) | |
| 978 ;; Parse out all the mimetypes specified in a unix-style path string PATH | |
| 979 (cond | |
| 980 (path nil) | |
| 981 ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES"))) | |
| 982 ((memq system-type '(ms-dos ms-windows windows-nt)) | |
| 983 (setq path (mapconcat 'expand-file-name | |
| 984 '("~/mime.typ" "~/etc/mime.typ") ";"))) | |
| 985 (t (setq path (concat (expand-file-name "~/.mime-types") ":" | |
| 986 "/etc/mime-types:/usr/etc/mime-types:" | |
| 987 "/usr/local/etc/mime-types:" | |
| 988 "/usr/local/www/conf/mime-types")))) | |
| 989 (let ((fnames (mm-string-to-tokens path | |
| 990 (if (memq system-type | |
| 991 '(ms-dos ms-windows windows-nt)) | |
| 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 (= (string-to-char extn) ?.))) | |
| 1040 (setq extn (concat "." extn))) | |
| 1041 (cdr (assoc (downcase extn) mm-mime-extensions))) | |
| 1042 | |
| 1043 | |
| 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 (or shell-file-name | |
| 1063 (getenv "ESHELL") (getenv "SHELL") "/bin/sh") | |
| 1064 nil (if usef nil buff) nil "-c" 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 | |
| 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 | |
| 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 (if (featurep 'mule) | |
| 1097 (write-region (point-min) (point-max) fname nil nil *noconv*) | |
| 1098 (write-region (point-min) (point-max) fname)) | |
| 1099 (kill-buffer (current-buffer)) | |
| 1100 (play-sound-file fname) | |
| 1101 (condition-case () | |
| 1102 (delete-file fname) | |
| 1103 (error nil)))) | |
| 1104 | |
| 1105 (defun mm-parse-mime-headers (&optional no-delete) | |
| 1106 "Return a list of the MIME headers at the top of this buffer. If | |
| 1107 optional argument NO-DELETE is non-nil, don't delete the headers." | |
| 1108 (let* ((st (point-min)) | |
| 1109 (nd (progn | |
| 1110 (goto-char (point-min)) | |
| 1111 (skip-chars-forward " \t\n") | |
| 1112 (if (re-search-forward "^\r*$" nil t) | |
| 1113 (1+ (point)) | |
| 1114 (point-max)))) | |
| 1115 save-pos | |
| 1116 status | |
| 1117 hname | |
| 1118 hvalu | |
| 1119 result | |
| 1120 ) | |
| 1121 (narrow-to-region st nd) | |
| 1122 (goto-char (point-min)) | |
| 1123 (while (not (eobp)) | |
| 1124 (skip-chars-forward " \t\n\r") | |
| 1125 (setq save-pos (point)) | |
| 1126 (skip-chars-forward "^:\n\r") | |
| 1127 (downcase-region save-pos (point)) | |
| 1128 (setq hname (buffer-substring save-pos (point))) | |
| 1129 (skip-chars-forward ": \t ") | |
| 1130 (setq save-pos (point)) | |
| 1131 (skip-chars-forward "^\n\r") | |
| 1132 (setq hvalu (buffer-substring save-pos (point)) | |
| 1133 result (cons (cons hname hvalu) result))) | |
| 1134 (or no-delete (delete-region st nd)) | |
| 1135 result)) | |
| 1136 | |
| 1137 (defun mm-find-available-multiparts (separator &optional buf) | |
| 1138 "Return a list of mime-headers for the various body parts of a | |
| 1139 multipart message in buffer BUF with separator SEPARATOR. | |
| 1140 The different multipart specs are put in `mm-temporary-directory'." | |
| 1141 (let ((sep (concat "^--" separator "\r*$")) | |
| 1142 headers | |
| 1143 fname | |
| 1144 results) | |
| 1145 (save-excursion | |
| 1146 (and buf (set-buffer buf)) | |
| 1147 (goto-char (point-min)) | |
| 1148 (while (re-search-forward sep nil t) | |
| 1149 (let ((st (set-marker (make-marker) | |
| 1150 (progn | |
| 1151 (forward-line 1) | |
| 1152 (beginning-of-line) | |
| 1153 (point)))) | |
| 1154 (nd (set-marker (make-marker) | |
| 1155 (if (re-search-forward sep nil t) | |
| 1156 (1- (match-beginning 0)) | |
| 1157 (point-max))))) | |
| 1158 (narrow-to-region st nd) | |
| 1159 (goto-char st) | |
| 1160 (if (looking-at "^\r*$") | |
| 1161 (insert "Content-type: text/plain\n" | |
| 1162 "Content-length: " (int-to-string (- nd st)) "\n")) | |
| 1163 (setq headers (mm-parse-mime-headers) | |
| 1164 fname (mm-generate-unique-filename)) | |
| 1165 (let ((x (or (cdr (assoc "content-type" headers)) "text/plain"))) | |
| 1166 (if (string-match "name=\"*\\([^ \"]+\\)\"*" x) | |
| 1167 (setq fname (expand-file-name | |
| 1168 (substring x (match-beginning 1) | |
| 1169 (match-end 1)) | |
| 1170 mm-temporary-directory)))) | |
| 1171 (widen) | |
| 1172 (if (assoc "content-transfer-encoding" headers) | |
| 1173 (let ((coding (cdr | |
| 1174 (assoc "content-transfer-encoding" headers))) | |
| 1175 (cmd nil)) | |
| 1176 (setq coding (and coding (downcase coding)) | |
| 1177 cmd (or (cdr (assoc coding | |
| 1178 mm-content-transfer-encodings)) | |
| 1179 (read-string | |
| 1180 (concat "How shall I decode " coding "? ") | |
| 1181 "cat"))) | |
| 1182 (if (string= cmd "") (setq cmd "cat")) | |
| 1183 (if (stringp cmd) | |
| 1184 (shell-command-on-region st nd cmd t) | |
| 1185 (funcall cmd st nd)) | |
| 1186 (set-marker nd (point)))) | |
| 1187 (write-region st nd fname nil 5) | |
| 1188 (delete-region st nd) | |
| 1189 (setq results (cons | |
| 1190 (cons | |
| 1191 (cons "mm-filename" fname) headers) results))))) | |
| 1192 results)) | |
| 1193 | |
| 1194 (defun mm-format-multipart-as-html (&optional buf type) | |
| 1195 (if buf (set-buffer buf)) | |
| 1196 (let* ((boundary (if (string-match | |
| 1197 "boundary[ \t]*=[ \t\"]*\\([^ \"\t\n]+\\)" | |
| 1198 type) | |
| 1199 (regexp-quote | |
| 1200 (substring type (match-beginning 1) (match-end 1))))) | |
| 1201 (parts (mm-find-available-multiparts boundary))) | |
| 1202 (erase-buffer) | |
| 1203 (insert "<html>\n" | |
| 1204 " <head>\n" | |
| 1205 " <title>Multipart Message</title>\n" | |
| 1206 " </head>\n" | |
| 1207 " <body>\n" | |
| 1208 " <h1> Multipart message encountered </h1>\n" | |
| 1209 " <p> I have encountered a multipart MIME message.\n" | |
| 1210 " The following parts have been detected. Please\n" | |
| 1211 " select which one you want to view.\n" | |
| 1212 " </p>\n" | |
| 1213 " <ul>\n" | |
| 1214 (mapconcat | |
| 1215 (function (lambda (x) | |
| 1216 (concat " <li> <a href=\"file:" | |
| 1217 (cdr (assoc "mm-filename" x)) | |
| 1218 "\">" | |
| 1219 (or (cdr (assoc "content-description" x)) "") | |
| 1220 "--" | |
| 1221 (or (cdr (assoc "content-type" x)) | |
| 1222 "unknown type") | |
| 1223 "</a> </li>"))) | |
| 1224 parts "\n") | |
| 1225 " </ul>\n" | |
| 1226 " </body>\n" | |
| 1227 "</html>\n" | |
| 1228 "<!-- Automatically generated by MM v" mm-version "-->\n"))) | |
| 1229 | |
| 1230 (defun mm-multipart-viewer () | |
| 1231 (mm-format-multipart-as-html | |
| 1232 (current-buffer) | |
| 1233 (cdr (assoc "content-type" url-current-mime-headers))) | |
| 1234 (let ((w3-working-buffer (current-buffer))) | |
| 1235 (w3-prepare-buffer))) | |
| 1236 | |
| 1237 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1238 ;;; Transfer encodings we can decrypt automatically | |
| 1239 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1240 (defun mm-decode-quoted-printable (&optional st nd) | |
| 1241 (interactive) | |
| 1242 (setq st (or st (point-min)) | |
| 1243 nd (or nd (point-max))) | |
| 1244 (save-restriction | |
| 1245 (narrow-to-region st nd) | |
| 1246 (save-excursion | |
| 1247 (let ((buffer-read-only nil)) | |
| 1248 (goto-char (point-min)) | |
| 1249 (while (re-search-forward "=[0-9A-F][0-9A-F]" nil t) | |
| 1250 (replace-match | |
| 1251 (char-to-string | |
| 1252 (+ | |
| 1253 (* 16 (mm-hex-char-to-integer | |
| 1254 (char-after (1+ (match-beginning 0))))) | |
| 1255 (mm-hex-char-to-integer | |
| 1256 (char-after (1- (match-end 0)))))))))))) | |
| 1257 | |
| 1258 ;; Taken from hexl.el. | |
| 1259 (defun mm-hex-char-to-integer (character) | |
| 1260 "Take a char and return its value as if it was a hex digit." | |
| 1261 (if (and (>= character ?0) (<= character ?9)) | |
| 1262 (- character ?0) | |
| 1263 (let ((ch (logior character 32))) | |
| 1264 (if (and (>= ch ?a) (<= ch ?f)) | |
| 1265 (- ch (- ?a 10)) | |
| 1266 (error (format "Invalid hex digit `%c'." ch)))))) | |
| 1267 | |
| 1268 | |
| 1269 (require 'base64) | |
| 1270 (provide 'mm) |