X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmm-decode.el;h=717e01709e1ce4af44817b4d9d2d1c5d72548c1a;hb=a2d6af2c24264119c5aff0ef0063733674eef102;hp=d3c6b9c6b5fbb9fa432a6ac61c82239bc29e7349;hpb=c3e1fa9581a5bfd59386b25a438fbb6650441f79;p=elisp%2Fgnus.git- diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index d3c6b9c..717e017 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -1,5 +1,5 @@ ;;; mm-decode.el --- Functions for decoding MIME things -;; Copyright (C) 1998,99 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -28,12 +28,28 @@ (require 'mailcap) (require 'mm-bodies) +(defvar mm-xemacs-p (string-match "XEmacs" (emacs-version))) + +(defgroup mime-display () + "Display of MIME in mail and news articles." + :link '(custom-manual "(emacs-mime)Customization") + :group 'mail + :group 'news) + ;;; Convenience macros. (defmacro mm-handle-buffer (handle) `(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) @@ -56,7 +72,7 @@ `(list ,buffer ,type ,encoding ,undisplayer ,disposition ,description ,cache ,id)) -(defvar mm-inline-media-tests +(defcustom mm-inline-media-tests '(("image/jpeg" mm-inline-image (lambda (handle) @@ -96,6 +112,9 @@ ("text/plain" mm-inline-text identity) ("text/enriched" mm-inline-text identity) ("text/richtext" mm-inline-text identity) + ("text/x-patch" mm-display-patch-inline + (lambda (handle) + (locate-library "diff-mode"))) ("text/html" mm-inline-text (lambda (handle) @@ -103,7 +122,8 @@ ("text/x-vcard" mm-inline-text (lambda (handle) - (locate-library "vcard"))) + (or (featurep 'vcard) + (locate-library "vcard")))) ("message/delivery-status" mm-inline-text identity) ("message/rfc822" mm-inline-message identity) ("text/.*" mm-inline-text identity) @@ -116,29 +136,47 @@ (lambda (handle) (and (or (featurep 'nas-sound) (featurep 'native-sound)) (device-sound-enabled-p)))) + ("application/pgp-signature" ignore identity) ("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-inlined-types - '("image/.*" "text/.*" "message/delivery-status" "message/rfc822") - "List of media types that are to be displayed inline.") + "Alist of media types/tests saying whether types can be displayed inline." + :type '(repeat (list (string :tag "MIME type") + (function :tag "Display function") + (function :tag "Display test"))) + :group 'mime-display) + +(defcustom mm-inlined-types + '("image/.*" "text/.*" "message/delivery-status" "message/rfc822" + "application/pgp-signature") + "List of media types that are to be displayed inline." + :type '(repeat string) + :group 'mime-display) -(defvar mm-automatic-display +(defcustom 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 + "message/rfc822" "text/x-patch" "application/pgp-signature") + "A list of MIME types to be displayed automatically." + :type '(repeat string) + :group 'mime-display) + +(defcustom mm-attachment-override-types '("text/x-vcard") + "Types to have \"attachment\" ignored if they can be displayed inline." + :type '(repeat string) + :group 'mime-display) + +(defcustom mm-inline-override-types nil + "Types to be treated as attachments even if they can be displayed inline." + :type '(repeat string) + :group 'mime-display) + +(defcustom mm-automatic-external-display nil + "List of MIME type regexps that will be displayed externally automatically." + :type '(repeat string) + :group 'mime-display) + +(defcustom 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 @@ -147,7 +185,9 @@ 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\")") + (\"text/html\" \"text/richtext\")" + :type '(repeat string) + :group 'mime-display) (defvar mm-tmp-directory (cond ((fboundp 'temp-directory) (temp-directory)) @@ -155,8 +195,10 @@ to: ("/tmp/")) "Where mm will store its temporary files.") -(defvar mm-inline-large-images nil - "If non-nil, then all images fit in the buffer.") +(defcustom mm-inline-large-images nil + "If non-nil, then all images fit in the buffer." + :type 'boolean + :group 'mime-display) ;;; Internal variables. @@ -180,10 +222,16 @@ to: cd (mail-fetch-field "content-disposition") description (mail-fetch-field "content-description") id (mail-fetch-field "content-id")))) + (when cte + (setq cte (mail-header-strip cte))) (if (or (not ctl) (not (string-match "/" (car ctl)))) (mm-dissect-singlepart - '("text/plain") nil no-strict-mime + '("text/plain") + (and cte (intern (downcase (mail-header-remove-whitespace + (mail-header-remove-comments + cte))))) + no-strict-mime (and cd (ignore-errors (mail-header-parse-content-disposition cd))) description) (setq type (split-string (car ctl) "/")) @@ -211,7 +259,9 @@ to: (defun mm-dissect-singlepart (ctl cte &optional force cdl description id) (when (or force - (not (equal "text/plain" (car ctl)))) + (if (equal "text/plain" (car ctl)) + (assoc 'format ctl) + t)) (let ((res (mm-make-handle (mm-copy-to-buffer) ctl cte nil cdl description nil id))) (push (car res) mm-dissection-list) @@ -226,13 +276,13 @@ to: (defun mm-dissect-multipart (ctl) (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 - (goto-char (point-max)) - (if (re-search-backward close-delimiter nil t) - (match-beginning 0) - (point-max))))) + (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$")) + start parts + (end (save-excursion + (goto-char (point-max)) + (if (re-search-backward close-delimiter nil t) + (match-beginning 0) + (point-max))))) (while (search-forward boundary end t) (goto-char (match-beginning 0)) (when start @@ -269,7 +319,7 @@ external if displayed external." (mailcap-parse-mailcaps) (if (mm-handle-displayed-p handle) (mm-remove-part handle) - (let* ((type (car (mm-handle-type handle))) + (let* ((type (mm-handle-media-type handle)) (method (mailcap-mime-info type))) (if (mm-inlined-p handle) (progn @@ -285,72 +335,134 @@ external if displayed external." (mm-insert-inline handle (mm-get-part handle)) 'inline) (mm-display-external - handle (or method 'mailcap-save-binary-file)) - 'external))))))) + handle (or method 'mailcap-save-binary-file))))))))) (defun mm-display-external (handle method) "Display HANDLE using METHOD." - (mm-with-unibyte-buffer - (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 mm-binary-coding-system) - (insert-buffer-substring cur) + (let ((outbuf (current-buffer))) + (mm-with-unibyte-buffer + (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 mm-binary-coding-system) + (insert-buffer-substring cur) + (message "Viewing with %s" method) + (let ((mm (current-buffer)) + (non-viewer (assq 'non-viewer + (mailcap-mime-info + (mm-handle-media-type handle) t)))) + (unwind-protect + (if method + (funcall method) + (mm-save-part handle)) + (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)) + (mime-info (mailcap-mime-info + (mm-handle-media-type handle) t)) + (needsterm (or (assoc "needsterm" mime-info) + (assoc "needsterminal" mime-info))) + (copiousoutput (assoc "copiousoutput" mime-info)) + file buffer) + ;; We create a private sub-directory where we store our files. + (make-directory dir) + (set-file-modes dir 448) + (if filename + (setq file (expand-file-name (file-name-nondirectory filename) + dir)) + (setq file (make-temp-name (expand-file-name "mm." dir)))) + (let ((coding-system-for-write mm-binary-coding-system)) + (write-region (point-min) (point-max) file nil 'nomesg)) (message "Viewing with %s" method) - (let ((mm (current-buffer)) - (non-viewer (assoc "non-viewer" - (mailcap-mime-info - (car (mm-handle-type handle)) t)))) - (unwind-protect - (if method - (funcall method) - (mm-save-part handle)) - (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 buffer) - ;; We create a private sub-directory where we store our files. - (make-directory dir) - (set-file-modes dir 448) - (if filename - (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) - (message "Viewing with %s" method) - (unwind-protect - (setq process - (if needsterm - (start-process "*display*" nil - "xterm" - "-e" shell-file-name "-c" - (format method - (mm-quote-arg file))) - (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 buffer))) - (message "Displaying %s..." (format method file)))))) - + (cond (needsterm + (unwind-protect + (start-process "*display*" nil + "xterm" + "-e" shell-file-name + shell-command-switch + (mm-mailcap-command + method file (mm-handle-type handle))) + (mm-handle-set-undisplayer handle (cons file buffer))) + (message "Displaying %s..." (format method file)) + 'external) + (copiousoutput + (with-current-buffer outbuf + (forward-line 1) + (mm-insert-inline + handle + (unwind-protect + (progn + (call-process shell-file-name nil + (setq buffer + (generate-new-buffer "*mm*")) + nil + shell-command-switch + (mm-mailcap-command + method file (mm-handle-type handle))) + (if (buffer-live-p buffer) + (save-excursion + (set-buffer buffer) + (buffer-string)))) + (progn + (ignore-errors (delete-file file)) + (ignore-errors (delete-directory + (file-name-directory file))) + (ignore-errors (kill-buffer buffer)))))) + 'inline) + (t + (unwind-protect + (start-process "*display*" + (setq buffer + (generate-new-buffer "*mm*")) + shell-file-name + shell-command-switch + (mm-mailcap-command + method file (mm-handle-type handle))) + (mm-handle-set-undisplayer handle (cons file buffer))) + (message "Displaying %s..." (format method file)) + 'external))))))) + +(defun mm-mailcap-command (method file type-list) + (let ((ctl (cdr type-list)) + (beg 0) + (uses-stdin t) + out sub total) + (while (string-match "%{\\([^}]+\\)}\\|%s\\|%t\\|%%" method beg) + (push (substring method beg (match-beginning 0)) out) + (setq beg (match-end 0) + total (match-string 0 method) + sub (match-string 1 method)) + (cond + ((string= total "%%") + (push "%" out)) + ((string= total "%s") + (setq uses-stdin nil) + (push (mm-quote-arg file) out)) + ((string= total "%t") + (push (mm-quote-arg (car type-list)) out)) + (t + (push (mm-quote-arg (or (cdr (assq (intern sub) ctl)) "")) out)))) + (push (substring method beg (length method)) out) + (if uses-stdin + (progn + (push "<" out) + (push (mm-quote-arg file) out))) + (mapconcat 'identity (nreverse out) ""))) + (defun mm-remove-parts (handles) "Remove the displayed MIME parts represented by HANDLE." (if (and (listp handles) @@ -360,6 +472,7 @@ external if displayed external." (while (setq handle (pop handles)) (cond ((stringp handle) + ;; Do nothing. ) ((and (listp handle) (stringp (car handle))) @@ -376,6 +489,7 @@ external if displayed external." (while (setq handle (pop handles)) (cond ((stringp handle) + ;; Do nothing. ) ((and (listp handle) (stringp (car handle))) @@ -407,18 +521,23 @@ external if displayed external." (mm-handle-set-undisplayer handle nil)))) (defun mm-display-inline (handle) - (let* ((type (car (mm-handle-type handle))) - (function (cadr (assoc type mm-inline-media-tests)))) + (let* ((type (mm-handle-media-type handle)) + (function (cadr (mm-assoc-string-match mm-inline-media-tests type)))) (funcall function handle) (goto-char (point-min)))) +(defun mm-assoc-string-match (alist type) + (dolist (elem alist) + (when (string-match (car elem) type) + (return elem)))) + (defun mm-inlinable-p (handle) "Say whether HANDLE can be displayed inline." (let ((alist mm-inline-media-tests) - (type (car (mm-handle-type handle))) + (type (mm-handle-media-type handle)) test) (while alist - (when (equal type (caar alist)) + (when (string-match (caar alist) type) (setq test (caddar alist) alist nil) (setq test (funcall test handle))) @@ -428,10 +547,11 @@ external if displayed external." (defun mm-automatic-display-p (handle) "Say whether the user wants HANDLE to be displayed automatically." (let ((methods mm-automatic-display) - (type (car (mm-handle-type handle))) + (type (mm-handle-media-type handle)) method result) (while (setq method (pop methods)) - (when (and (string-match method type) + (when (and (not (mm-inline-override-p handle)) + (string-match method type) (mm-inlinable-p handle)) (setq result t methods nil))) @@ -440,10 +560,11 @@ external if displayed external." (defun mm-inlined-p (handle) "Say whether the user wants HANDLE to be displayed automatically." (let ((methods mm-inlined-types) - (type (car (mm-handle-type handle))) + (type (mm-handle-media-type handle)) method result) (while (setq method (pop methods)) - (when (and (string-match method type) + (when (and (not (mm-inline-override-p handle)) + (string-match method type) (mm-inlinable-p handle)) (setq result t methods nil))) @@ -452,7 +573,7 @@ external if displayed external." (defun mm-attachment-override-p (handle) "Say whether HANDLE should have attachment behavior overridden." (let ((types mm-attachment-override-types) - (type (car (mm-handle-type handle))) + (type (mm-handle-media-type handle)) ty) (catch 'found (while (setq ty (pop types)) @@ -460,6 +581,16 @@ external if displayed external." (mm-inlinable-p handle)) (throw 'found t)))))) +(defun mm-inline-override-p (handle) + "Say whether HANDLE should have inline behavior overridden." + (let ((types mm-inline-override-types) + (type (mm-handle-media-type handle)) + ty) + (catch 'found + (while (setq ty (pop types)) + (when (string-match ty type) + (throw 'found t)))))) + (defun mm-automatic-external-display-p (type) "Return the user-defined method for TYPE." (let ((methods mm-automatic-external-display) @@ -495,13 +626,12 @@ external if displayed external." "Insert the contents of HANDLE in the current buffer." (let ((cur (current-buffer))) (save-excursion - (if (member (car (split-string (car (mm-handle-type handle)) "/")) - '("text" "message")) + (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) - (car (mm-handle-type handle))) + (mm-handle-media-type handle)) (let ((temp (current-buffer))) (set-buffer cur) (insert-buffer-substring temp))) @@ -509,7 +639,7 @@ external if displayed external." (insert-buffer-substring (mm-handle-buffer handle)) (mm-decode-content-transfer-encoding (mm-handle-encoding handle) - (car (mm-handle-type handle))) + (mm-handle-media-type handle)) (let ((temp (current-buffer))) (set-buffer cur) (insert-buffer-substring temp))))))) @@ -538,22 +668,13 @@ external if displayed external." (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" (car (split-string - (car (mm-handle-type handle)) "/"))) - buffer-file-coding-system - 'binary)) + (let ((coding-system-for-write '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. + ;; ange-ftp, which is reasonable to use here. (inhibit-file-name-operation 'write-region) (inhibit-file-name-handlers - (if (equal (car (mm-handle-type handle)) - "application/octet-stream") - (cons 'jka-compr-handler inhibit-file-name-handlers) - inhibit-file-name-handlers))) + (cons 'jka-compr-handler inhibit-file-name-handlers))) (write-region (point-min) (point-max) file)))) (defun mm-pipe-part (handle) @@ -567,11 +688,13 @@ external if displayed external." (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))) (method (completing-read "Viewer: " methods))) + (when (string= method "") + (error "No method given")) (mm-display-external (copy-sequence handle) method))) (defun mm-preferred-alternative (handles &optional preferred) @@ -582,18 +705,15 @@ external if displayed external." (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 (car h)) - (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))) @@ -602,7 +722,8 @@ external if displayed external." (defun mm-preferred-alternative-precedence (handles) "Return the precedence based on HANDLES and mm-discouraged-alternatives." (let ((seq (nreverse (mapcar (lambda (h) - (car (mm-handle-type h))) handles)))) + (mm-handle-media-type h)) + handles)))) (dolist (disc (reverse mm-discouraged-alternatives)) (dolist (elem (copy-sequence seq)) (when (string-match disc elem) @@ -613,9 +734,39 @@ external if displayed external." "Return the handle(s) referred to by ID." (cdr (assoc id mm-content-id-alist))) -(defun mm-get-image (handle) +(defun mm-get-image-emacs (handle) + "Return an image instance based on HANDLE." + (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. + (error "Don't know what to do for XBMs right now.")) + (t + (list 'image :type (intern type) :data (buffer-string)))))) + (mm-handle-set-cache handle spec)))))) + +(defun mm-get-image-xemacs (handle) "Return an image instance based on HANDLE." - (let ((type (cadr (split-string (car (mm-handle-type handle)) "/"))) + (let ((type (mm-handle-media-subtype handle)) spec) ;; Allow some common translations. (setq type @@ -652,17 +803,37 @@ external if displayed external." (vector (intern type) :data (buffer-string))))))) (mm-handle-set-cache handle spec)))))) +(defun mm-get-image (handle) + (if mm-xemacs-p + (mm-get-image-xemacs handle) + (mm-get-image-emacs handle))) + (defun mm-image-fit-p (handle) "Say whether the image in HANDLE will fit the current window." (let ((image (mm-get-image handle))) - (or mm-inline-large-images - (and (< (glyph-width image) (window-pixel-width)) - (< (glyph-height image) (window-pixel-height)))))) + (if (fboundp 'glyph-width) + ;; XEmacs' glyphs can actually tell us about their width, so + ;; lets be nice and smart about them. + (or mm-inline-large-images + (and (< (glyph-width image) (window-pixel-width)) + (< (glyph-height image) (window-pixel-height)))) + ;; Let's just inline everything under Emacs 21, since the image + ;; specification there doesn't actually get the width/height + ;; until you render the image. + t))) (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))) + (cond + ;; Handle XEmacs + ((fboundp 'valid-image-instantiator-format-p) + (valid-image-instantiator-format-p format)) + ;; Handle Emacs 21 + ((fboundp 'image-type-available-p) + (image-type-available-p format)) + ;; Nobody else can do images yet. + (t + nil))) (defun mm-valid-and-fit-image-p (format handle) "Say whether FORMAT can be displayed natively and HANDLE fits the window."