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