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 ;;; Convenience macros.
  32
  33 (defmacro mm-handle-buffer (handle)
  34   `(nth 0 ,handle))
  35 (defmacro mm-handle-type (handle)
  36   `(nth 1 ,handle))
  37 (defmacro mm-handle-encoding (handle)
  38   `(nth 2 ,handle))
  39 (defmacro mm-handle-undisplayer (handle)
  40   `(nth 3 ,handle))
  41 (defmacro mm-handle-set-undisplayer (handle function)
  42   `(setcar (nthcdr 3 ,handle) ,function))
  43 (defmacro mm-handle-disposition (handle)
  44   `(nth 4 ,handle))
  45 (defmacro mm-handle-description (handle)
  46   `(nth 5 ,handle))
  47 (defmacro mm-handle-cache (handle)
  48   `(nth 6 ,handle))
  49 (defmacro mm-handle-set-cache (handle contents)
  50   `(setcar (nthcdr 6 ,handle) ,contents))
  51 (defmacro mm-make-handle (&optional buffer type encoding undisplayer
  52                                     disposition description cache)
  53   `(list ,buffer ,type ,encoding ,undisplayer
  54          ,disposition ,description ,cache))
  55
  56 (defvar mm-inline-media-tests
  57   '(("image/jpeg" mm-inline-image
  58      (and window-system (featurep 'jpeg) (mm-image-fit-p handle)))
  59     ("image/png" mm-inline-image
  60      (and window-system (featurep 'png) (mm-image-fit-p handle)))
  61     ("image/gif" mm-inline-image
  62      (and window-system (featurep 'gif) (mm-image-fit-p handle)))
  63     ("image/tiff" mm-inline-image
  64      (and window-system (featurep 'tiff) (mm-image-fit-p handle)))
  65     ("image/xbm" mm-inline-image
  66      (and window-system (fboundp 'device-type)
  67           (eq (device-type) 'x)))
  68     ("image/xpm" mm-inline-image
  69      (and window-system (featurep 'xpm)))
  70     ("image/bmp" mm-inline-image
  71      (and window-system (featurep 'bmp)))
  72     ("text/plain" mm-inline-text t)
  73     ("text/enriched" mm-inline-text t)
  74     ("text/richtext" mm-inline-text t)
  75     ("text/html" mm-inline-text (locate-library "w3"))
  76     ("message/delivery-status" mm-inline-text t)
  77     ("audio/wav" mm-inline-audio
  78      (and (or (featurep 'nas-sound) (featurep 'native-sound))
  79           (device-sound-enabled-p)))
  80     ("audio/au" mm-inline-audio
  81      (and (or (featurep 'nas-sound) (featurep 'native-sound))
  82           (device-sound-enabled-p))))
  83   "Alist of media types/test that say whether the media types can be displayed inline.")
  84
  85 (defvar mm-user-display-methods
  86   '(("image/.*" . inline)
  87     ("text/.*" . inline)
  88     ("message/delivery-status" . inline)))
  89
  90 (defvar mm-user-automatic-display
  91   '("text/plain" "text/enriched" "text/richtext" "text/html"
  92     "image/.*" "message/delivery-status" "multipart/.*"))
  93
  94 (defvar mm-alternative-precedence
  95   '("image/jpeg" "image/gif" "text/html" "text/enriched"
  96     "text/richtext" "text/plain")
  97   "List that describes the precedence of alternative parts.")
  98
  99 (defvar mm-tmp-directory "/tmp/"
 100   "Where mm will store its temporary files.")
 101
 102 ;;; Internal variables.
 103
 104 (defvar mm-dissection-list nil)
 105 (defvar mm-last-shell-command "")
 106 (defvar mm-content-id-alist nil)
 107
 108 ;;; The functions.
 109
 110 (defun mm-dissect-buffer (&optional no-strict-mime)
 111   "Dissect the current buffer and return a list of MIME handles."
 112   (save-excursion
 113     (let (ct ctl type subtype cte cd description id result)
 114       (save-restriction
 115         (mail-narrow-to-head)
 116         (when (or no-strict-mime
 117                   (mail-fetch-field "mime-version"))
 118           (setq ct (mail-fetch-field "content-type")
 119                 ctl (condition-case () (mail-header-parse-content-type ct)
 120                       (error nil))
 121                 cte (mail-fetch-field "content-transfer-encoding")
 122                 cd (mail-fetch-field "content-disposition")
 123                 description (mail-fetch-field "content-description")
 124                 id (mail-fetch-field "content-id"))))
 125       (if (not ctl)
 126           (mm-dissect-singlepart
 127            '("text/plain") nil no-strict-mime
 128            (and cd (condition-case ()
 129                        (mail-header-parse-content-disposition cd)
 130                      (error nil)))
 131            description)
 132         (setq type (split-string (car ctl) "/"))
 133         (setq subtype (cadr type)
 134               type (pop type))
 135         (setq
 136          result
 137          (cond
 138           ((equal type "multipart")
 139            (cons (car ctl) (mm-dissect-multipart ctl)))
 140           (t
 141            (mm-dissect-singlepart
 142             ctl
 143             (and cte (intern (downcase (mail-header-remove-whitespace
 144                                         (mail-header-remove-comments
 145                                          cte)))))
 146             no-strict-mime
 147             (and cd (condition-case ()
 148                         (mail-header-parse-content-disposition cd)
 149                       (error nil)))
 150             description))))
 151         (when id
 152           (when (string-match " *<\\(.*\\)> *" id)
 153             (setq id (match-string 1 id)))
 154           (push (cons id result) mm-content-id-alist))
 155         result))))
 156
 157 (defun mm-dissect-singlepart (ctl cte &optional force cdl description)
 158   (when (or force
 159             (not (equal "text/plain" (car ctl))))
 160     (let ((res (mm-make-handle
 161                 (mm-copy-to-buffer) ctl cte nil cdl description)))
 162       (push (car res) mm-dissection-list)
 163       res)))
 164
 165 (defun mm-remove-all-parts ()
 166   "Remove all MIME handles."
 167   (interactive)
 168   (mapcar 'mm-remove-part mm-dissection-list)
 169   (setq mm-dissection-list nil))
 170
 171 (defun mm-dissect-multipart (ctl)
 172   (goto-char (point-min))
 173   (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
 174         (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))
 175         start parts
 176         (end (save-excursion
 177                (goto-char (point-max))
 178                (if (re-search-backward close-delimiter nil t)
 179                    (match-beginning 0)
 180                  (point-max)))))
 181     (while (search-forward boundary end t)
 182       (goto-char (match-beginning 0))
 183       (when start
 184         (save-excursion
 185           (save-restriction
 186             (narrow-to-region start (point))
 187             (setq parts (nconc (list (mm-dissect-buffer t)) parts)))))
 188       (forward-line 2)
 189       (setq start (point)))
 190     (when start
 191       (save-excursion
 192         (save-restriction
 193           (narrow-to-region start end)
 194           (setq parts (nconc (list (mm-dissect-buffer t)) parts)))))
 195     (nreverse parts)))
 196
 197 (defun mm-copy-to-buffer ()
 198   "Copy the contents of the current buffer to a fresh buffer."
 199   (save-excursion
 200     (let ((obuf (current-buffer))
 201           beg)
 202       (goto-char (point-min))
 203       (search-forward-regexp "^\n" nil t)
 204       (setq beg (point))
 205       (set-buffer (generate-new-buffer " *mm*"))
 206       (insert-buffer-substring obuf beg)
 207       (current-buffer))))
 208
 209 (defun mm-inlinable-part-p (type)
 210   "Say whether TYPE can be displayed inline."
 211   (eq (mm-user-method type) 'inline))
 212
 213 (defun mm-display-part (handle &optional no-default)
 214   "Display the MIME part represented by HANDLE.
 215 Returns nil if the part is removed; inline if displayed inline;
 216 external if displayed external."
 217   (save-excursion
 218     (mailcap-parse-mailcaps)
 219     (if (mm-handle-displayed-p handle)
 220         (mm-remove-part handle)
 221       (let* ((type (car (mm-handle-type handle)))
 222              (method (mailcap-mime-info type))
 223              (user-method (mm-user-method type)))
 224         (if (eq user-method 'inline)
 225             (progn
 226               (forward-line 1)
 227               (mm-display-inline handle))
 228           (when (or user-method
 229                     method
 230                     (not no-default))
 231             (if (and (not user-method)
 232                      (not method)
 233                      (equal "text" (car (split-string type))))
 234                 (progn
 235                   (mm-insert-inline handle (mm-get-part handle))
 236                   'inline)
 237               (mm-display-external
 238                handle (or user-method method
 239                           'mailcap-save-binary-file))
 240               'external)))))))
 241
 242 (defun mm-display-external (handle method)
 243   "Display HANDLE using METHOD."
 244   (mm-with-unibyte-buffer
 245     (insert-buffer-substring (mm-handle-buffer handle))
 246     (mm-decode-content-transfer-encoding
 247      (mm-handle-encoding handle) (car (mm-handle-type handle)))
 248     (if (functionp method)
 249         (let ((cur (current-buffer)))
 250           (if (eq method 'mailcap-save-binary-file)
 251               (progn
 252                 (set-buffer (generate-new-buffer "*mm*"))
 253                 (setq method nil))
 254             (let ((win (get-buffer-window cur t)))
 255               (when win
 256                 (select-window win)))
 257             (switch-to-buffer (generate-new-buffer "*mm*")))
 258           (buffer-disable-undo)
 259           (mm-set-buffer-file-coding-system mm-binary-coding-system)
 260           (insert-buffer-substring cur)
 261           (message "Viewing with %s" method)
 262           (let ((mm (current-buffer)))
 263             (unwind-protect
 264                 (if method
 265                     (funcall method)
 266                   (mm-save-part handle))
 267               (mm-handle-set-undisplayer handle mm))))
 268       (let* ((dir (make-temp-name (expand-file-name "emm." mm-tmp-directory)))
 269              (filename (mail-content-type-get
 270                         (mm-handle-disposition handle) 'filename))
 271              (needsterm (assoc "needsterm"
 272                                (mailcap-mime-info
 273                                 (car (mm-handle-type handle)) t)))
 274              process file)
 275         ;; We create a private sub-directory where we store our files.
 276         (make-directory dir)
 277         (set-file-modes dir 448)
 278         (if filename
 279             (setq file (expand-file-name (file-name-nondirectory filename)
 280                                          dir))
 281           (setq file (make-temp-name (expand-file-name "mm." dir))))
 282         (write-region (point-min) (point-max) file nil 'nomesg)
 283         (message "Viewing with %s" method)
 284         (unwind-protect
 285             (setq process
 286                   (if needsterm
 287                       (start-process "*display*" nil
 288                                      "xterm"
 289                                      "-e" shell-file-name "-c"
 290                                      (format method
 291                                              (mm-quote-arg file)))
 292                     (start-process "*display*" (generate-new-buffer "*mm*")
 293                                    shell-file-name
 294                                    "-c" (format method
 295                                                 (mm-quote-arg file)))))
 296           (mm-handle-set-undisplayer handle (cons file process)))
 297         (message "Displaying %s..." (format method file))))))
 298
 299 (defun mm-remove-parts (handles)
 300   "Remove the displayed MIME parts represented by HANDLE."
 301   (if (and (listp handles)
 302            (bufferp (car handles)))
 303       (mm-remove-part handles)
 304     (let (handle)
 305       (while (setq handle (pop handles))
 306         (cond
 307          ((stringp handle)
 308           )
 309          ((and (listp handle)
 310                (stringp (car handle)))
 311           (mm-remove-parts (cdr handle)))
 312          (t
 313           (mm-remove-part handle)))))))
 314
 315 (defun mm-destroy-parts (handles)
 316   "Remove the displayed MIME parts represented by HANDLE."
 317   (if (and (listp handles)
 318            (bufferp (car handles)))
 319       (mm-destroy-part handles)
 320     (let (handle)
 321       (while (setq handle (pop handles))
 322         (cond
 323          ((stringp handle)
 324           )
 325          ((and (listp handle)
 326                (stringp (car handle)))
 327           (mm-destroy-parts (cdr handle)))
 328          (t
 329           (mm-destroy-part handle)))))))
 330
 331 (defun mm-remove-part (handle)
 332   "Remove the displayed MIME part represented by HANDLE."
 333   (when (listp handle)
 334     (let ((object (mm-handle-undisplayer handle)))
 335       (condition-case ()
 336           (cond
 337            ;; Internally displayed part.
 338            ((mm-annotationp object)
 339             (delete-annotation object))
 340            ((or (functionp object)
 341                 (and (listp object)
 342                      (eq (car object) 'lambda)))
 343             (funcall object))
 344            ;; Externally displayed part.
 345            ((consp object)
 346             (condition-case ()
 347                 (delete-file (car object))
 348               (error nil))
 349             (condition-case ()
 350                 (delete-directory (file-name-directory (car object)))
 351               (error nil))
 352             (condition-case ()
 353                 (kill-process (cdr object))
 354               (error nil)))
 355            ((bufferp object)
 356             (when (buffer-live-p object)
 357               (kill-buffer object))))
 358         (error nil))
 359       (mm-handle-set-undisplayer handle nil))))
 360
 361 (defun mm-display-inline (handle)
 362   (let* ((type (car (mm-handle-type handle)))
 363          (function (cadr (assoc type mm-inline-media-tests))))
 364     (funcall function handle)
 365     (goto-char (point-min))))
 366
 367 (defun mm-inlinable-p (type)
 368   "Say whether TYPE can be displayed inline."
 369   (let ((alist mm-inline-media-tests)
 370         test)
 371     (while alist
 372       (when (equal type (caar alist))
 373         (setq test (caddar alist)
 374               alist nil)
 375         (setq test (eval test)))
 376       (pop alist))
 377     test))
 378
 379 (defun mm-user-method (type)
 380   "Return the user-defined method for TYPE."
 381   (let ((methods mm-user-display-methods)
 382         method result)
 383     (while (setq method (pop methods))
 384       (when (string-match (car method) type)
 385         (when (or (not (eq (cdr method) 'inline))
 386                   (mm-inlinable-p type))
 387           (setq result (cdr method)
 388                 methods nil))))
 389     result))
 390
 391 (defun mm-automatic-display-p (type)
 392   "Return the user-defined method for TYPE."
 393   (let ((methods mm-user-automatic-display)
 394         method result)
 395     (while (setq method (pop methods))
 396       (when (and (string-match method type)
 397                  (mm-inlinable-p type))
 398         (setq result t
 399               methods nil)))
 400     result))
 401
 402 (defun add-mime-display-method (type method)
 403   "Make parts of TYPE be displayed with METHOD.
 404 This overrides entries in the mailcap file."
 405   (push (cons type method) mm-user-display-methods))
 406
 407 (defun mm-destroy-part (handle)
 408   "Destroy the data structures connected to HANDLE."
 409   (when (listp handle)
 410     (mm-remove-part handle)
 411     (when (buffer-live-p (mm-handle-buffer handle))
 412       (kill-buffer (mm-handle-buffer handle)))))
 413
 414 (defun mm-handle-displayed-p (handle)
 415   "Say whether HANDLE is displayed or not."
 416   (mm-handle-undisplayer handle))
 417
 418 (defun mm-quote-arg (arg)
 419   "Return a version of ARG that is safe to evaluate in a shell."
 420   (let ((pos 0) new-pos accum)
 421     ;; *** bug: we don't handle newline characters properly
 422     (while (setq new-pos (string-match "[;!`\"$\\& \t{} ]" arg pos))
 423       (push (substring arg pos new-pos) accum)
 424       (push "\\" accum)
 425       (push (list (aref arg new-pos)) accum)
 426       (setq pos (1+ new-pos)))
 427     (if (= pos 0)
 428         arg
 429       (apply 'concat (nconc (nreverse accum) (list (substring arg pos)))))))
 430
 431 ;;;
 432 ;;; Functions for outputting parts
 433 ;;;
 434
 435 (defun mm-get-part (handle)
 436   "Return the contents of HANDLE as a string."
 437   (mm-with-unibyte-buffer
 438     (insert-buffer-substring (mm-handle-buffer handle))
 439     (mm-decode-content-transfer-encoding
 440      (mm-handle-encoding handle)
 441      (car (mm-handle-type handle)))
 442     (buffer-string)))
 443
 444 (defvar mm-default-directory nil)
 445
 446 (defun mm-save-part (handle)
 447   "Write HANDLE to a file."
 448   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 449          (filename (mail-content-type-get
 450                     (mm-handle-disposition handle) 'filename))
 451          file)
 452     (when filename
 453       (setq filename (file-name-nondirectory filename)))
 454     (setq file
 455           (read-file-name "Save MIME part to: "
 456                           (expand-file-name
 457                            (or filename name "")
 458                            (or mm-default-directory default-directory))))
 459     (setq mm-default-directory (file-name-directory file))
 460     (mm-with-unibyte-buffer
 461       (insert-buffer-substring (mm-handle-buffer handle))
 462       (mm-decode-content-transfer-encoding
 463        (mm-handle-encoding handle)
 464        (car (mm-handle-type handle)))
 465       (when (or (not (file-exists-p file))
 466                 (yes-or-no-p (format "File %s already exists; overwrite? "
 467                                      file)))
 468         ;; Now every coding system is 100% binary within mm-with-unibyte-buffer
 469         ;; Is text still special?
 470       (let ((coding-system-for-write
 471              (if (equal "text" (car (split-string
 472                                      (car (mm-handle-type handle)) "/")))
 473                  buffer-file-coding-system
 474                'binary)))
 475         (write-region (point-min) (point-max) file))))))
 476
 477 (defun mm-pipe-part (handle)
 478   "Pipe HANDLE to a process."
 479   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 480          (command
 481           (read-string "Shell command on MIME part: " mm-last-shell-command)))
 482     (mm-with-unibyte-buffer
 483       (insert-buffer-substring (mm-handle-buffer handle))
 484       (mm-decode-content-transfer-encoding
 485        (mm-handle-encoding handle)
 486        (car (mm-handle-type handle)))
 487       (shell-command-on-region (point-min) (point-max) command nil))))
 488
 489 (defun mm-interactively-view-part (handle)
 490   "Display HANDLE using METHOD."
 491   (let* ((type (car (mm-handle-type handle)))
 492          (methods
 493           (mapcar (lambda (i) (list (cdr (assoc 'viewer i))))
 494                   (mailcap-mime-info type 'all)))
 495          (method (completing-read "Viewer: " methods)))
 496     (mm-display-external (copy-sequence handle) method)))
 497
 498 (defun mm-preferred-alternative (handles &optional preferred)
 499   "Say which of HANDLES are preferred."
 500   (let ((prec (if preferred (list preferred) mm-alternative-precedence))
 501         p h result type handle)
 502     (while (setq p (pop prec))
 503       (setq h handles)
 504       (while h
 505         (setq type
 506               (if (stringp (caar h))
 507                   (caar h)
 508                 (car (mm-handle-type (car h)))))
 509         (setq handle (car h))
 510         (when (and (equal p type)
 511                    (mm-automatic-display-p type)
 512                    (or (stringp (caar h))
 513                        (not (mm-handle-disposition (car h)))
 514                        (equal (car (mm-handle-disposition (car h)))
 515                               "inline")))
 516           (setq result (car h)
 517                 h nil
 518                 prec nil))
 519         (pop h)))
 520     result))
 521
 522 (defun mm-get-content-id (id)
 523   "Return the handle(s) referred to by ID."
 524   (cdr (assoc id mm-content-id-alist)))
 525
 526 (defun mm-get-image (handle)
 527   "Return an image instance based on HANDLE."
 528   (let ((type (cadr (split-string (car (mm-handle-type handle)) "/")))
 529         spec)
 530     (or (mm-handle-cache handle)
 531         (mm-with-unibyte-buffer
 532           (insert-buffer-substring (mm-handle-buffer handle))
 533           (mm-decode-content-transfer-encoding
 534            (mm-handle-encoding handle)
 535            (car (mm-handle-type handle)))
 536           (prog1
 537               (setq spec
 538                     (make-image-specifier
 539                      (vector (intern type) :data (buffer-string))))
 540             (mm-handle-set-cache handle spec))))))
 541
 542 (defun mm-image-fit-p (handle)
 543   "Say whether the image in HANDLE will fit the current window."
 544   (let ((image (make-annotation (mm-get-image handle))))
 545     (and (< (glyph-width (annotation-glyph image))
 546             (window-pixel-width))
 547          (< (glyph-height (annotation-glyph image))
 548             (window-pixel-height)))))
 549
 550 (provide 'mm-decode)
 551
 552 ;; mm-decode.el ends here