`(nth 5 ,handle))
(defvar mm-inline-media-tests
- '(("image/jpeg" mm-inline-image (featurep 'jpeg))
- ("image/png" mm-inline-image (featurep 'png))
- ("image/gif" mm-inline-image (featurep 'gif))
- ("image/tiff" mm-inline-image (featurep 'tiff))
- ("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))
+ '(("image/jpeg" mm-inline-image
+ (and window-system (featurep 'jpeg) (mm-image-fit-p handle)))
+ ("image/png" mm-inline-image
+ (and window-system (featurep 'png) (mm-image-fit-p handle)))
+ ("image/gif" mm-inline-image
+ (and window-system (featurep 'gif) (mm-image-fit-p handle)))
+ ("image/tiff" mm-inline-image
+ (and window-system (featurep 'tiff) (mm-image-fit-p handle)))
+ ("image/xbm" mm-inline-image
+ (and window-system (fboundp 'device-type)
+ (eq (device-type) 'x)))
+ ("image/xpm" mm-inline-image
+ (and window-system (featurep 'xpm)))
+ ("image/bmp" mm-inline-image
+ (and window-system (featurep 'bmp)))
("text/plain" mm-inline-text t)
("text/enriched" mm-inline-text t)
("text/richtext" mm-inline-text t)
("message/delivery-status" . inline)))
(defvar mm-user-automatic-display
- '("text/plain" "text/enriched" "text/richtext" "text/html" "image/gif"
- "image/jpeg" "message/delivery-status" "multipart/.*"))
+ '("text/plain" "text/enriched" "text/richtext" "text/html"
+ "image/.*" "message/delivery-status" "multipart/.*"))
(defvar mm-alternative-precedence
- '("text/plain" "text/enriched" "text/richtext" "text/html")
+ '("image/jpeg" "image/gif" "text/html" "text/enriched"
+ "text/richtext" "text/plain")
"List that describes the precedence of alternative parts.")
(defvar mm-tmp-directory "/tmp/"
description (mail-fetch-field "content-description")
id (mail-fetch-field "content-id"))))
(if (not ctl)
- (mm-dissect-singlepart '("text/plain") nil no-strict-mime nil nil)
+ (mm-dissect-singlepart
+ '("text/plain") nil no-strict-mime nil description)
(setq type (split-string (car ctl) "/"))
(setq subtype (cadr type)
type (pop type))
no-strict-mime
(and cd (condition-case ()
(mail-header-parse-content-disposition cd)
- (error nil)))))))
+ (error nil)))
+ description))))
(when id
+ (when (string-match " *<\\(.*\\)> *" id)
+ (setq id (match-string 1 id)))
(push (cons id result) mm-content-id-alist))
result))))
(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)))
(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
(let ((methods mm-user-automatic-display)
method result)
(while (setq method (pop methods))
- (when (string-match method type)
+ (when (and (string-match method type)
+ (mm-inlinable-p type))
(setq result t
methods nil)))
result))
"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))
+ (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)
(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)))))
+ ;; Now every coding system is 100% binary within mm-with-unibyte-buffer
+ ;; Is text still special?
+ (let ((coding-system-for-write
+ (if (equal "text" (car (split-string
+ (car (mm-handle-type handle)) "/")))
+ buffer-file-coding-system
+ 'binary)))
+ (write-region (point-min) (point-max) file))))))
(defun mm-pipe-part (handle)
"Pipe HANDLE to a process."
(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)
+ p h result type handle)
(while (setq p (pop prec))
(setq h handles)
(while h
(if (stringp (caar h))
(caar h)
(car (mm-handle-type (car h)))))
+ (setq handle (car h))
(when (and (equal p type)
(mm-automatic-display-p type)
(or (stringp (caar h))
"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))))))
+
+(defun mm-image-fit-p (handle)
+ "Say whether the image in HANDLE will fit the current window."
+ (let ((image (make-annotation (mm-get-image handle))))
+ (and (< (glyph-width (annotation-glyph image))
+ (window-pixel-width))
+ (< (glyph-height (annotation-glyph image))
+ (window-pixel-height)))))
+
+(defun url-cid (url)
+ (set-buffer (get-buffer-create url-working-buffer))
+ (let ((content-type nil)
+ (encoding nil)
+ (part nil)
+ (data nil))
+ (if (not (string-match "^cid:\\(.*\\)" url))
+ (message "Malformed CID URL: %s" url)
+ (setq url (url-unhex-string (match-string 1 url))
+ part (mm-get-content-id url))
+ (if (not part)
+ (message "Unknown CID encounterred: %s" url)
+ (setq data (buffer-string nil nil (mm-handle-buffer part))
+ content-type (mm-handle-type part)
+ encoding (symbol-name (mm-handle-encoding part)))
+ (if (= 0 (length content-type)) (setq content-type "text/plain"))
+ (if (= 0 (length encoding)) (setq encoding "8bit"))
+ (setq url-current-content-length (length data)
+ url-current-mime-type content-type
+ url-current-mime-encoding encoding
+ url-current-mime-headers (list (cons "content-type" content-type)
+ (cons "content-encoding" encoding)))
+ (and data (insert data))))))
+
(provide 'mm-decode)
;; mm-decode.el ends here
projects / elisp / gnus.git- / blobdiff