git.chise.org Git - elisp/gnus.git-/blob - lisp/mm.el

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