cgit.sxemacs.org Git - gnus/blob - lisp/mm-decode.el

   1 ;;; mm-decode.el --- Functions for decoding MIME things
   2 ;; Copyright (C) 1998 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; This file is part of GNU Emacs.
   7
   8 ;; GNU Emacs is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2, or (at your option)
  11 ;; any later version.
  12
  13 ;; GNU Emacs is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  21 ;; Boston, MA 02111-1307, USA.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (require 'mail-parse)
  28 (require 'mailcap)
  29 (require 'mm-bodies)
  30
  31 (defvar mm-inline-media-tests
  32   '(("image/jpeg" mm-inline-image (featurep 'jpeg))
  33     ("image/png" mm-inline-image (featurep 'png))
  34     ("image/gif" mm-inline-image (featurep 'gif))
  35     ("image/tiff" mm-inline-image (featurep 'tiff))
  36     ("image/xbm" mm-inline-image (eq (device-type) 'x))
  37     ("image/xpm" mm-inline-image (featurep 'xpm))
  38     ("image/bmp" mm-inline-image (featurep 'bmp))
  39     ("text/plain" mm-inline-text t)
  40     ("text/html" mm-inline-text (featurep 'w3))
  41     ("audio/wav" mm-inline-audio
  42      (and (or (featurep 'nas-sound) (featurep 'native-sound))
  43           (device-sound-enabled-p)))
  44     ("audio/au" mm-inline-audio
  45      (and (or (featurep 'nas-sound) (featurep 'native-sound))
  46           (device-sound-enabled-p))))
  47   "Alist of media types/test that say whether the media types can be displayed inline.")
  48
  49 (defvar mm-user-display-methods
  50   '(("image/.*" . inline)
  51     ("text/.*" . inline)))
  52
  53 (defvar mm-user-automatic-display
  54   '("text/plain" "text/html" "image/gif"))
  55
  56 (defvar mm-alternative-precedence '("text/plain" "text/html")
  57   "List that describes the precedence of alternative parts.")
  58
  59 (defvar mm-tmp-directory "/tmp/"
  60   "Where mm will store its temporary files.")
  61
  62 ;;; Internal variables.
  63
  64 (defvar mm-dissection-list nil)
  65 (defvar mm-last-shell-command "")
  66
  67 ;;; Convenience macros.
  68
  69 (defmacro mm-handle-buffer (handle)
  70   `(nth 0 ,handle))
  71 (defmacro mm-handle-type (handle)
  72   `(nth 1 ,handle))
  73 (defmacro mm-handle-encoding (handle)
  74   `(nth 2 ,handle))
  75 (defmacro mm-handle-undisplayer (handle)
  76   `(nth 3 ,handle))
  77 (defmacro mm-handle-set-undisplayer (handle function)
  78   `(setcar (nthcdr 3 ,handle) ,function))
  79 (defmacro mm-handle-disposition (handle)
  80   `(nth 4 ,handle))
  81 (defmacro mm-handle-description (handle)
  82   `(nth 5 ,handle))
  83
  84 ;;; The functions.
  85
  86 (defun mm-dissect-buffer (&optional no-strict-mime)
  87   "Dissect the current buffer and return a list of MIME handles."
  88   (save-excursion
  89     (let (ct ctl type subtype cte cd description)
  90       (save-restriction
  91         (mail-narrow-to-head)
  92         (when (and (or no-strict-mime
  93                        (mail-fetch-field "mime-version"))
  94                    (setq ct (mail-fetch-field "content-type")))
  95           (setq ctl (mail-header-parse-content-type ct)
  96                 cte (mail-fetch-field "content-transfer-encoding")
  97                 cd (mail-fetch-field "content-disposition")
  98                 description (mail-fetch-field "content-description"))))
  99       (when ctl
 100         (setq type (split-string (car ctl) "/"))
 101         (setq subtype (cadr type)
 102               type (pop type))
 103         (cond
 104          ((equal type "multipart")
 105           (mm-dissect-multipart ctl))
 106          (t
 107           (mm-dissect-singlepart
 108            ctl
 109            (and cte (intern (downcase (mail-header-remove-whitespace
 110                                        (mail-header-remove-comments
 111                                         cte)))))
 112            no-strict-mime
 113            (and cd (mail-header-parse-content-disposition cd)))))))))
 114
 115 (defun mm-dissect-singlepart (ctl cte &optional force cdl description)
 116   (when (or force
 117             (not (equal "text/plain" (car ctl))))
 118     (let ((res (list (list (mm-copy-to-buffer) ctl cte nil cdl description))))
 119       (push (car res) mm-dissection-list)
 120       res)))
 121
 122 (defun mm-remove-all-parts ()
 123   "Remove all MIME handles."
 124   (interactive)
 125   (mapcar 'mm-remove-part mm-dissection-list)
 126   (setq mm-dissection-list nil))
 127
 128 (defun mm-dissect-multipart (ctl)
 129   (goto-char (point-min))
 130   (let ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
 131         start parts end)
 132     (while (search-forward boundary nil t)
 133       (forward-line -1)
 134       (when start
 135         (save-excursion
 136           (save-restriction
 137             (narrow-to-region start (point))
 138             (setq parts (nconc (mm-dissect-buffer t) parts)))))
 139       (forward-line 2)
 140       (setq start (point)))
 141     (nreverse parts)))
 142
 143 (defun mm-copy-to-buffer ()
 144   "Copy the contents of the current buffer to a fresh buffer."
 145   (save-excursion
 146     (let ((obuf (current-buffer))
 147           beg)
 148       (goto-char (point-min))
 149       (search-forward "\n\n" nil t)
 150       (setq beg (point))
 151       (set-buffer (generate-new-buffer " *mm*"))
 152       (insert-buffer-substring obuf beg)
 153       (current-buffer))))
 154
 155 (defun mm-display-part (handle)
 156   "Display the MIME part represented by HANDLE."
 157   (save-excursion
 158     (mailcap-parse-mailcaps)
 159     (if (mm-handle-undisplayer handle)
 160         (mm-remove-part handle)
 161       (let* ((type (car (mm-handle-type handle)))
 162              (method (mailcap-mime-info type))
 163              (user-method (mm-user-method type)))
 164         (if (eq user-method 'inline)
 165             (progn
 166               (forward-line 1)
 167               (mm-display-inline handle))
 168           (mm-display-external
 169            handle (or user-method method 'mailcap-save-binary-file)))))))
 170
 171 (defun mm-display-external (handle method)
 172   "Display HANDLE using METHOD."
 173   (mm-with-unibyte-buffer
 174     (insert-buffer-substring (mm-handle-buffer handle))
 175     (mm-decode-content-transfer-encoding (mm-handle-encoding handle))
 176     (if (functionp method)
 177         (let ((cur (current-buffer)))
 178           (switch-to-buffer (generate-new-buffer "*mm*"))
 179           (insert-buffer-substring cur)
 180           (funcall method)
 181           (mm-handle-set-undisplayer handle (current-buffer)))
 182       (let* ((file (make-temp-name (expand-file-name "emm." mm-tmp-directory)))
 183              process)
 184         (write-region (point-min) (point-max)
 185                       file nil 'nomesg nil 'no-conversion)
 186         (setq process
 187               (start-process "*display*" nil shell-file-name
 188                              "-c" (format method file)))
 189         (mm-handle-set-undisplayer handle (cons file process))
 190         (message "Displaying %s..." (format method file))))))
 191
 192 (defun mm-remove-part (handle)
 193   "Remove the displayed MIME part represented by HANDLE."
 194   (let ((object (mm-handle-undisplayer handle)))
 195     (condition-case ()
 196         (cond
 197          ;; Internally displayed part.
 198          ((mm-annotationp object)
 199           (delete-annotation object))
 200          ((or (functionp object)
 201               (and (listp object)
 202                    (eq (car object) 'lambda)))
 203           (funcall object))
 204          ;; Externally displayed part.
 205          ((consp object)
 206           (condition-case ()
 207               (delete-file (car object))
 208             (error nil))
 209           (condition-case ()
 210               (kill-process (cdr object))
 211             (error nil)))
 212          ((bufferp object)
 213           (when (buffer-live-p object)
 214             (kill-buffer object))))
 215       (error nil))
 216     (mm-handle-set-undisplayer handle nil)))
 217
 218 (defun mm-display-inline (handle)
 219   (let* ((type (car (mm-handle-type handle)))
 220          (function (cadr (assoc type mm-inline-media-tests))))
 221     (funcall function handle)))
 222
 223 (defun mm-inlinable-p (type)
 224   "Say whether TYPE can be displayed inline."
 225   (let ((alist mm-inline-media-tests)
 226         test)
 227     (while alist
 228       (when (equal type (caar alist))
 229         (setq test (caddar alist)
 230               alist nil)
 231         (setq test (eval test)))
 232       (pop alist))
 233     test))
 234
 235 (defun mm-user-method (type)
 236   "Return the user-defined method for TYPE."
 237   (let ((methods mm-user-display-methods)
 238         method result)
 239     (while (setq method (pop methods))
 240       (when (string-match (car method) type)
 241         (when (or (not (eq (cdr method) 'inline))
 242                   (mm-inlinable-p type))
 243           (setq result (cdr method)
 244                 methods nil))))
 245     result))
 246
 247 (defun mm-automatic-display-p (type)
 248   "Return the user-defined method for TYPE."
 249   (let ((methods mm-user-automatic-display)
 250         method result)
 251     (while (setq method (pop methods))
 252       (when (string-match method type)
 253         (setq result t
 254               methods nil)))
 255     result))
 256
 257 (defun add-mime-display-method (type method)
 258   "Make parts of TYPE be displayed with METHOD.
 259 This overrides entries in the mailcap file."
 260   (push (cons type method) mm-user-display-methods))
 261
 262 (defun mm-destroy-part (handle)
 263   "Destroy the data structures connected to HANDLE."
 264   (mm-remove-part handle)
 265   (when (buffer-live-p (mm-handle-buffer handle))
 266     (kill-buffer (mm-handle-buffer handle))))
 267
 268 (defun mm-quote-arg (arg)
 269   "Return a version of ARG that is safe to evaluate in a shell."
 270   (let ((pos 0) new-pos accum)
 271     ;; *** bug: we don't handle newline characters properly
 272     (while (setq new-pos (string-match "[!`\"$\\& \t{}]" arg pos))
 273       (push (substring arg pos new-pos) accum)
 274       (push "\\" accum)
 275       (push (list (aref arg new-pos)) accum)
 276       (setq pos (1+ new-pos)))
 277     (if (= pos 0)
 278         arg
 279       (apply 'concat (nconc (nreverse accum) (list (substring arg pos)))))))
 280
 281 ;;;
 282 ;;; Functions for outputting parts
 283 ;;;
 284
 285 (defun mm-get-part (handle)
 286   "Return the contents of HANDLE as a string."
 287   (mm-with-unibyte-buffer
 288     (insert-buffer-substring (mm-handle-buffer handle))
 289     (mm-decode-content-transfer-encoding (mm-handle-encoding handle))
 290     (buffer-string)))
 291
 292 (defun mm-save-part (handle)
 293   "Write HANDLE to a file."
 294   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 295          (filename (mail-content-type-get
 296                     (mm-handle-disposition handle) 'filename))
 297          file)
 298     (when filename
 299       (setq filename (file-name-nondirectory filename)))
 300     (setq file
 301           (read-file-name "Save MIME part to: "
 302                           (expand-file-name
 303                            (or filename name "") default-directory)))
 304     (mm-with-unibyte-buffer
 305       (insert-buffer-substring (mm-handle-buffer handle))
 306       (mm-decode-content-transfer-encoding (mm-handle-encoding handle))
 307       (when (or (not (file-exists-p file))
 308                 (yes-or-no-p (format "File %s already exists; overwrite? ")))
 309         (write-region (point-min) (point-max) file)))))
 310
 311 (defun mm-pipe-part (handle)
 312   "Pipe HANDLE to a process."
 313   (let* ((name (mail-content-type-get (car (mm-handle-type handle)) 'name))
 314          (command
 315           (read-string "Shell command on MIME part: " mm-last-shell-command)))
 316     (mm-with-unibyte-buffer
 317       (insert-buffer-substring (mm-handle-buffer handle))
 318       (mm-decode-content-transfer-encoding (mm-handle-encoding handle))
 319       (shell-command-on-region (point-min) (point-max) command nil))))
 320
 321 (defun mm-interactively-view-part (handle)
 322   "Display HANDLE using METHOD."
 323   (let* ((type (car (mm-handle-type handle)))
 324          (methods
 325           (mapcar (lambda (i) (list (cdr (assoc "viewer" i))))
 326                   (mailcap-mime-info type 'all)))
 327          (method (completing-read "Viewer: " methods)))
 328     (mm-display-external (copy-sequence handle) method)))
 329
 330 (defun mm-preferred-alternative (handles &optional preferred)
 331   "Say which of HANDLES are preferred."
 332   (let ((prec (if preferred (list preferred) mm-alternative-precedence))
 333         p h result type)
 334     (while (setq p (pop prec))
 335       (setq h handles)
 336       (while h
 337         (setq type (car (mm-handle-type (car h))))
 338         (when (and (equal p type)
 339                    (mm-automatic-display-p type)
 340                    (or (not (mm-handle-disposition (car h)))
 341                        (equal (car (mm-handle-disposition (car h)))
 342                               "inline")))
 343           (setq result (car h)
 344                 h nil
 345                 prec nil))
 346         (pop h)))
 347     result))
 348
 349 (provide 'mm-decode)
 350
 351 ;; mm-decode.el ends here