;;; mm-decode.el --- Functions for decoding MIME things
-;; Copyright (C) 1998 Free Software Foundation, Inc.
+;; Copyright (C) 1998,99 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
`(nth 0 ,handle))
(defmacro mm-handle-type (handle)
`(nth 1 ,handle))
+(defsubst mm-handle-media-type (handle)
+ (if (stringp (car handle))
+ (car handle)
+ (car (mm-handle-type handle))))
+(defsubst mm-handle-media-supertype (handle)
+ (car (split-string (mm-handle-media-type handle) "/")))
+(defsubst mm-handle-media-subtype (handle)
+ (cadr (split-string (mm-handle-media-type handle) "/")))
(defmacro mm-handle-encoding (handle)
`(nth 2 ,handle))
(defmacro mm-handle-undisplayer (handle)
`(nth 4 ,handle))
(defmacro mm-handle-description (handle)
`(nth 5 ,handle))
+(defmacro mm-handle-cache (handle)
+ `(nth 6 ,handle))
+(defmacro mm-handle-set-cache (handle contents)
+ `(setcar (nthcdr 6 ,handle) ,contents))
+(defmacro mm-handle-id (handle)
+ `(nth 7 ,handle))
+(defmacro mm-make-handle (&optional buffer type encoding undisplayer
+ disposition description cache
+ id)
+ `(list ,buffer ,type ,encoding ,undisplayer
+ ,disposition ,description ,cache ,id))
(defvar mm-inline-media-tests
- '(("image/jpeg" mm-inline-image
- (and (featurep 'jpeg) (mm-image-fit-p handle)))
- ("image/png" mm-inline-image
- (and (featurep 'png) (mm-image-fit-p handle)))
- ("image/gif" mm-inline-image
- (and (featurep 'gif) (mm-image-fit-p handle)))
- ("image/tiff" mm-inline-image
- (and (featurep 'tiff) (mm-image-fit-p handle)))
- ("image/xbm" mm-inline-image (and (fboundp 'device-type)
- (eq (device-type) 'x)))
- ("image/xpm" mm-inline-image (featurep 'xpm))
- ("image/bmp" mm-inline-image (featurep 'bmp))
- ("text/plain" mm-inline-text t)
- ("text/enriched" mm-inline-text t)
- ("text/richtext" mm-inline-text t)
- ("text/html" mm-inline-text (locate-library "w3"))
- ("message/delivery-status" mm-inline-text t)
+ '(("image/jpeg"
+ mm-inline-image
+ (lambda (handle)
+ (mm-valid-and-fit-image-p 'jpeg handle)))
+ ("image/png"
+ mm-inline-image
+ (lambda (handle)
+ (mm-valid-and-fit-image-p 'png handle)))
+ ("image/gif"
+ mm-inline-image
+ (lambda (handle)
+ (mm-valid-and-fit-image-p 'gif handle)))
+ ("image/tiff"
+ mm-inline-image
+ (lambda (handle)
+ (mm-valid-and-fit-image-p 'tiff handle)) )
+ ("image/xbm"
+ mm-inline-image
+ (lambda (handle)
+ (mm-valid-and-fit-image-p 'xbm handle)))
+ ("image/x-xbitmap"
+ mm-inline-image
+ (lambda (handle)
+ (mm-valid-and-fit-image-p 'xbm handle)))
+ ("image/xpm"
+ mm-inline-image
+ (lambda (handle)
+ (mm-valid-and-fit-image-p 'xpm handle)))
+ ("image/x-pixmap"
+ mm-inline-image
+ (lambda (handle)
+ (mm-valid-and-fit-image-p 'xpm handle)))
+ ("image/bmp"
+ mm-inline-image
+ (lambda (handle)
+ (mm-valid-and-fit-image-p 'bmp handle)))
+ ("text/plain" mm-inline-text identity)
+ ("text/enriched" mm-inline-text identity)
+ ("text/richtext" mm-inline-text identity)
+ ("text/html"
+ mm-inline-text
+ (lambda (handle)
+ (locate-library "w3")))
+ ("text/x-vcard"
+ mm-inline-text
+ (lambda (handle)
+ (locate-library "vcard")))
+ ("message/delivery-status" mm-inline-text identity)
+ ("message/rfc822" mm-inline-message identity)
+ ("text/.*" mm-inline-text identity)
("audio/wav" mm-inline-audio
- (and (or (featurep 'nas-sound) (featurep 'native-sound))
- (device-sound-enabled-p)))
- ("audio/au" mm-inline-audio
- (and (or (featurep 'nas-sound) (featurep 'native-sound))
- (device-sound-enabled-p))))
+ (lambda (handle)
+ (and (or (featurep 'nas-sound) (featurep 'native-sound))
+ (device-sound-enabled-p))))
+ ("audio/au"
+ mm-inline-audio
+ (lambda (handle)
+ (and (or (featurep 'nas-sound) (featurep 'native-sound))
+ (device-sound-enabled-p))))
+ ("multipart/alternative" ignore identity)
+ ("multipart/mixed" ignore identity)
+ ("multipart/related" ignore identity))
"Alist of media types/test that say whether the media types can be displayed inline.")
-(defvar mm-user-display-methods
- '(("image/.*" . inline)
- ("text/.*" . inline)
- ("message/delivery-status" . inline)))
-
-(defvar mm-user-automatic-display
- '("text/plain" "text/enriched" "text/richtext" "text/html"
- "image/.*" "message/delivery-status" "multipart/.*"))
-
-(defvar mm-alternative-precedence
- '("text/html" "text/enriched" "text/richtext" "text/plain")
- "List that describes the precedence of alternative parts.")
-
-(defvar mm-tmp-directory "/tmp/"
+(defvar mm-inlined-types
+ '("image/.*" "text/.*" "message/delivery-status" "message/rfc822")
+ "List of media types that are to be displayed inline.")
+
+(defvar mm-automatic-display
+ '("text/plain" "text/enriched" "text/richtext" "text/html"
+ "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*"
+ "message/rfc822")
+ "A list of MIME types to be displayed automatically.")
+
+(defvar mm-attachment-override-types
+ '("text/plain" "text/x-vcard")
+ "Types that should have \"attachment\" ignored if they can be displayed inline.")
+
+(defvar mm-automatic-external-display nil
+ "List of MIME type regexps that will be displayed externally automatically.")
+
+(defvar mm-discouraged-alternatives nil
+ "List of MIME types that are discouraged when viewing multipart/alternative.
+Viewing agents are supposed to view the last possible part of a message,
+as that is supposed to be the richest. However, users may prefer other
+types instead, and this list says what types are most unwanted. If,
+for instance, text/html parts are very unwanted, and text/richtech are
+somewhat unwanted, then the value of this variable should be set
+to:
+
+ (\"text/html\" \"text/richtext\")")
+
+(defvar mm-tmp-directory
+ (cond ((fboundp 'temp-directory) (temp-directory))
+ ((boundp 'temporary-file-directory) temporary-file-directory)
+ ("/tmp/"))
"Where mm will store its temporary files.")
+(defvar mm-inline-large-images nil
+ "If non-nil, then all images fit in the buffer.")
+
;;; Internal variables.
(defvar mm-dissection-list nil)
(let (ct ctl type subtype cte cd description id result)
(save-restriction
(mail-narrow-to-head)
- (when (and (or no-strict-mime
- (mail-fetch-field "mime-version"))
- (setq ct (mail-fetch-field "content-type")))
- (setq ctl (condition-case () (mail-header-parse-content-type ct)
- (error nil))
+ (when (or no-strict-mime
+ (mail-fetch-field "mime-version"))
+ (setq ct (mail-fetch-field "content-type")
+ ctl (ignore-errors (mail-header-parse-content-type ct))
cte (mail-fetch-field "content-transfer-encoding")
cd (mail-fetch-field "content-disposition")
description (mail-fetch-field "content-description")
id (mail-fetch-field "content-id"))))
- (if (not ctl)
+ (if (or (not ctl)
+ (not (string-match "/" (car ctl))))
(mm-dissect-singlepart
- '("text/plain") nil no-strict-mime nil description)
+ '("text/plain") nil no-strict-mime
+ (and cd (ignore-errors (mail-header-parse-content-disposition cd)))
+ description)
(setq type (split-string (car ctl) "/"))
(setq subtype (cadr type)
type (pop type))
(mail-header-remove-comments
cte)))))
no-strict-mime
- (and cd (condition-case ()
- (mail-header-parse-content-disposition cd)
- (error nil)))
- description))))
+ (and cd (ignore-errors (mail-header-parse-content-disposition cd)))
+ description id))))
(when id
+ (when (string-match " *<\\(.*\\)> *" id)
+ (setq id (match-string 1 id)))
(push (cons id result) mm-content-id-alist))
result))))
-(defun mm-dissect-singlepart (ctl cte &optional force cdl description)
+(defun mm-dissect-singlepart (ctl cte &optional force cdl description id)
(when (or force
(not (equal "text/plain" (car ctl))))
- (let ((res (list (mm-copy-to-buffer) ctl cte nil cdl description)))
+ (let ((res (mm-make-handle
+ (mm-copy-to-buffer) ctl cte nil cdl description nil id)))
(push (car res) mm-dissection-list)
res)))
(goto-char (point-min))
(let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
(close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))
- start parts
- (end (save-excursion
+ start parts
+ (end (save-excursion
(goto-char (point-max))
(if (re-search-backward close-delimiter nil t)
(match-beginning 0)
(insert-buffer-substring obuf beg)
(current-buffer))))
-(defun mm-inlinable-part-p (type)
- "Say whether TYPE can be displayed inline."
- (eq (mm-user-method type) 'inline))
-
(defun mm-display-part (handle &optional no-default)
"Display the MIME part represented by HANDLE.
Returns nil if the part is removed; inline if displayed inline;
(mailcap-parse-mailcaps)
(if (mm-handle-displayed-p handle)
(mm-remove-part handle)
- (let* ((type (car (mm-handle-type handle)))
- (method (mailcap-mime-info type))
- (user-method (mm-user-method type)))
- (if (eq user-method 'inline)
+ (let* ((type (mm-handle-media-type handle))
+ (method (mailcap-mime-info type)))
+ (if (mm-inlined-p handle)
(progn
(forward-line 1)
- (mm-display-inline handle))
- (when (or user-method
- method
+ (mm-display-inline handle)
+ 'inline)
+ (when (or method
(not no-default))
- (if (and (not user-method)
- (not method)
+ (if (and (not method)
(equal "text" (car (split-string type))))
(progn
+ (forward-line 1)
(mm-insert-inline handle (mm-get-part handle))
'inline)
(mm-display-external
- handle (or user-method method
- 'mailcap-save-binary-file))
+ handle (or method 'mailcap-save-binary-file))
'external)))))))
(defun mm-display-external (handle method)
"Display HANDLE using METHOD."
(mm-with-unibyte-buffer
- (insert-buffer-substring (mm-handle-buffer handle))
- (mm-decode-content-transfer-encoding
- (mm-handle-encoding handle) (car (mm-handle-type handle)))
(if (functionp method)
(let ((cur (current-buffer)))
(if (eq method 'mailcap-save-binary-file)
(progn
(set-buffer (generate-new-buffer "*mm*"))
(setq method nil))
+ (mm-insert-part handle)
(let ((win (get-buffer-window cur t)))
(when win
(select-window win)))
(switch-to-buffer (generate-new-buffer "*mm*")))
(buffer-disable-undo)
- (mm-set-buffer-file-coding-system 'no-conversion)
+ (mm-set-buffer-file-coding-system mm-binary-coding-system)
(insert-buffer-substring cur)
(message "Viewing with %s" method)
- (let ((mm (current-buffer)))
+ (let ((mm (current-buffer))
+ (non-viewer (assoc "non-viewer"
+ (mailcap-mime-info
+ (mm-handle-media-type handle)) t)))
(unwind-protect
(if method
(funcall method)
(mm-save-part handle))
- (mm-handle-set-undisplayer handle mm))))
+ (when (and (not non-viewer)
+ method)
+ (mm-handle-set-undisplayer handle mm)))))
+ ;; The function is a string to be executed.
+ (mm-insert-part handle)
(let* ((dir (make-temp-name (expand-file-name "emm." mm-tmp-directory)))
(filename (mail-content-type-get
(mm-handle-disposition handle) 'filename))
(needsterm (assoc "needsterm"
(mailcap-mime-info
- (car (mm-handle-type handle)) t)))
- process file)
+ (mm-handle-media-type handle)) t))
+ process file buffer)
;; We create a private sub-directory where we store our files.
(make-directory dir)
(set-file-modes dir 448)
(setq file (expand-file-name (file-name-nondirectory filename)
dir))
(setq file (make-temp-name (expand-file-name "mm." dir))))
- (write-region (point-min) (point-max)
- file nil 'nomesg nil 'no-conversion)
+ (write-region (point-min) (point-max) file nil 'nomesg)
(message "Viewing with %s" method)
(unwind-protect
(setq process
"-e" shell-file-name "-c"
(format method
(mm-quote-arg file)))
- (start-process "*display*" (generate-new-buffer "*mm*")
+ (start-process "*display*"
+ (setq buffer (generate-new-buffer "*mm*"))
shell-file-name
"-c" (format method
(mm-quote-arg file)))))
- (mm-handle-set-undisplayer handle (cons file process)))
+ (mm-handle-set-undisplayer handle (cons file buffer)))
(message "Displaying %s..." (format method file))))))
(defun mm-remove-parts (handles)
"Remove the displayed MIME part represented by HANDLE."
(when (listp handle)
(let ((object (mm-handle-undisplayer handle)))
- (condition-case ()
- (cond
- ;; Internally displayed part.
- ((mm-annotationp object)
- (delete-annotation object))
- ((or (functionp object)
- (and (listp object)
- (eq (car object) 'lambda)))
- (funcall object))
- ;; Externally displayed part.
- ((consp object)
- (condition-case ()
- (delete-file (car object))
- (error nil))
- (condition-case ()
- (delete-directory (file-name-directory (car object)))
- (error nil))
- (condition-case ()
- (kill-process (cdr object))
- (error nil)))
- ((bufferp object)
- (when (buffer-live-p object)
- (kill-buffer object))))
- (error nil))
+ (ignore-errors
+ (cond
+ ;; Internally displayed part.
+ ((mm-annotationp object)
+ (delete-annotation object))
+ ((or (functionp object)
+ (and (listp object)
+ (eq (car object) 'lambda)))
+ (funcall object))
+ ;; Externally displayed part.
+ ((consp object)
+ (ignore-errors (delete-file (car object)))
+ (ignore-errors (delete-directory (file-name-directory (car object))))
+ (ignore-errors (kill-buffer (cdr object))))
+ ((bufferp object)
+ (when (buffer-live-p object)
+ (kill-buffer object)))))
(mm-handle-set-undisplayer handle nil))))
(defun mm-display-inline (handle)
- (let* ((type (car (mm-handle-type handle)))
+ (let* ((type (mm-handle-media-type handle))
(function (cadr (assoc type mm-inline-media-tests))))
(funcall function handle)
(goto-char (point-min))))
-(defun mm-inlinable-p (type)
- "Say whether TYPE can be displayed inline."
+(defun mm-inlinable-p (handle)
+ "Say whether HANDLE can be displayed inline."
(let ((alist mm-inline-media-tests)
+ (type (mm-handle-media-type handle))
test)
(while alist
(when (equal type (caar alist))
(setq test (caddar alist)
alist nil)
- (setq test (eval test)))
+ (setq test (funcall test handle)))
(pop alist))
test))
-(defun mm-user-method (type)
- "Return the user-defined method for TYPE."
- (let ((methods mm-user-display-methods)
+(defun mm-automatic-display-p (handle)
+ "Say whether the user wants HANDLE to be displayed automatically."
+ (let ((methods mm-automatic-display)
+ (type (mm-handle-media-type handle))
method result)
(while (setq method (pop methods))
- (when (string-match (car method) type)
- (when (or (not (eq (cdr method) 'inline))
- (mm-inlinable-p type))
- (setq result (cdr method)
- methods nil))))
+ (when (and (string-match method type)
+ (mm-inlinable-p handle))
+ (setq result t
+ methods nil)))
result))
-(defun mm-automatic-display-p (type)
- "Return the user-defined method for TYPE."
- (let ((methods mm-user-automatic-display)
+(defun mm-inlined-p (handle)
+ "Say whether the user wants HANDLE to be displayed automatically."
+ (let ((methods mm-inlined-types)
+ (type (mm-handle-media-type handle))
method result)
(while (setq method (pop methods))
(when (and (string-match method type)
- (mm-inlinable-p type))
+ (mm-inlinable-p handle))
(setq result t
methods nil)))
result))
-(defun add-mime-display-method (type method)
- "Make parts of TYPE be displayed with METHOD.
-This overrides entries in the mailcap file."
- (push (cons type method) mm-user-display-methods))
+(defun mm-attachment-override-p (handle)
+ "Say whether HANDLE should have attachment behavior overridden."
+ (let ((types mm-attachment-override-types)
+ (type (mm-handle-media-type handle))
+ ty)
+ (catch 'found
+ (while (setq ty (pop types))
+ (when (and (string-match ty type)
+ (mm-inlinable-p handle))
+ (throw 'found t))))))
+
+(defun mm-automatic-external-display-p (type)
+ "Return the user-defined method for TYPE."
+ (let ((methods mm-automatic-external-display)
+ method result)
+ (while (setq method (pop methods))
+ (when (string-match method type)
+ (setq result t
+ methods nil)))
+ result))
(defun mm-destroy-part (handle)
"Destroy the data structures connected to HANDLE."
(defun mm-handle-displayed-p (handle)
"Say whether HANDLE is displayed or not."
(mm-handle-undisplayer handle))
-
-(defun mm-quote-arg (arg)
- "Return a version of ARG that is safe to evaluate in a shell."
- (let ((pos 0) new-pos accum)
- ;; *** bug: we don't handle newline characters properly
- (while (setq new-pos (string-match "[;!`\"$\\& \t{} ]" arg pos))
- (push (substring arg pos new-pos) accum)
- (push "\\" accum)
- (push (list (aref arg new-pos)) accum)
- (setq pos (1+ new-pos)))
- (if (= pos 0)
- arg
- (apply 'concat (nconc (nreverse accum) (list (substring arg pos)))))))
;;;
;;; Functions for outputting parts
(defun mm-get-part (handle)
"Return the contents of HANDLE as a string."
(mm-with-unibyte-buffer
- (insert-buffer-substring (mm-handle-buffer handle))
- (mm-decode-content-transfer-encoding
- (mm-handle-encoding handle)
- (car (mm-handle-type handle)))
+ (mm-insert-part handle)
(buffer-string)))
+(defun mm-insert-part (handle)
+ "Insert the contents of HANDLE in the current buffer."
+ (let ((cur (current-buffer)))
+ (save-excursion
+ (if (member (mm-handle-media-supertype handle) '("text" "message"))
+ (with-temp-buffer
+ (insert-buffer-substring (mm-handle-buffer handle))
+ (mm-decode-content-transfer-encoding
+ (mm-handle-encoding handle)
+ (mm-handle-media-type handle))
+ (let ((temp (current-buffer)))
+ (set-buffer cur)
+ (insert-buffer-substring temp)))
+ (mm-with-unibyte-buffer
+ (insert-buffer-substring (mm-handle-buffer handle))
+ (mm-decode-content-transfer-encoding
+ (mm-handle-encoding handle)
+ (mm-handle-media-type handle))
+ (let ((temp (current-buffer)))
+ (set-buffer cur)
+ (insert-buffer-substring temp)))))))
+
(defvar mm-default-directory nil)
(defun mm-save-part (handle)
(or filename name "")
(or mm-default-directory default-directory))))
(setq mm-default-directory (file-name-directory file))
- (mm-with-unibyte-buffer
- (insert-buffer-substring (mm-handle-buffer handle))
- (mm-decode-content-transfer-encoding
- (mm-handle-encoding handle)
- (car (mm-handle-type handle)))
- (when (or (not (file-exists-p file))
- (yes-or-no-p (format "File %s already exists; overwrite? "
- file)))
- (write-region (point-min) (point-max) file)))))
+ (when (or (not (file-exists-p file))
+ (yes-or-no-p (format "File %s already exists; overwrite? "
+ file)))
+ (mm-save-part-to-file handle file))))
+
+(defun mm-save-part-to-file (handle file)
+ (mm-with-unibyte-buffer
+ (mm-insert-part handle)
+ ;; Now every coding system is 100% binary within mm-with-unibyte-buffer
+ ;; Is text still special?
+ (let ((coding-system-for-write
+ (if (equal "text" (mm-handle-media-supertype handle))
+ buffer-file-coding-system
+ 'binary))
+ ;; Don't re-compress .gz & al. Arguably we should make
+ ;; `file-name-handler-alist' nil, but that would chop
+ ;; ange-ftp which it's reasonable to use here.
+ (inhibit-file-name-operation 'write-region)
+ (inhibit-file-name-handlers
+ (if (equal (mm-handle-media-type handle)
+ "application/octet-stream")
+ (cons 'jka-compr-handler inhibit-file-name-handlers)
+ inhibit-file-name-handlers)))
+ (write-region (point-min) (point-max) file))))
(defun mm-pipe-part (handle)
"Pipe HANDLE to a process."
(command
(read-string "Shell command on MIME part: " mm-last-shell-command)))
(mm-with-unibyte-buffer
- (insert-buffer-substring (mm-handle-buffer handle))
- (mm-decode-content-transfer-encoding
- (mm-handle-encoding handle)
- (car (mm-handle-type handle)))
+ (mm-insert-part handle)
(shell-command-on-region (point-min) (point-max) command nil))))
(defun mm-interactively-view-part (handle)
"Display HANDLE using METHOD."
- (let* ((type (car (mm-handle-type handle)))
+ (let* ((type (mm-handle-media-type handle))
(methods
(mapcar (lambda (i) (list (cdr (assoc 'viewer i))))
(mailcap-mime-info type 'all)))
(defun mm-preferred-alternative (handles &optional preferred)
"Say which of HANDLES are preferred."
- (let ((prec (if preferred (list preferred) mm-alternative-precedence))
- p h result type)
+ (let ((prec (if preferred (list preferred)
+ (mm-preferred-alternative-precedence handles)))
+ p h result type handle)
(while (setq p (pop prec))
(setq h handles)
(while h
- (setq type
- (if (stringp (caar h))
- (caar h)
- (car (mm-handle-type (car h)))))
+ (setq handle (car h))
+ (setq type (mm-handle-media-type handle))
(when (and (equal p type)
- (mm-automatic-display-p type)
- (or (stringp (caar h))
- (not (mm-handle-disposition (car h)))
- (equal (car (mm-handle-disposition (car h)))
+ (mm-automatic-display-p handle)
+ (or (stringp (car handle))
+ (not (mm-handle-disposition handle))
+ (equal (car (mm-handle-disposition handle))
"inline")))
- (setq result (car h)
+ (setq result handle
h nil
prec nil))
(pop h)))
result))
+(defun mm-preferred-alternative-precedence (handles)
+ "Return the precedence based on HANDLES and mm-discouraged-alternatives."
+ (let ((seq (nreverse (mapcar (lambda (h)
+ (mm-handle-media-type h))
+ handles))))
+ (dolist (disc (reverse mm-discouraged-alternatives))
+ (dolist (elem (copy-sequence seq))
+ (when (string-match disc elem)
+ (setq seq (nconc (delete elem seq) (list elem))))))
+ seq))
+
(defun mm-get-content-id (id)
"Return the handle(s) referred to by ID."
(cdr (assoc id mm-content-id-alist)))
(defun mm-get-image (handle)
"Return an image instance based on HANDLE."
- (let ((type (cadr (split-string (car (mm-handle-type handle)) "/"))))
- (mm-with-unibyte-buffer
- (insert-buffer-substring (mm-handle-buffer handle))
- (mm-decode-content-transfer-encoding
- (mm-handle-encoding handle)
- (car (mm-handle-type handle)))
- (make-image-specifier
- (vector (intern type) :data (buffer-string))))))
+ (let ((type (mm-handle-media-subtype handle))
+ spec)
+ ;; Allow some common translations.
+ (setq type
+ (cond
+ ((equal type "x-pixmap")
+ "xpm")
+ ((equal type "x-xbitmap")
+ "xbm")
+ (t type)))
+ (or (mm-handle-cache handle)
+ (mm-with-unibyte-buffer
+ (mm-insert-part handle)
+ (prog1
+ (setq spec
+ (ignore-errors
+ (cond
+ ((equal type "xbm")
+ ;; xbm images require special handling, since
+ ;; the only way to create glyphs from these
+ ;; (without a ton of work) is to write them
+ ;; out to a file, and then create a file
+ ;; specifier.
+ (let ((file (make-temp-name
+ (expand-file-name "emm.xbm"
+ mm-tmp-directory))))
+ (unwind-protect
+ (progn
+ (write-region (point-min) (point-max) file)
+ (make-glyph (list (cons 'x file))))
+ (ignore-errors
+ (delete-file file)))))
+ (t
+ (make-glyph
+ (vector (intern type) :data (buffer-string)))))))
+ (mm-handle-set-cache handle spec))))))
(defun mm-image-fit-p (handle)
"Say whether the image in HANDLE will fit the current window."
- (or t
- (let ((image (make-image-instance (mm-get-image handle))))
- (and (< (image-instance-width image)
- (window-pixel-width))
- (< (image-instance-height image)
- (window-pixel-height))))))
+ (let ((image (mm-get-image handle)))
+ (or mm-inline-large-images
+ (and (< (glyph-width image) (window-pixel-width))
+ (< (glyph-height image) (window-pixel-height))))))
+
+(defun mm-valid-image-format-p (format)
+ "Say whether FORMAT can be displayed natively by Emacs."
+ (and (fboundp 'valid-image-instantiator-format-p)
+ (valid-image-instantiator-format-p format)))
+
+(defun mm-valid-and-fit-image-p (format handle)
+ "Say whether FORMAT can be displayed natively and HANDLE fits the window."
+ (and window-system
+ (mm-valid-image-format-p format)
+ (mm-image-fit-p handle)))
(provide 'mm-decode)
projects / elisp / gnus.git- / blobdiff