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           (buffer-disable-undo)
 196           (mm-set-buffer-file-coding-system 'no-conversion)
 197           (insert-buffer-substring cur)
 198           (funcall method)
 199           (mm-handle-set-undisplayer handle (current-buffer)))
 200       (let* ((dir (make-temp-name (expand-file-name "emm." mm-tmp-directory)))
 201              (filename (mail-content-type-get
 202                         (mm-handle-disposition handle) 'filename))
 203              (needsterm (assoc "needsterm"
 204                                (mailcap-mime-info
 205                                 (car (mm-handle-type handle)) t)))
 206              process file)
 207         ;; We create a private sub-directory where we store our files.
 208         (make-directory dir)
 209         (set-file-modes dir 448)
 210         (if filename
 211             (setq file (expand-file-name (or filename "mm.") dir))
 212           (setq file (make-temp-name (expand-file-name "mm." dir))))
 213         (write-region (point-min) (point-max)
 214                       file nil 'nomesg nil 'no-conversion)
 215         (setq process
 216               (if needsterm
 217                   (start-process "*display*" nil
 218                                  "xterm"
 219                                  "-e" (format method file))
 220                 (switch-to-buffer (generate-new-buffer "*mm*"))
 221                 (buffer-disable-undo)
 222                 (mm-set-buffer-file-coding-system 'no-conversion)
 223                 (start-process "*display*" (current-buffer)
 224                                shell-file-name
 225                                "-c" (format method file))))
 226         (mm-handle-set-undisplayer handle (cons file process))
 227         (message "Displaying %s..." (format method file))))))
 228
 229 (defun mm-remove-part (handle)
 230   "Remove the displayed MIME part represented by HANDLE."
 231   (let ((object (mm-handle-undisplayer handle)))
 232     (condition-case ()
 233         (cond
 234          ;; Internally displayed part.
 235          ((mm-annotationp object)
 236           (delete-annotation object))
 237          ((or (functionp object)
 238               (and (listp object)
 239                    (eq (car object) 'lambda)))
 240           (funcall object))
 241          ;; Externally displayed part.
 242          ((consp object)
 243           (condition-case ()
 244               (delete-file (car object))
 245             (error nil))
 246           (condition-case ()
 247               (delete-directory (file-name-directory (car object)))
 248             (error nil))
 249           (condition-case ()
 250               (kill-process (cdr object))
 251             (error nil)))
 252          ((bufferp object)
 253           (when (buffer-live-p object)
 254             (kill-buffer object))))
 255       (error nil))
 256     (mm-handle-set-undisplayer handle nil)))
 257
 258 (defun mm-display-inline (handle)
 259   (let* ((type (car (mm-handle-type handle)))
 260          (function (cadr (assoc type mm-inline-media-tests))))
 261     (funcall function handle)))
 262
 263 (defun mm-inlinable-p (type)
 264   "Say whether TYPE can be displayed inline."
 265   (let ((alist mm-inline-media-tests)
 266         test)
 267     (while alist
 268       (when (equal type (caar alist))
 269         (setq test (caddar alist)
 270               alist nil)
 271         (setq test (eval test)))
 272       (pop alist))
 273     test))
 274
 275 (defun mm-user-method (type)
 276   "Return the user-defined method for TYPE."
 277   (let ((methods mm-user-display-methods)
 278         method result)
 279     (while (setq method (pop methods))
 280       (when (string-match (car method) type)
 281         (when (or (not (eq (cdr method) 'inline))
 282                   (mm-inlinable-p type))
 283           (setq result (cdr method)
 284                 methods nil))))
 285     result))
 286
 287 (defun mm-automatic-display-p (type)
 288   "Return the user-defined method for TYPE."
 289   (let ((methods mm-user-automatic-display)
 290         method result)
 291     (while (setq method (pop methods))
 292       (when (string-match method type)
 293         (setq result t
 294               methods nil)))
 295     result))
 296
 297 (defun add-mime-display-method (type method)
 298   "Make parts of TYPE be displayed with METHOD.
 299 This overrides entries in the mailcap file."
 300   (push (cons type method) mm-user-display-methods))
 301
 302 (defun mm-destroy-part (handle)
 303   "Destroy the data structures connected to HANDLE."
 304   (mm-remove-part handle)
 305   (when (buffer-live-p (mm-handle-buffer handle))
 306     (kill-buffer (mm-handle-buffer handle))))
 307
 308 (defun mm-quote-arg (arg)
 309   "Return a version of ARG that is safe to evaluate in a shell."
 310   (let ((pos 0) new-pos accum)
 311     ;; *** bug: we don't handle newline characters properly
 312     (while (setq new-pos (string-match "[!`\"$\\& \t{}]" arg pos))
 313       (push (substring arg pos new-pos) accum)
 314       (push "\\" accum)
 315       (push (list (aref arg new-pos)) accum)
 316       (setq pos (1+ new-pos)))
 317     (if (= pos 0)
 318         arg
 319       (apply 'concat (nconc (nreverse accum) (list (substring arg pos)))))))
 320
 321 ;;;
 322 ;;; Functions for outputting parts
 323 ;;;
 324
 325 (defun mm-get-part (handle)
 326   "Return the contents of HANDLE as a string."
 327   (mm-with-unibyte-buffer
 328     (insert-buffer-substring (mm-handle-buffer handle))
 329     (mm-decode-content-transfer-encoding (mm-handle-encoding handle))
 330     (buffer-string)))
 331
 332 (defvar mm-default-directory nil)
 333
 334 (defun mm-save-part (handle)
 335   "Write HANDLE to a file."
 336   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 337          (filename (mail-content-type-get
 338                     (mm-handle-disposition handle) 'filename))
 339          file)
 340     (when filename
 341       (setq filename (file-name-nondirectory filename)))
 342     (setq file
 343           (read-file-name "Save MIME part to: "
 344                           (expand-file-name
 345                            (or filename name "")
 346                            (or mm-default-directory default-directory))))
 347     (setq mm-default-directory (file-name-directory file))
 348     (mm-with-unibyte-buffer
 349       (insert-buffer-substring (mm-handle-buffer handle))
 350       (mm-decode-content-transfer-encoding (mm-handle-encoding handle))
 351       (when (or (not (file-exists-p file))
 352                 (yes-or-no-p (format "File %s already exists; overwrite? "
 353                                      file)))
 354         (write-region (point-min) (point-max) file)))))
 355
 356 (defun mm-pipe-part (handle)
 357   "Pipe HANDLE to a process."
 358   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 359          (command
 360           (read-string "Shell command on MIME part: " mm-last-shell-command)))
 361     (mm-with-unibyte-buffer
 362       (insert-buffer-substring (mm-handle-buffer handle))
 363       (mm-decode-content-transfer-encoding (mm-handle-encoding handle))
 364       (shell-command-on-region (point-min) (point-max) command nil))))
 365
 366 (defun mm-interactively-view-part (handle)
 367   "Display HANDLE using METHOD."
 368   (let* ((type (car (mm-handle-type handle)))
 369          (methods
 370           (mapcar (lambda (i) (list (cdr (assoc "viewer" i))))
 371                   (mailcap-mime-info type 'all)))
 372          (method (completing-read "Viewer: " methods)))
 373     (mm-display-external (copy-sequence handle) method)))
 374
 375 (defun mm-preferred-alternative (handles &optional preferred)
 376   "Say which of HANDLES are preferred."
 377   (let ((prec (if preferred (list preferred) mm-alternative-precedence))
 378         p h result type)
 379     (while (setq p (pop prec))
 380       (setq h handles)
 381       (while h
 382         (setq type (car (mm-handle-type (car h))))
 383         (when (and (equal p type)
 384                    (mm-automatic-display-p type)
 385                    (or (not (mm-handle-disposition (car h)))
 386                        (equal (car (mm-handle-disposition (car h)))
 387                               "inline")))
 388           (setq result (car h)
 389                 h nil
 390                 prec nil))
 391         (pop h)))
 392     result))
 393
 394 (defun mm-get-content-id (id)
 395   "Return the handle(s) referred to by ID."
 396   (cdr (assoc id mm-content-id-alist)))
 397
 398 (provide 'mm-decode)
 399
 400 ;; mm-decode.el ends here