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