cgit.sxemacs.org Git - gnus/blob - lisp/mm-decode.el

   1 ;;; mm-decode.el --- Functions for decoding MIME things
   2 ;; Copyright (C) 1998, 1999, 2000 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 (eval-and-compile
  32   (autoload 'mm-inline-partial "mm-partial"))
  33
  34 (defvar mm-xemacs-p (string-match "XEmacs" (emacs-version)))
  35
  36 (defgroup mime-display ()
  37   "Display of MIME in mail and news articles."
  38   :link '(custom-manual "(emacs-mime)Customization")
  39   :group 'mail
  40   :group 'news)
  41
  42 ;;; Convenience macros.
  43
  44 (defmacro mm-handle-buffer (handle)
  45   `(nth 0 ,handle))
  46 (defmacro mm-handle-type (handle)
  47   `(nth 1 ,handle))
  48 (defsubst mm-handle-media-type (handle)
  49   (if (stringp (car handle))
  50       (car handle)
  51     (car (mm-handle-type handle))))
  52 (defsubst mm-handle-media-supertype (handle)
  53   (car (split-string (mm-handle-media-type handle) "/")))
  54 (defsubst mm-handle-media-subtype (handle)
  55   (cadr (split-string (mm-handle-media-type handle) "/")))
  56 (defmacro mm-handle-encoding (handle)
  57   `(nth 2 ,handle))
  58 (defmacro mm-handle-undisplayer (handle)
  59   `(nth 3 ,handle))
  60 (defmacro mm-handle-set-undisplayer (handle function)
  61   `(setcar (nthcdr 3 ,handle) ,function))
  62 (defmacro mm-handle-disposition (handle)
  63   `(nth 4 ,handle))
  64 (defmacro mm-handle-description (handle)
  65   `(nth 5 ,handle))
  66 (defmacro mm-handle-cache (handle)
  67   `(nth 6 ,handle))
  68 (defmacro mm-handle-set-cache (handle contents)
  69   `(setcar (nthcdr 6 ,handle) ,contents))
  70 (defmacro mm-handle-id (handle)
  71   `(nth 7 ,handle))
  72 (defmacro mm-make-handle (&optional buffer type encoding undisplayer
  73                                     disposition description cache
  74                                     id)
  75   `(list ,buffer ,type ,encoding ,undisplayer
  76          ,disposition ,description ,cache ,id))
  77
  78 (defcustom mm-inline-media-tests
  79   '(("image/jpeg"
  80      mm-inline-image
  81      (lambda (handle)
  82        (mm-valid-and-fit-image-p 'jpeg handle)))
  83     ("image/png"
  84      mm-inline-image
  85      (lambda (handle)
  86        (mm-valid-and-fit-image-p 'png handle)))
  87     ("image/gif"
  88      mm-inline-image
  89      (lambda (handle)
  90        (mm-valid-and-fit-image-p 'gif handle)))
  91     ("image/tiff"
  92      mm-inline-image
  93      (lambda (handle)
  94        (mm-valid-and-fit-image-p 'tiff handle)) )
  95     ("image/xbm"
  96      mm-inline-image
  97      (lambda (handle)
  98        (mm-valid-and-fit-image-p 'xbm handle)))
  99     ("image/x-xbitmap"
 100      mm-inline-image
 101      (lambda (handle)
 102        (mm-valid-and-fit-image-p 'xbm handle)))
 103     ("image/xpm"
 104      mm-inline-image
 105      (lambda (handle)
 106        (mm-valid-and-fit-image-p 'xpm handle)))
 107     ("image/x-pixmap"
 108      mm-inline-image
 109      (lambda (handle)
 110        (mm-valid-and-fit-image-p 'xpm handle)))
 111     ("image/bmp"
 112      mm-inline-image
 113      (lambda (handle)
 114        (mm-valid-and-fit-image-p 'bmp handle)))
 115     ("text/plain" mm-inline-text identity)
 116     ("text/enriched" mm-inline-text identity)
 117     ("text/richtext" mm-inline-text identity)
 118     ("text/x-patch" mm-display-patch-inline
 119      (lambda (handle)
 120        (locate-library "diff-mode")))
 121     ("text/html"
 122      mm-inline-text
 123      (lambda (handle)
 124        (locate-library "w3")))
 125     ("text/x-vcard"
 126      mm-inline-text
 127      (lambda (handle)
 128        (or (featurep 'vcard)
 129            (locate-library "vcard"))))
 130     ("message/delivery-status" mm-inline-text identity)
 131     ("message/rfc822" mm-inline-message identity)
 132     ("message/partial" mm-inline-partial identity)
 133     ("text/.*" mm-inline-text identity)
 134     ("audio/wav" mm-inline-audio
 135      (lambda (handle)
 136        (and (or (featurep 'nas-sound) (featurep 'native-sound))
 137             (device-sound-enabled-p))))
 138     ("audio/au"
 139      mm-inline-audio
 140      (lambda (handle)
 141        (and (or (featurep 'nas-sound) (featurep 'native-sound))
 142             (device-sound-enabled-p))))
 143     ("application/pgp-signature" ignore identity)
 144     ("multipart/alternative" ignore identity)
 145     ("multipart/mixed" ignore identity)
 146     ("multipart/related" ignore identity))
 147   "Alist of media types/tests saying whether types can be displayed inline."
 148   :type '(repeat (list (string :tag "MIME type")
 149                        (function :tag "Display function")
 150                        (function :tag "Display test")))
 151   :group 'mime-display)
 152
 153 (defcustom mm-inlined-types
 154   '("image/.*" "text/.*" "message/delivery-status" "message/rfc822"
 155     "message/partial"
 156     "application/pgp-signature")
 157   "List of media types that are to be displayed inline."
 158   :type '(repeat string)
 159   :group 'mime-display)
 160
 161 (defcustom mm-automatic-display
 162   '("text/plain" "text/enriched" "text/richtext" "text/html"
 163     "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*"
 164     "message/rfc822" "text/x-patch" "application/pgp-signature")
 165   "A list of MIME types to be displayed automatically."
 166   :type '(repeat string)
 167   :group 'mime-display)
 168
 169 (defcustom mm-attachment-override-types '("text/x-vcard")
 170   "Types to have \"attachment\" ignored if they can be displayed inline."
 171   :type '(repeat string)
 172   :group 'mime-display)
 173
 174 (defcustom mm-inline-override-types nil
 175   "Types to be treated as attachments even if they can be displayed inline."
 176   :type '(repeat string)
 177   :group 'mime-display)
 178
 179 (defcustom mm-automatic-external-display nil
 180   "List of MIME type regexps that will be displayed externally automatically."
 181   :type '(repeat string)
 182   :group 'mime-display)
 183
 184 (defcustom mm-discouraged-alternatives nil
 185   "List of MIME types that are discouraged when viewing multipart/alternative.
 186 Viewing agents are supposed to view the last possible part of a message,
 187 as that is supposed to be the richest.  However, users may prefer other
 188 types instead, and this list says what types are most unwanted.  If,
 189 for instance, text/html parts are very unwanted, and text/richtech are
 190 somewhat unwanted, then the value of this variable should be set
 191 to:
 192
 193  (\"text/html\" \"text/richtext\")"
 194   :type '(repeat string)
 195   :group 'mime-display)
 196
 197 (defvar mm-tmp-directory
 198   (cond ((fboundp 'temp-directory) (temp-directory))
 199         ((boundp 'temporary-file-directory) temporary-file-directory)
 200         ("/tmp/"))
 201   "Where mm will store its temporary files.")
 202
 203 (defcustom mm-inline-large-images nil
 204   "If non-nil, then all images fit in the buffer."
 205   :type 'boolean
 206   :group 'mime-display)
 207
 208 ;;; Internal variables.
 209
 210 (defvar mm-dissection-list nil)
 211 (defvar mm-last-shell-command "")
 212 (defvar mm-content-id-alist nil)
 213
 214 ;;; The functions.
 215
 216 (defun mm-dissect-buffer (&optional no-strict-mime)
 217   "Dissect the current buffer and return a list of MIME handles."
 218   (save-excursion
 219     (let (ct ctl type subtype cte cd description id result)
 220       (save-restriction
 221         (mail-narrow-to-head)
 222         (when (or no-strict-mime
 223                   (mail-fetch-field "mime-version"))
 224           (setq ct (mail-fetch-field "content-type")
 225                 ctl (ignore-errors (mail-header-parse-content-type ct))
 226                 cte (mail-fetch-field "content-transfer-encoding")
 227                 cd (mail-fetch-field "content-disposition")
 228                 description (mail-fetch-field "content-description")
 229                 id (mail-fetch-field "content-id"))))
 230       (when cte
 231         (setq cte (mail-header-strip cte)))
 232       (if (or (not ctl)
 233               (not (string-match "/" (car ctl))))
 234           (mm-dissect-singlepart
 235            '("text/plain")
 236            (and cte (intern (downcase (mail-header-remove-whitespace
 237                                        (mail-header-remove-comments
 238                                         cte)))))
 239            no-strict-mime
 240            (and cd (ignore-errors (mail-header-parse-content-disposition cd)))
 241            description)
 242         (setq type (split-string (car ctl) "/"))
 243         (setq subtype (cadr type)
 244               type (pop type))
 245         (setq
 246          result
 247          (cond
 248           ((equal type "multipart")
 249            (cons (car ctl) (mm-dissect-multipart ctl)))
 250           (t
 251            (mm-dissect-singlepart
 252             ctl
 253             (and cte (intern (downcase (mail-header-remove-whitespace
 254                                         (mail-header-remove-comments
 255                                          cte)))))
 256             no-strict-mime
 257             (and cd (ignore-errors (mail-header-parse-content-disposition cd)))
 258             description id))))
 259         (when id
 260           (when (string-match " *<\\(.*\\)> *" id)
 261             (setq id (match-string 1 id)))
 262           (push (cons id result) mm-content-id-alist))
 263         result))))
 264
 265 (defun mm-dissect-singlepart (ctl cte &optional force cdl description id)
 266   (when (or force
 267             (if (equal "text/plain" (car ctl))
 268                 (assoc 'format ctl)
 269               t))
 270     (let ((res (mm-make-handle
 271                 (mm-copy-to-buffer) ctl cte nil cdl description nil id)))
 272       (push (car res) mm-dissection-list)
 273       res)))
 274
 275 (defun mm-remove-all-parts ()
 276   "Remove all MIME handles."
 277   (interactive)
 278   (mapcar 'mm-remove-part mm-dissection-list)
 279   (setq mm-dissection-list nil))
 280
 281 (defun mm-dissect-multipart (ctl)
 282   (goto-char (point-min))
 283   (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
 284          (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))
 285          start parts
 286          (end (save-excursion
 287                 (goto-char (point-max))
 288                 (if (re-search-backward close-delimiter nil t)
 289                     (match-beginning 0)
 290                   (point-max)))))
 291     (while (search-forward boundary end t)
 292       (goto-char (match-beginning 0))
 293       (when start
 294         (save-excursion
 295           (save-restriction
 296             (narrow-to-region start (point))
 297             (setq parts (nconc (list (mm-dissect-buffer t)) parts)))))
 298       (forward-line 2)
 299       (setq start (point)))
 300     (when start
 301       (save-excursion
 302         (save-restriction
 303           (narrow-to-region start end)
 304           (setq parts (nconc (list (mm-dissect-buffer t)) parts)))))
 305     (nreverse parts)))
 306
 307 (defun mm-copy-to-buffer ()
 308   "Copy the contents of the current buffer to a fresh buffer."
 309   (save-excursion
 310     (let ((obuf (current-buffer))
 311           beg)
 312       (goto-char (point-min))
 313       (search-forward-regexp "^\n" nil t)
 314       (setq beg (point))
 315       (set-buffer (generate-new-buffer " *mm*"))
 316       (insert-buffer-substring obuf beg)
 317       (current-buffer))))
 318
 319 (defun mm-display-part (handle &optional no-default)
 320   "Display the MIME part represented by HANDLE.
 321 Returns nil if the part is removed; inline if displayed inline;
 322 external if displayed external."
 323   (save-excursion
 324     (mailcap-parse-mailcaps)
 325     (if (mm-handle-displayed-p handle)
 326         (mm-remove-part handle)
 327       (let* ((type (mm-handle-media-type handle))
 328              (method (mailcap-mime-info type)))
 329         (if (mm-inlined-p handle)
 330             (progn
 331               (forward-line 1)
 332               (mm-display-inline handle)
 333               'inline)
 334           (when (or method
 335                     (not no-default))
 336             (if (and (not method)
 337                      (equal "text" (car (split-string type))))
 338                 (progn
 339                   (forward-line 1)
 340                   (mm-insert-inline handle (mm-get-part handle))
 341                   'inline)
 342               (mm-display-external
 343                handle (or method 'mailcap-save-binary-file)))))))))
 344
 345 (defun mm-display-external (handle method)
 346   "Display HANDLE using METHOD."
 347   (let ((outbuf (current-buffer)))
 348     (mm-with-unibyte-buffer
 349       (if (functionp method)
 350           (let ((cur (current-buffer)))
 351             (if (eq method 'mailcap-save-binary-file)
 352                 (progn
 353                   (set-buffer (generate-new-buffer "*mm*"))
 354                   (setq method nil))
 355               (mm-insert-part handle)
 356               (let ((win (get-buffer-window cur t)))
 357                 (when win
 358                   (select-window win)))
 359               (switch-to-buffer (generate-new-buffer "*mm*")))
 360             (buffer-disable-undo)
 361             (mm-set-buffer-file-coding-system mm-binary-coding-system)
 362             (insert-buffer-substring cur)
 363             (message "Viewing with %s" method)
 364             (let ((mm (current-buffer))
 365                   (non-viewer (assq 'non-viewer
 366                                     (mailcap-mime-info
 367                                      (mm-handle-media-type handle) t))))
 368               (unwind-protect
 369                   (if method
 370                       (funcall method)
 371                     (mm-save-part handle))
 372                 (when (and (not non-viewer)
 373                            method)
 374                   (mm-handle-set-undisplayer handle mm)))))
 375         ;; The function is a string to be executed.
 376         (mm-insert-part handle)
 377         (let* ((dir (make-temp-name (expand-file-name "emm." mm-tmp-directory)))
 378                (filename (mail-content-type-get
 379                           (mm-handle-disposition handle) 'filename))
 380                (mime-info (mailcap-mime-info
 381                            (mm-handle-media-type handle) t))
 382                (needsterm (or (assoc "needsterm" mime-info)
 383                               (assoc "needsterminal" mime-info)))
 384                (copiousoutput (assoc "copiousoutput" mime-info))
 385                file buffer)
 386           ;; We create a private sub-directory where we store our files.
 387           (make-directory dir)
 388           (set-file-modes dir 448)
 389           (if filename
 390               (setq file (expand-file-name (file-name-nondirectory filename)
 391                                            dir))
 392             (setq file (make-temp-name (expand-file-name "mm." dir))))
 393           (let ((coding-system-for-write mm-binary-coding-system))
 394             (write-region (point-min) (point-max) file nil 'nomesg))
 395           (message "Viewing with %s" method)
 396           (cond (needsterm
 397                  (unwind-protect
 398                      (start-process "*display*" nil
 399                                     "xterm"
 400                                     "-e" shell-file-name
 401                                     shell-command-switch
 402                                     (mm-mailcap-command
 403                                      method file (mm-handle-type handle)))
 404                    (mm-handle-set-undisplayer handle (cons file buffer)))
 405                  (message "Displaying %s..." (format method file))
 406                  'external)
 407                 (copiousoutput
 408                  (with-current-buffer outbuf
 409                    (forward-line 1)
 410                    (mm-insert-inline
 411                     handle
 412                     (unwind-protect
 413                         (progn
 414                           (call-process shell-file-name nil
 415                                         (setq buffer
 416                                               (generate-new-buffer "*mm*"))
 417                                         nil
 418                                         shell-command-switch
 419                                         (mm-mailcap-command
 420                                          method file (mm-handle-type handle)))
 421                           (if (buffer-live-p buffer)
 422                               (save-excursion
 423                                 (set-buffer buffer)
 424                                 (buffer-string))))
 425                       (progn
 426                         (ignore-errors (delete-file file))
 427                         (ignore-errors (delete-directory
 428                                         (file-name-directory file)))
 429                         (ignore-errors (kill-buffer buffer))))))
 430                  'inline)
 431                 (t
 432                  (unwind-protect
 433                      (start-process "*display*"
 434                                     (setq buffer
 435                                           (generate-new-buffer "*mm*"))
 436                                     shell-file-name
 437                                     shell-command-switch
 438                                     (mm-mailcap-command
 439                                      method file (mm-handle-type handle)))
 440                    (mm-handle-set-undisplayer handle (cons file buffer)))
 441                  (message "Displaying %s..." (format method file))
 442                  'external)))))))
 443
 444 (defun mm-mailcap-command (method file type-list)
 445   (let ((ctl (cdr type-list))
 446         (beg 0)
 447         (uses-stdin t)
 448         out sub total)
 449     (while (string-match "%{\\([^}]+\\)}\\|%s\\|%t\\|%%" method beg)
 450       (push (substring method beg (match-beginning 0)) out)
 451       (setq beg (match-end 0)
 452             total (match-string 0 method)
 453             sub (match-string 1 method))
 454       (cond
 455        ((string= total "%%")
 456         (push "%" out))
 457        ((string= total "%s")
 458         (setq uses-stdin nil)
 459         (push (mm-quote-arg file) out))
 460        ((string= total "%t")
 461         (push (mm-quote-arg (car type-list)) out))
 462        (t
 463         (push (mm-quote-arg (or (cdr (assq (intern sub) ctl)) "")) out))))
 464     (push (substring method beg (length method)) out)
 465     (if uses-stdin
 466         (progn
 467           (push "<" out)
 468           (push (mm-quote-arg file) out)))
 469     (mapconcat 'identity (nreverse out) "")))
 470
 471 (defun mm-remove-parts (handles)
 472   "Remove the displayed MIME parts represented by HANDLE."
 473   (if (and (listp handles)
 474            (bufferp (car handles)))
 475       (mm-remove-part handles)
 476     (let (handle)
 477       (while (setq handle (pop handles))
 478         (cond
 479          ((stringp handle)
 480           ;; Do nothing.
 481           )
 482          ((and (listp handle)
 483                (stringp (car handle)))
 484           (mm-remove-parts (cdr handle)))
 485          (t
 486           (mm-remove-part handle)))))))
 487
 488 (defun mm-destroy-parts (handles)
 489   "Remove the displayed MIME parts represented by HANDLE."
 490   (if (and (listp handles)
 491            (bufferp (car handles)))
 492       (mm-destroy-part handles)
 493     (let (handle)
 494       (while (setq handle (pop handles))
 495         (cond
 496          ((stringp handle)
 497           ;; Do nothing.
 498           )
 499          ((and (listp handle)
 500                (stringp (car handle)))
 501           (mm-destroy-parts (cdr handle)))
 502          (t
 503           (mm-destroy-part handle)))))))
 504
 505 (defun mm-remove-part (handle)
 506   "Remove the displayed MIME part represented by HANDLE."
 507   (when (listp handle)
 508     (let ((object (mm-handle-undisplayer handle)))
 509       (ignore-errors
 510         (cond
 511          ;; Internally displayed part.
 512          ((mm-annotationp object)
 513           (delete-annotation object))
 514          ((or (functionp object)
 515               (and (listp object)
 516                    (eq (car object) 'lambda)))
 517           (funcall object))
 518          ;; Externally displayed part.
 519          ((consp object)
 520           (ignore-errors (delete-file (car object)))
 521           (ignore-errors (delete-directory (file-name-directory (car object))))
 522           (ignore-errors (kill-buffer (cdr object))))
 523          ((bufferp object)
 524           (when (buffer-live-p object)
 525             (kill-buffer object)))))
 526       (mm-handle-set-undisplayer handle nil))))
 527
 528 (defun mm-display-inline (handle)
 529   (let* ((type (mm-handle-media-type handle))
 530          (function (cadr (mm-assoc-string-match mm-inline-media-tests type))))
 531     (funcall function handle)
 532     (goto-char (point-min))))
 533
 534 (defun mm-assoc-string-match (alist type)
 535   (dolist (elem alist)
 536     (when (string-match (car elem) type)
 537       (return elem))))
 538
 539 (defun mm-inlinable-p (handle)
 540   "Say whether HANDLE can be displayed inline."
 541   (let ((alist mm-inline-media-tests)
 542         (type (mm-handle-media-type handle))
 543         test)
 544     (while alist
 545       (when (string-match (caar alist) type)
 546         (setq test (caddar alist)
 547               alist nil)
 548         (setq test (funcall test handle)))
 549       (pop alist))
 550     test))
 551
 552 (defun mm-automatic-display-p (handle)
 553   "Say whether the user wants HANDLE to be displayed automatically."
 554   (let ((methods mm-automatic-display)
 555         (type (mm-handle-media-type handle))
 556         method result)
 557     (while (setq method (pop methods))
 558       (when (and (not (mm-inline-override-p handle))
 559                  (string-match method type)
 560                  (mm-inlinable-p handle))
 561         (setq result t
 562               methods nil)))
 563     result))
 564
 565 (defun mm-inlined-p (handle)
 566   "Say whether the user wants HANDLE to be displayed automatically."
 567   (let ((methods mm-inlined-types)
 568         (type (mm-handle-media-type handle))
 569         method result)
 570     (while (setq method (pop methods))
 571       (when (and (not (mm-inline-override-p handle))
 572                  (string-match method type)
 573                  (mm-inlinable-p handle))
 574         (setq result t
 575               methods nil)))
 576     result))
 577
 578 (defun mm-attachment-override-p (handle)
 579   "Say whether HANDLE should have attachment behavior overridden."
 580   (let ((types mm-attachment-override-types)
 581         (type (mm-handle-media-type handle))
 582         ty)
 583     (catch 'found
 584       (while (setq ty (pop types))
 585         (when (and (string-match ty type)
 586                    (mm-inlinable-p handle))
 587           (throw 'found t))))))
 588
 589 (defun mm-inline-override-p (handle)
 590   "Say whether HANDLE should have inline behavior overridden."
 591   (let ((types mm-inline-override-types)
 592         (type (mm-handle-media-type handle))
 593         ty)
 594     (catch 'found
 595       (while (setq ty (pop types))
 596         (when (string-match ty type)
 597           (throw 'found t))))))
 598
 599 (defun mm-automatic-external-display-p (type)
 600   "Return the user-defined method for TYPE."
 601   (let ((methods mm-automatic-external-display)
 602         method result)
 603     (while (setq method (pop methods))
 604       (when (string-match method type)
 605         (setq result t
 606               methods nil)))
 607     result))
 608
 609 (defun mm-destroy-part (handle)
 610   "Destroy the data structures connected to HANDLE."
 611   (when (listp handle)
 612     (mm-remove-part handle)
 613     (when (buffer-live-p (mm-handle-buffer handle))
 614       (kill-buffer (mm-handle-buffer handle)))))
 615
 616 (defun mm-handle-displayed-p (handle)
 617   "Say whether HANDLE is displayed or not."
 618   (mm-handle-undisplayer handle))
 619
 620 ;;;
 621 ;;; Functions for outputting parts
 622 ;;;
 623
 624 (defun mm-get-part (handle)
 625   "Return the contents of HANDLE as a string."
 626   (mm-with-unibyte-buffer
 627     (mm-insert-part handle)
 628     (buffer-string)))
 629
 630 (defun mm-insert-part (handle)
 631   "Insert the contents of HANDLE in the current buffer."
 632   (let ((cur (current-buffer)))
 633     (save-excursion
 634       (if (member (mm-handle-media-supertype handle) '("text" "message"))
 635           (with-temp-buffer
 636             (insert-buffer-substring (mm-handle-buffer handle))
 637             (mm-decode-content-transfer-encoding
 638              (mm-handle-encoding handle)
 639              (mm-handle-media-type handle))
 640             (let ((temp (current-buffer)))
 641               (set-buffer cur)
 642               (insert-buffer-substring temp)))
 643         (mm-with-unibyte-buffer
 644           (insert-buffer-substring (mm-handle-buffer handle))
 645           (mm-decode-content-transfer-encoding
 646            (mm-handle-encoding handle)
 647            (mm-handle-media-type handle))
 648           (let ((temp (current-buffer)))
 649             (set-buffer cur)
 650             (insert-buffer-substring temp)))))))
 651
 652 (defvar mm-default-directory nil)
 653
 654 (defun mm-save-part (handle)
 655   "Write HANDLE to a file."
 656   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 657          (filename (mail-content-type-get
 658                     (mm-handle-disposition handle) 'filename))
 659          file)
 660     (when filename
 661       (setq filename (file-name-nondirectory filename)))
 662     (setq file
 663           (read-file-name "Save MIME part to: "
 664                           (expand-file-name
 665                            (or filename name "")
 666                            (or mm-default-directory default-directory))))
 667     (setq mm-default-directory (file-name-directory file))
 668     (when (or (not (file-exists-p file))
 669               (yes-or-no-p (format "File %s already exists; overwrite? "
 670                                    file)))
 671       (mm-save-part-to-file handle file))))
 672
 673 (defun mm-save-part-to-file (handle file)
 674   (mm-with-unibyte-buffer
 675     (mm-insert-part handle)
 676     (let ((coding-system-for-write 'binary)
 677           ;; Don't re-compress .gz & al.  Arguably we should make
 678           ;; `file-name-handler-alist' nil, but that would chop
 679           ;; ange-ftp, which is reasonable to use here.
 680           (inhibit-file-name-operation 'write-region)
 681           (inhibit-file-name-handlers
 682            (cons 'jka-compr-handler inhibit-file-name-handlers)))
 683       (write-region (point-min) (point-max) file))))
 684
 685 (defun mm-pipe-part (handle)
 686   "Pipe HANDLE to a process."
 687   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 688          (command
 689           (read-string "Shell command on MIME part: " mm-last-shell-command)))
 690     (mm-with-unibyte-buffer
 691       (mm-insert-part handle)
 692       (shell-command-on-region (point-min) (point-max) command nil))))
 693
 694 (defun mm-interactively-view-part (handle)
 695   "Display HANDLE using METHOD."
 696   (let* ((type (mm-handle-media-type handle))
 697          (methods
 698           (mapcar (lambda (i) (list (cdr (assoc 'viewer i))))
 699                   (mailcap-mime-info type 'all)))
 700          (method (completing-read "Viewer: " methods)))
 701     (when (string= method "")
 702       (error "No method given"))
 703     (mm-display-external (copy-sequence handle) method)))
 704
 705 (defun mm-preferred-alternative (handles &optional preferred)
 706   "Say which of HANDLES are preferred."
 707   (let ((prec (if preferred (list preferred)
 708                 (mm-preferred-alternative-precedence handles)))
 709         p h result type handle)
 710     (while (setq p (pop prec))
 711       (setq h handles)
 712       (while h
 713         (setq handle (car h))
 714         (setq type (mm-handle-media-type handle))
 715         (when (and (equal p type)
 716                    (mm-automatic-display-p handle)
 717                    (or (stringp (car handle))
 718                        (not (mm-handle-disposition handle))
 719                        (equal (car (mm-handle-disposition handle))
 720                               "inline")))
 721           (setq result handle
 722                 h nil
 723                 prec nil))
 724         (pop h)))
 725     result))
 726
 727 (defun mm-preferred-alternative-precedence (handles)
 728   "Return the precedence based on HANDLES and mm-discouraged-alternatives."
 729   (let ((seq (nreverse (mapcar (lambda (h)
 730                                  (mm-handle-media-type h))
 731                                handles))))
 732     (dolist (disc (reverse mm-discouraged-alternatives))
 733       (dolist (elem (copy-sequence seq))
 734         (when (string-match disc elem)
 735           (setq seq (nconc (delete elem seq) (list elem))))))
 736     seq))
 737
 738 (defun mm-get-content-id (id)
 739   "Return the handle(s) referred to by ID."
 740   (cdr (assoc id mm-content-id-alist)))
 741
 742 (defun mm-get-image-emacs (handle)
 743   "Return an image instance based on HANDLE."
 744   (let ((type (mm-handle-media-subtype handle))
 745         spec)
 746     ;; Allow some common translations.
 747     (setq type
 748           (cond
 749            ((equal type "x-pixmap")
 750             "xpm")
 751            ((equal type "x-xbitmap")
 752             "xbm")
 753            (t type)))
 754     (or (mm-handle-cache handle)
 755         (mm-with-unibyte-buffer
 756           (mm-insert-part handle)
 757           (prog1
 758               (setq spec
 759                     (ignore-errors
 760                       (cond
 761                        ((equal type "xbm")
 762                         ;; xbm images require special handling, since
 763                         ;; the only way to create glyphs from these
 764                         ;; (without a ton of work) is to write them
 765                         ;; out to a file, and then create a file
 766                         ;; specifier.
 767                         (error "Don't know what to do for XBMs right now."))
 768                        (t
 769                         (list 'image :type (intern type) :data (buffer-string))))))
 770             (mm-handle-set-cache handle spec))))))
 771
 772 (defun mm-get-image-xemacs (handle)
 773   "Return an image instance based on HANDLE."
 774   (let ((type (mm-handle-media-subtype handle))
 775         spec)
 776     ;; Allow some common translations.
 777     (setq type
 778           (cond
 779            ((equal type "x-pixmap")
 780             "xpm")
 781            ((equal type "x-xbitmap")
 782             "xbm")
 783            (t type)))
 784     (or (mm-handle-cache handle)
 785         (mm-with-unibyte-buffer
 786           (mm-insert-part handle)
 787           (prog1
 788               (setq spec
 789                     (ignore-errors
 790                       (cond
 791                        ((equal type "xbm")
 792                         ;; xbm images require special handling, since
 793                         ;; the only way to create glyphs from these
 794                         ;; (without a ton of work) is to write them
 795                         ;; out to a file, and then create a file
 796                         ;; specifier.
 797                         (let ((file (make-temp-name
 798                                      (expand-file-name "emm.xbm"
 799                                                        mm-tmp-directory))))
 800                           (unwind-protect
 801                               (progn
 802                                 (write-region (point-min) (point-max) file)
 803                                 (make-glyph (list (cons 'x file))))
 804                             (ignore-errors
 805                               (delete-file file)))))
 806                        (t
 807                         (make-glyph
 808                          (vector (intern type) :data (buffer-string)))))))
 809             (mm-handle-set-cache handle spec))))))
 810
 811 (defun mm-get-image (handle)
 812   (if mm-xemacs-p
 813       (mm-get-image-xemacs handle)
 814     (mm-get-image-emacs handle)))
 815
 816 (defun mm-image-fit-p (handle)
 817   "Say whether the image in HANDLE will fit the current window."
 818   (let ((image (mm-get-image handle)))
 819     (if (fboundp 'glyph-width)
 820         ;; XEmacs' glyphs can actually tell us about their width, so
 821         ;; lets be nice and smart about them.
 822         (or mm-inline-large-images
 823             (and (< (glyph-width image) (window-pixel-width))
 824                  (< (glyph-height image) (window-pixel-height))))
 825       ;; Let's just inline everything under Emacs 21, since the image
 826       ;; specification there doesn't actually get the width/height
 827       ;; until you render the image.
 828       t)))
 829
 830 (defun mm-valid-image-format-p (format)
 831   "Say whether FORMAT can be displayed natively by Emacs."
 832   (cond
 833    ;; Handle XEmacs
 834    ((fboundp 'valid-image-instantiator-format-p)
 835     (valid-image-instantiator-format-p format))
 836    ;; Handle Emacs 21
 837    ((fboundp 'image-type-available-p)
 838     (image-type-available-p format))
 839    ;; Nobody else can do images yet.
 840    (t
 841     nil)))
 842
 843 (defun mm-valid-and-fit-image-p (format handle)
 844   "Say whether FORMAT can be displayed natively and HANDLE fits the window."
 845   (and window-system
 846        (mm-valid-image-format-p format)
 847        (mm-image-fit-p handle)))
 848
 849 (provide 'mm-decode)
 850
 851 ;; mm-decode.el ends here