git.chise.org Git - elisp/gnus.git-/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 (defvar mm-content-id-alist nil)
  67
  68 ;;; Convenience macros.
  69
  70 (defmacro mm-handle-buffer (handle)
  71   `(nth 0 ,handle))
  72 (defmacro mm-handle-type (handle)
  73   `(nth 1 ,handle))
  74 (defmacro mm-handle-encoding (handle)
  75   `(nth 2 ,handle))
  76 (defmacro mm-handle-undisplayer (handle)
  77   `(nth 3 ,handle))
  78 (defmacro mm-handle-set-undisplayer (handle function)
  79   `(setcar (nthcdr 3 ,handle) ,function))
  80 (defmacro mm-handle-disposition (handle)
  81   `(nth 4 ,handle))
  82 (defmacro mm-handle-description (handle)
  83   `(nth 5 ,handle))
  84
  85 ;;; The functions.
  86
  87 (defun mm-dissect-buffer (&optional no-strict-mime)
  88   "Dissect the current buffer and return a list of MIME handles."
  89   (save-excursion
  90     (let (ct ctl type subtype cte cd description id result)
  91       (save-restriction
  92         (mail-narrow-to-head)
  93         (when (and (or no-strict-mime
  94                        (mail-fetch-field "mime-version"))
  95                    (setq ct (mail-fetch-field "content-type")))
  96           (setq ctl (mail-header-parse-content-type ct)
  97                 cte (mail-fetch-field "content-transfer-encoding")
  98                 cd (mail-fetch-field "content-disposition")
  99                 description (mail-fetch-field "content-description")
 100                 id (mail-fetch-field "content-id"))))
 101       (when ctl
 102         (setq type (split-string (car ctl) "/"))
 103         (setq subtype (cadr type)
 104               type (pop type))
 105         (setq
 106          result
 107          (cond
 108           ((equal type "multipart")
 109            (mm-dissect-multipart ctl))
 110           (t
 111            (mm-dissect-singlepart
 112             ctl
 113             (and cte (intern (downcase (mail-header-remove-whitespace
 114                                         (mail-header-remove-comments
 115                                          cte)))))
 116             no-strict-mime
 117             (and cd (mail-header-parse-content-disposition cd))))))
 118         (when id
 119           (push (cons id result) mm-content-id-alist))
 120         result))))
 121
 122 (defun mm-dissect-singlepart (ctl cte &optional force cdl description)
 123   (when (or force
 124             (not (equal "text/plain" (car ctl))))
 125     (let ((res (list (list (mm-copy-to-buffer) ctl cte nil cdl description))))
 126       (push (car res) mm-dissection-list)
 127       res)))
 128
 129 (defun mm-remove-all-parts ()
 130   "Remove all MIME handles."
 131   (interactive)
 132   (mapcar 'mm-remove-part mm-dissection-list)
 133   (setq mm-dissection-list nil))
 134
 135 (defun mm-dissect-multipart (ctl)
 136   (goto-char (point-min))
 137   (let ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
 138         start parts end)
 139     (while (search-forward boundary nil t)
 140       (forward-line -1)
 141       (when start
 142         (save-excursion
 143           (save-restriction
 144             (narrow-to-region start (point))
 145             (setq parts (nconc (mm-dissect-buffer t) parts)))))
 146       (forward-line 2)
 147       (setq start (point)))
 148     (nreverse parts)))
 149
 150 (defun mm-copy-to-buffer ()
 151   "Copy the contents of the current buffer to a fresh buffer."
 152   (save-excursion
 153     (let ((obuf (current-buffer))
 154           beg)
 155       (goto-char (point-min))
 156       (search-forward "\n\n" nil t)
 157       (setq beg (point))
 158       (set-buffer (generate-new-buffer " *mm*"))
 159       (insert-buffer-substring obuf beg)
 160       (current-buffer))))
 161
 162 (defun mm-display-part (handle)
 163   "Display the MIME part represented by HANDLE."
 164   (save-excursion
 165     (mailcap-parse-mailcaps)
 166     (if (mm-handle-undisplayer handle)
 167         (mm-remove-part handle)
 168       (let* ((type (car (mm-handle-type handle)))
 169              (method (mailcap-mime-info type))
 170              (user-method (mm-user-method type)))
 171         (if (eq user-method 'inline)
 172             (progn
 173               (forward-line 1)
 174               (mm-display-inline handle))
 175           (mm-display-external
 176            handle (or user-method method 'mailcap-save-binary-file)))))))
 177
 178 (defun mm-display-external (handle method)
 179   "Display HANDLE using METHOD."
 180   (mm-with-unibyte-buffer
 181     (insert-buffer-substring (mm-handle-buffer handle))
 182     (mm-decode-content-transfer-encoding (mm-handle-encoding handle))
 183     (if (functionp method)
 184         (let ((cur (current-buffer)))
 185           (switch-to-buffer (generate-new-buffer "*mm*"))
 186           (insert-buffer-substring cur)
 187           (funcall method)
 188           (mm-handle-set-undisplayer handle (current-buffer)))
 189       (let* ((file (make-temp-name (expand-file-name "emm." mm-tmp-directory)))
 190              process)
 191         (write-region (point-min) (point-max)
 192                       file nil 'nomesg nil 'no-conversion)
 193         (setq process
 194               (start-process "*display*" nil shell-file-name
 195                              "-c" (format method file)))
 196         (mm-handle-set-undisplayer handle (cons file process))
 197         (message "Displaying %s..." (format method file))))))
 198
 199 (defun mm-remove-part (handle)
 200   "Remove the displayed MIME part represented by HANDLE."
 201   (let ((object (mm-handle-undisplayer handle)))
 202     (condition-case ()
 203         (cond
 204          ;; Internally displayed part.
 205          ((mm-annotationp object)
 206           (delete-annotation object))
 207          ((or (functionp object)
 208               (and (listp object)
 209                    (eq (car object) 'lambda)))
 210           (funcall object))
 211          ;; Externally displayed part.
 212          ((consp object)
 213           (condition-case ()
 214               (delete-file (car object))
 215             (error nil))
 216           (condition-case ()
 217               (kill-process (cdr object))
 218             (error nil)))
 219          ((bufferp object)
 220           (when (buffer-live-p object)
 221             (kill-buffer object))))
 222       (error nil))
 223     (mm-handle-set-undisplayer handle nil)))
 224
 225 (defun mm-display-inline (handle)
 226   (let* ((type (car (mm-handle-type handle)))
 227          (function (cadr (assoc type mm-inline-media-tests))))
 228     (funcall function handle)))
 229
 230 (defun mm-inlinable-p (type)
 231   "Say whether TYPE can be displayed inline."
 232   (let ((alist mm-inline-media-tests)
 233         test)
 234     (while alist
 235       (when (equal type (caar alist))
 236         (setq test (caddar alist)
 237               alist nil)
 238         (setq test (eval test)))
 239       (pop alist))
 240     test))
 241
 242 (defun mm-user-method (type)
 243   "Return the user-defined method for TYPE."
 244   (let ((methods mm-user-display-methods)
 245         method result)
 246     (while (setq method (pop methods))
 247       (when (string-match (car method) type)
 248         (when (or (not (eq (cdr method) 'inline))
 249                   (mm-inlinable-p type))
 250           (setq result (cdr method)
 251                 methods nil))))
 252     result))
 253
 254 (defun mm-automatic-display-p (type)
 255   "Return the user-defined method for TYPE."
 256   (let ((methods mm-user-automatic-display)
 257         method result)
 258     (while (setq method (pop methods))
 259       (when (string-match method type)
 260         (setq result t
 261               methods nil)))
 262     result))
 263
 264 (defun add-mime-display-method (type method)
 265   "Make parts of TYPE be displayed with METHOD.
 266 This overrides entries in the mailcap file."
 267   (push (cons type method) mm-user-display-methods))
 268
 269 (defun mm-destroy-part (handle)
 270   "Destroy the data structures connected to HANDLE."
 271   (mm-remove-part handle)
 272   (when (buffer-live-p (mm-handle-buffer handle))
 273     (kill-buffer (mm-handle-buffer handle))))
 274
 275 (defun mm-quote-arg (arg)
 276   "Return a version of ARG that is safe to evaluate in a shell."
 277   (let ((pos 0) new-pos accum)
 278     ;; *** bug: we don't handle newline characters properly
 279     (while (setq new-pos (string-match "[!`\"$\\& \t{}]" arg pos))
 280       (push (substring arg pos new-pos) accum)
 281       (push "\\" accum)
 282       (push (list (aref arg new-pos)) accum)
 283       (setq pos (1+ new-pos)))
 284     (if (= pos 0)
 285         arg
 286       (apply 'concat (nconc (nreverse accum) (list (substring arg pos)))))))
 287
 288 ;;;
 289 ;;; Functions for outputting parts
 290 ;;;
 291
 292 (defun mm-get-part (handle)
 293   "Return the contents of HANDLE as a string."
 294   (mm-with-unibyte-buffer
 295     (insert-buffer-substring (mm-handle-buffer handle))
 296     (mm-decode-content-transfer-encoding (mm-handle-encoding handle))
 297     (buffer-string)))
 298
 299 (defun mm-save-part (handle)
 300   "Write HANDLE to a file."
 301   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 302          (filename (mail-content-type-get
 303                     (mm-handle-disposition handle) 'filename))
 304          file)
 305     (when filename
 306       (setq filename (file-name-nondirectory filename)))
 307     (setq file
 308           (read-file-name "Save MIME part to: "
 309                           (expand-file-name
 310                            (or filename name "") default-directory)))
 311     (mm-with-unibyte-buffer
 312       (insert-buffer-substring (mm-handle-buffer handle))
 313       (mm-decode-content-transfer-encoding (mm-handle-encoding handle))
 314       (when (or (not (file-exists-p file))
 315                 (yes-or-no-p (format "File %s already exists; overwrite? "
 316                                      file)))
 317         (write-region (point-min) (point-max) file)))))
 318
 319 (defun mm-pipe-part (handle)
 320   "Pipe HANDLE to a process."
 321   (let* ((name (mail-content-type-get (car (mm-handle-type handle)) 'name))
 322          (command
 323           (read-string "Shell command on MIME part: " mm-last-shell-command)))
 324     (mm-with-unibyte-buffer
 325       (insert-buffer-substring (mm-handle-buffer handle))
 326       (mm-decode-content-transfer-encoding (mm-handle-encoding handle))
 327       (shell-command-on-region (point-min) (point-max) command nil))))
 328
 329 (defun mm-interactively-view-part (handle)
 330   "Display HANDLE using METHOD."
 331   (let* ((type (car (mm-handle-type handle)))
 332          (methods
 333           (mapcar (lambda (i) (list (cdr (assoc "viewer" i))))
 334                   (mailcap-mime-info type 'all)))
 335          (method (completing-read "Viewer: " methods)))
 336     (mm-display-external (copy-sequence handle) method)))
 337
 338 (defun mm-preferred-alternative (handles &optional preferred)
 339   "Say which of HANDLES are preferred."
 340   (let ((prec (if preferred (list preferred) mm-alternative-precedence))
 341         p h result type)
 342     (while (setq p (pop prec))
 343       (setq h handles)
 344       (while h
 345         (setq type (car (mm-handle-type (car h))))
 346         (when (and (equal p type)
 347                    (mm-automatic-display-p type)
 348                    (or (not (mm-handle-disposition (car h)))
 349                        (equal (car (mm-handle-disposition (car h)))
 350                               "inline")))
 351           (setq result (car h)
 352                 h nil
 353                 prec nil))
 354         (pop h)))
 355     result))
 356
 357 (defun mm-get-content-id (id)
 358   "Return the handle(s) referred to by ID."
 359   (cdr (assoc id mm-content-id-alist)))
 360
 361 (provide 'mm-decode)
 362
 363 ;; mm-decode.el ends here