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