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