X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmm-decode.el;h=1cfcd1c79014fc759d4b477c5de9a0f165843cd2;hb=bd5c2da9b674dbe4d52c456ce996481be2e8e687;hp=0538fb5787e3aabed662d6edb4938e91a4096bb0;hpb=90b0036db876985a484966d646b71cc412f3dba6;p=gnus diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index 0538fb578..1cfcd1c79 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 @@ -27,6 +27,18 @@ (require 'mail-parse) (require 'mailcap) (require 'mm-bodies) +(eval-when-compile (require 'cl)) + +(eval-and-compile + (autoload 'mm-inline-partial "mm-partial") + (autoload 'mm-inline-external-body "mm-extern")) + +(defgroup mime-display () + "Display of MIME in mail and news articles." + :link '(custom-manual "(emacs-mime)Customization") + :group 'mail + :group 'news + :group 'multimedia) ;;; Convenience macros. @@ -34,6 +46,14 @@ `(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,63 +76,127 @@ `(list ,buffer ,type ,encoding ,undisplayer ,disposition ,description ,cache ,id)) -(defvar mm-inline-media-tests - '(("image/jpeg" mm-inline-image (mm-valid-and-fit-image-p 'jpeg handle)) - ("image/png" mm-inline-image (mm-valid-and-fit-image-p 'png handle)) - ("image/gif" mm-inline-image (mm-valid-and-fit-image-p 'gif handle)) - ("image/tiff" mm-inline-image (mm-valid-and-fit-image-p 'tiff handle)) - ("image/xbm" mm-inline-image (mm-valid-and-fit-image-p 'xbm handle)) - ("image/x-xbitmap" mm-inline-image (mm-valid-and-fit-image-p 'xbm handle)) - ("image/xpm" mm-inline-image (mm-valid-and-fit-image-p 'xpm handle)) - ("image/x-pixmap" mm-inline-image (mm-valid-and-fit-image-p 'xpm handle)) - ("image/bmp" mm-inline-image (mm-valid-and-fit-image-p 'bmp handle)) - ("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")) - ("text/x-vcard" mm-inline-text (locate-library "vcard")) - ("message/delivery-status" mm-inline-text t) - ("message/rfc822" mm-inline-message t) - ("text/.*" mm-inline-text t) +(defcustom mm-inline-media-tests + '(("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/x-patch" mm-display-patch-inline + (lambda (handle) + (locate-library "diff-mode"))) + ("application/emacs-lisp" mm-display-elisp-inline identity) + ("text/html" + mm-inline-text + (lambda (handle) + (locate-library "w3"))) + ("text/x-vcard" + mm-inline-text + (lambda (handle) + (or (featurep 'vcard) + (locate-library "vcard")))) + ("message/delivery-status" mm-inline-text identity) + ("message/rfc822" mm-inline-message identity) + ("message/partial" mm-inline-partial identity) + ("message/external-body" mm-inline-external-body 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))) - ("multipart/alternative" ignore t) - ("multipart/mixed" ignore t) - ("multipart/related" ignore t)) - "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) - ("message/rfc822" . inline))) - -(defvar mm-user-automatic-display + (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)))) + ("application/pgp-signature" ignore identity) + ("multipart/alternative" ignore identity) + ("multipart/mixed" ignore identity) + ("multipart/related" ignore identity)) + "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" + "message/partial" "message/external-body" "application/emacs-lisp" + "application/pgp-signature") + "List of media types that are to be displayed inline." + :type '(repeat string) + :group 'mime-display) + +(defcustom mm-automatic-display '("text/plain" "text/enriched" "text/richtext" "text/html" "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*" - "message/rfc822")) - -(defvar mm-attachment-override-types - '("text/plain" "text/x-vcard") - "Types that should have \"attachment\" ignored if they can be displayed inline.") - -(defvar mm-user-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 multiapart/alternative. + "message/rfc822" "text/x-patch" "application/pgp-signature" + "application/emacs-lisp") + "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 types instead, and this list says what types are most unwanted. If, -for instance, text/html parts are very unwanted, and text/richtech are +for instance, text/html parts are very unwanted, and text/richtext 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)) @@ -120,8 +204,10 @@ to: ("/tmp/")) "Where mm will store its temporary files.") -(defvar mm-all-images-fit 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. @@ -129,6 +215,50 @@ to: (defvar mm-last-shell-command "") (defvar mm-content-id-alist nil) +;; According to RFC2046, in particular, in a digest, the default +;; Content-Type value for a body part is changed from "text/plain" to +;; "message/rfc822". +(defvar mm-dissect-default-type "text/plain") + +(autoload 'mml2015-verify "mml2015") + +(defvar mm-verify-function-alist + '(("application/pgp-signature" . mml2015-verify))) + +(defcustom mm-verify-option nil + "Option of verifying signed parts. +`never', not verify; `always', always verify; +`known', only verify known protocols. Otherwise, ask user." + :type '(choice (item always) + (item never) + (item :tag "only known protocols" known) + (item :tag "ask" nil)) + :group 'gnus-article) + +(autoload 'mml2015-decrypt "mml2015") + +(defvar mm-decrypt-function-alist + '(("application/pgp-encrypted" . mml2015-decrypt))) + +(defcustom mm-decrypt-option nil + "Option of decrypting signed parts. +`never', not decrypt; `always', always decrypt; +`known', only decrypt known protocols. Otherwise, ask user." + :type '(choice (item always) + (item never) + (item :tag "only known protocols" known) + (item :tag "ask" nil)) + :group 'gnus-article) + +(defvar mm-viewer-completion-map + (let ((map (make-sparse-keymap 'mm-viewer-completion-map))) + (set-keymap-parent map minibuffer-local-completion-map) + map) + "Keymap for input viewer with completion.") + +;; Should we bind other key to minibuffer-complete-word? +(define-key mm-viewer-completion-map " " 'self-insert-command) + ;;; The functions. (defun mm-dissect-buffer (&optional no-strict-mime) @@ -145,10 +275,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 + (list mm-dissect-default-type) + (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) "/")) @@ -158,7 +294,10 @@ to: result (cond ((equal type "multipart") - (cons (car ctl) (mm-dissect-multipart ctl))) + (let ((mm-dissect-default-type (if (equal subtype "digest") + "message/rfc822" + "text/plain"))) + (cons (car ctl) (mm-dissect-multipart ctl)))) (t (mm-dissect-singlepart ctl @@ -176,7 +315,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) @@ -191,14 +332,15 @@ 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))))) - (while (search-forward boundary end t) + (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))))) + (setq boundary (concat (regexp-quote boundary) "[ \t]*$")) + (while (re-search-forward boundary end t) (goto-char (match-beginning 0)) (when start (save-excursion @@ -212,7 +354,7 @@ to: (save-restriction (narrow-to-region start end) (setq parts (nconc (list (mm-dissect-buffer t)) parts))))) - (nreverse parts))) + (mm-possibly-verify-or-decrypt (nreverse parts) ctl))) (defun mm-copy-to-buffer () "Copy the contents of the current buffer to a fresh buffer." @@ -226,10 +368,6 @@ to: (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; @@ -238,94 +376,153 @@ external if displayed external." (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) 'inline) - (when (or user-method - method + (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)) - '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) + (goto-char (point-min)) + (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." + "Remove the displayed MIME parts represented by HANDLES." (if (and (listp handles) (bufferp (car handles))) (mm-remove-part handles) @@ -333,6 +530,7 @@ external if displayed external." (while (setq handle (pop handles)) (cond ((stringp handle) + ;; Do nothing. ) ((and (listp handle) (stringp (car handle))) @@ -341,7 +539,7 @@ external if displayed external." (mm-remove-part handle))))))) (defun mm-destroy-parts (handles) - "Remove the displayed MIME parts represented by HANDLE." + "Remove the displayed MIME parts represented by HANDLES." (if (and (listp handles) (bufferp (car handles))) (mm-destroy-part handles) @@ -349,6 +547,7 @@ external if displayed external." (while (setq handle (pop handles)) (cond ((stringp handle) + ;; Do nothing. ) ((and (listp handle) (stringp (car handle))) @@ -380,59 +579,79 @@ 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-inlinable-p (type) - "Say whether TYPE can be displayed inline." +(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 (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 (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 (not (mm-inline-override-p handle)) + (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)) + (when (and (not (mm-inline-override-p handle)) + (string-match method type) + (mm-inlinable-p handle)) (setq result t methods nil))) result)) -(defun mm-attachment-override-p (type) - "Say whether TYPE should have attachment behavior overridden." +(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 type)) + (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-user-automatic-external-display) + (let ((methods mm-automatic-external-display) method result) (while (setq method (pop methods)) (when (string-match method type) @@ -440,11 +659,6 @@ external if displayed external." 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-destroy-part (handle) "Destroy the data structures connected to HANDLE." (when (listp handle) @@ -470,13 +684,12 @@ This overrides entries in the mailcap file." "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)) + (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))) @@ -484,7 +697,7 @@ This overrides entries in the mailcap file." (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))))))) @@ -505,30 +718,23 @@ This overrides entries in the mailcap file." (or filename name "") (or mm-default-directory default-directory)))) (setq mm-default-directory (file-name-directory 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)))) + (and (or (not (file-exists-p file)) + (yes-or-no-p (format "File %s already exists; overwrite? " + file))) + (progn + (mm-save-part-to-file handle file) + 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" (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) @@ -542,11 +748,17 @@ This overrides entries in the mailcap file." (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))) + (method (let ((minibuffer-local-completion-map + mm-viewer-completion-map)) + (completing-read "Viewer: " methods)))) + (when (string= method "") + (error "No method given")) + (if (string-match "^[^% \t]+$" method) + (setq method (concat method " %s"))) (mm-display-external (copy-sequence handle) method))) (defun mm-preferred-alternative (handles &optional preferred) @@ -557,27 +769,24 @@ This overrides entries in the mailcap file." (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) - (car (mm-handle-type h))) handles)))) + "Return the precedence based on HANDLES and `mm-discouraged-alternatives'." + (let ((seq (nreverse (mapcar #'mm-handle-media-type + handles)))) (dolist (disc (reverse mm-discouraged-alternatives)) (dolist (elem (copy-sequence seq)) (when (string-match disc elem) @@ -590,7 +799,7 @@ This overrides entries in the mailcap file." (defun mm-get-image (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 @@ -606,45 +815,159 @@ This overrides entries in the mailcap file." (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))))))) + ;; Avoid testing `make-glyph' since W3 may define + ;; a bogus version of it. + (if (fboundp 'create-image) + (create-image (buffer-string) (intern type) 'data-p) + (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." (let ((image (mm-get-image handle))) - (or mm-all-images-fit - (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* ((size (image-size image)) + (w (car size)) + (h (cdr size))) + (or mm-inline-large-images + (and (< h (1- (window-height))) ; Don't include mode line. + (< w (window-width)))))))) (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) + (and (display-graphic-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." - (and window-system - (mm-valid-image-format-p format) + (and (mm-valid-image-format-p format) (mm-image-fit-p handle))) +(defun mm-find-part-by-type (handles type &optional notp) + (let (handle) + (while handles + (if (if notp + (not (equal (mm-handle-media-type (car handles)) type)) + (equal (mm-handle-media-type (car handles)) type)) + (setq handle (car handles) + handles nil)) + (setq handles (cdr handles))) + handle)) + +(defun mm-find-raw-part-by-type (ctl type &optional notp) + (goto-char (point-min)) + (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary))) + (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$")) + start + (end (save-excursion + (goto-char (point-max)) + (if (re-search-backward close-delimiter nil t) + (match-beginning 0) + (point-max)))) + result) + (setq boundary (concat (regexp-quote boundary) "[ \t]*$")) + (while (and (not result) + (re-search-forward boundary end t)) + (goto-char (match-beginning 0)) + (when start + (save-excursion + (save-restriction + (narrow-to-region start (point)) + (when (let ((ctl (ignore-errors + (mail-header-parse-content-type + (mail-fetch-field "content-type"))))) + (if notp + (not (equal (car ctl) type)) + (equal (car ctl) type))) + (setq result (buffer-substring (point-min) (point-max))))))) + (forward-line 2) + (setq start (point))) + (when (and (not result) start) + (save-excursion + (save-restriction + (narrow-to-region start end) + (when (let ((ctl (ignore-errors + (mail-header-parse-content-type + (mail-fetch-field "content-type"))))) + (if notp + (not (equal (car ctl) type)) + (equal (car ctl) type))) + (setq result (buffer-substring (point-min) (point-max))))))) + result)) + +(defun mm-possibly-verify-or-decrypt (parts ctl) + (let ((subtype (cadr (split-string (car ctl) "/"))) + protocol func) + (cond + ((equal subtype "signed") + (setq protocol (mail-content-type-get ctl 'protocol)) + (setq func (cdr (assoc protocol mm-verify-function-alist))) + (if (cond + ((eq mm-verify-option 'never) nil) + ((eq mm-verify-option 'always) t) + ((eq mm-verify-option 'known) func) + (t (y-or-n-p + (format "Verify signed part(protocol=%s)?" protocol)))) + (condition-case err + (save-excursion + (if func + (funcall func parts ctl) + (error (format "Unknown sign protocol(%s)" protocol)))) + (error + (unless (y-or-n-p (format "%s, continue?" err)) + (error "Verify failure.")))))) + ((equal subtype "encrypted") + (setq protocol (mail-content-type-get ctl 'protocol)) + (setq func (cdr (assoc protocol mm-decrypt-function-alist))) + (if (cond + ((eq mm-decrypt-option 'never) nil) + ((eq mm-decrypt-option 'always) t) + ((eq mm-decrypt-option 'known) func) + (t (y-or-n-p + (format "Decrypt part (protocol=%s)?" protocol)))) + (condition-case err + (save-excursion + (if func + (setq parts (funcall func parts ctl)) + (error (format "Unknown encrypt protocol(%s)" protocol)))) + (error + (unless (y-or-n-p (format "%s, continue?" err)) + (error "Decrypt failure.")))))) + (t nil)) + parts)) + (provide 'mm-decode) -;; mm-decode.el ends here +;;; mm-decode.el ends here