X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmm-decode.el;h=4a9007a06ecd4d77b4d00de76f54c9233aaabd85;hp=3b3695b4ca3e9e4cceb69f3f39408746a01e835d;hb=0a63db68d21591915aa899eabbadb2320edbdb65;hpb=f6c143aaed9dabcab84ea1aebbad8498dc6a3630;ds=sidebyside diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index 3b3695b4c..4a9007a06 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -1,6 +1,6 @@ ;;; mm-decode.el --- Functions for decoding MIME things -;; Copyright (C) 1998-2012 Free Software Foundation, Inc. +;; Copyright (C) 1998-2013 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -29,9 +29,7 @@ (require 'mail-parse) (require 'mm-bodies) -(require 'mm-archive) -(eval-when-compile (require 'cl) - (require 'term)) +(eval-when-compile (require 'cl)) (autoload 'gnus-map-function "gnus-util") (autoload 'gnus-replace-in-string "gnus-util") @@ -42,9 +40,14 @@ (autoload 'mm-extern-cache-contents "mm-extern") (autoload 'mm-insert-inline "mm-view") +(autoload 'mm-archive-decoders "mm-archive") +(autoload 'mm-archive-dissect-and-inline "mm-archive") +(autoload 'mm-dissect-archive "mm-archive") + (defvar gnus-current-window-configuration) (add-hook 'gnus-exit-gnus-hook 'mm-destroy-postponed-undisplay-list) +(add-hook 'gnus-exit-gnus-hook 'mm-temp-files-delete) (defgroup mime-display () "Display of MIME in mail and news articles." @@ -61,6 +64,18 @@ :group 'news :group 'multimedia) +(defface mm-command-output + '((((class color) + (background dark)) + (:foreground "ForestGreen")) + (((class color) + (background light)) + (:foreground "red3")) + (t + (:italic t))) + "Face used for displaying output from commands." + :group 'mime-display) + ;;; Convenience macros. (defmacro mm-handle-buffer (handle) @@ -249,6 +264,8 @@ before the external MIME handler is invoked." ("message/partial" mm-inline-partial identity) ("message/external-body" mm-inline-external-body identity) ("text/.*" mm-inline-text identity) + ("application/x-.?tar\\(-.*\\)?" mm-archive-dissect-and-inline identity) + ("application/zip" mm-archive-dissect-and-inline identity) ("audio/wav" mm-inline-audio (lambda (handle) (and (or (featurep 'nas-sound) (featurep 'native-sound)) @@ -276,7 +293,8 @@ before the external MIME handler is invoked." (ignore-errors (if (fboundp 'create-image) (create-image (buffer-string) 'imagemagick 'data-p) - (mm-create-image-xemacs (mm-handle-media-subtype handle)))))) + (mm-create-image-xemacs + (mm-handle-media-subtype handle)))))) (when image (setcar (cdr handle) (list "image/imagemagick")) (mm-image-fit-p handle))))))) @@ -298,6 +316,9 @@ before the external MIME handler is invoked." "application/pgp-signature" "application/x-pkcs7-signature" "application/pkcs7-signature" "application/x-pkcs7-mime" "application/pkcs7-mime" + "application/x-gtar-compressed" + "application/x-tar" + "application/zip" ;; Mutt still uses this even though it has already been withdrawn. "application/pgp") "List of media types that are to be displayed inline. @@ -449,6 +470,12 @@ If not set, `default-directory' will be used." (defvar mm-last-shell-command "") (defvar mm-content-id-alist nil) (defvar mm-postponed-undisplay-list nil) +(defvar mm-inhibit-auto-detect-attachment nil) +(defvar mm-temp-files-to-be-deleted nil + "List of temporary files scheduled to be deleted.") +(defvar mm-temp-files-cache-file (concat ".mm-temp-files-" (user-login-name)) + "Name of a file that caches a list of temporary files to be deleted. +The file will be saved in the directory `mm-tmp-directory'.") ;; According to RFC2046, in particular, in a digest, the default ;; Content-Type value for a body part is changed from "text/plain" to @@ -565,10 +592,52 @@ Postpone undisplaying of viewers for types in (message "Destroying external MIME viewers") (mm-destroy-parts mm-postponed-undisplay-list))) +(defun mm-temp-files-delete () + "Delete temporary files and those parent directories. +Note that the deletion may fail if a program is catching hold of a file +under Windows or Cygwin. In that case, it schedules the deletion of +files left at the next time." + (let* ((coding-system-for-read mm-universal-coding-system) + (coding-system-for-write mm-universal-coding-system) + (cache-file (expand-file-name mm-temp-files-cache-file + mm-tmp-directory)) + (cache (when (file-exists-p cache-file) + (mm-with-multibyte-buffer + (insert-file-contents cache-file) + (split-string (buffer-string) "\n" t)))) + fails) + (dolist (temp (append cache mm-temp-files-to-be-deleted)) + (when (and (file-exists-p temp) + (if (file-directory-p temp) + ;; A parent directory left at the previous time. + (progn + (ignore-errors (delete-directory temp)) + (file-exists-p temp)) + ;; Delete a temporary file and its parent directory. + (ignore-errors (delete-file temp)) + (or (file-exists-p temp) + (progn + (setq temp (file-name-directory temp)) + (ignore-errors (delete-directory temp)) + (file-exists-p temp))))) + (push temp fails))) + (if fails + ;; Schedule the deletion of the files left at the next time. + (progn + (write-region (concat (mapconcat 'identity (nreverse fails) "\n") + "\n") + nil cache-file nil 'silent) + (set-file-modes cache-file #o600)) + (when (file-exists-p cache-file) + (ignore-errors (delete-file cache-file)))) + (setq mm-temp-files-to-be-deleted nil))) + (autoload 'message-fetch-field "message") (defun mm-dissect-buffer (&optional no-strict-mime loose-mime from) - "Dissect the current buffer and return a list of MIME handles." + "Dissect the current buffer and return a list of MIME handles. +If NO-STRICT-MIME, don't require the message to have a +MIME-Version header before proceeding." (save-excursion (let (ct ctl type subtype cte cd description id result) (save-restriction @@ -603,12 +672,39 @@ Postpone undisplaying of viewers for types in description))))) (if (or (not ctl) (not (string-match "/" (car ctl)))) - (mm-dissect-singlepart - (list mm-dissect-default-type) - (and cte (intern (downcase (mail-header-strip cte)))) - no-strict-mime - (and cd (mail-header-parse-content-disposition cd)) - description) + (let ((cdl (and cd (mail-header-parse-content-disposition cd)))) + (mm-dissect-singlepart + ;; Guess Content-Type from the file name extention. + ;; Some mailer sends a part without type like this: + ;; Content-Type: ; name="IMG_3156.JPG" + ;; Content-Disposition: attachment; filename="IMG_3156.JPG" + (list (or + (let ((tem + (or (mail-content-type-get cdl 'filename) + (and ct + (with-temp-buffer + (insert ct) + (goto-char (point-min)) + (and (re-search-forward "\ +;[\t\n ]*name=\\([\"']\\|\\([^\t\n\r ]+\\)\\)" nil t) + (or (match-string 2) + (progn + (goto-char (match-beginning 1)) + (condition-case nil + (progn + (forward-sexp 1) + (buffer-substring + (1+ (match-beginning 1)) + (1- (point)))) + (error nil)))))))))) + (and tem + (setq tem (file-name-extension tem)) + (require 'mailcap) + (cdr (assoc (concat "." (downcase tem)) + mailcap-mime-extensions)))) + mm-dissect-default-type)) + (and cte (intern (downcase (mail-header-strip cte)))) + no-strict-mime cdl description)) (setq type (split-string (car ctl) "/")) (setq subtype (cadr type) type (car type)) @@ -654,12 +750,24 @@ Postpone undisplaying of viewers for types in (if (equal "text/plain" (car ctl)) (assoc 'format ctl) t)) + ;; Guess what the type of application/octet-stream parts should + ;; really be. + (let ((filename (cdr (assq 'filename (cdr cdl))))) + (when (and (not mm-inhibit-auto-detect-attachment) + (equal (car ctl) "application/octet-stream") + filename + (string-match "\\.\\([^.]+\\)$" filename)) + (let ((new-type (mailcap-extension-to-mime (match-string 1 filename)))) + (when new-type + (setcar ctl new-type))))) (let ((handle (mm-make-handle (mm-copy-to-buffer) ctl cte nil cdl description nil id)) - (decoder (assoc (car ctl) mm-archive-decoders))) + (decoder (assoc (car ctl) (mm-archive-decoders)))) (if (and decoder - (executable-find (cadr decoder))) + ;; Do automatic decoding + (cadr decoder) + (executable-find (caddr decoder))) (mm-dissect-archive handle) handle)))) @@ -672,7 +780,9 @@ Postpone undisplaying of viewers for types in (goto-char (point-max)) (if (re-search-backward close-delimiter nil t) (match-beginning 0) - (point-max))))) + (point-max)))) + (mm-inhibit-auto-detect-attachment + (equal (car ctl) "multipart/encrypted"))) (setq boundary (concat (regexp-quote boundary) "[ \t]*$")) (while (and (< (point) end) (re-search-forward boundary end t)) (goto-char (match-beginning 0)) @@ -743,23 +853,29 @@ external if displayed external." (mail-content-type-get (mm-handle-type handle) 'name) "")) - (external mm-enable-external)) - (if (and (mm-inlinable-p ehandle) - (mm-inlined-p ehandle)) - (progn - (forward-line 1) - (mm-display-inline handle) - 'inline) - (when (or method - (not no-default)) - (if (and (not method) - (equal "text" (car (split-string type "/")))) - (progn - (forward-line 1) - (mm-insert-inline handle (mm-get-part handle)) - 'inline) - (setq external - (and method ;; If nil, we always use "save". + (external mm-enable-external) + (decoder (assoc (car (mm-handle-type handle)) + (mm-archive-decoders)))) + (cond + ((and decoder + (executable-find (caddr decoder))) + (mm-archive-dissect-and-inline handle) + 'inline) + ((and (mm-inlinable-p ehandle) + (mm-inlined-p ehandle)) + (forward-line 1) + (mm-display-inline handle) + 'inline) + ((or method + (not no-default)) + (if (and (not method) + (equal "text" (car (split-string type "/")))) + (progn + (forward-line 1) + (mm-insert-inline handle (mm-get-part handle)) + 'inline) + (setq external + (and method ;; If nil, we always use "save". (stringp method) ;; 'mailcap-save-binary-file (or (eq mm-enable-external t) (and (eq mm-enable-external 'ask) @@ -772,15 +888,17 @@ external if displayed external." (concat " \"" (format method filename) "\"") "") - "? ")))))) - (if external - (mm-display-external - handle (or method 'mailcap-save-binary-file)) + "? ")))))) + (if external (mm-display-external - handle 'mailcap-save-binary-file))))))))) + handle (or method 'mailcap-save-binary-file)) + (mm-display-external + handle 'mailcap-save-binary-file))))))))) (declare-function gnus-configure-windows "gnus-win" (setting &optional force)) (defvar mailcap-mime-extensions) ; mailcap-mime-info autoloads +(declare-function term-mode "term" ()) +(declare-function term-char-mode "term" ()) (defun mm-display-external (handle method) "Display HANDLE using METHOD." @@ -863,10 +981,20 @@ external if displayed external." method file (mm-handle-type handle)))) (unwind-protect (if window-system - (start-process "*display*" nil - mm-external-terminal-program - "-e" shell-file-name - shell-command-switch command) + (set-process-sentinel + (start-process "*display*" nil + mm-external-terminal-program + "-e" shell-file-name + shell-command-switch command) + `(lambda (process state) + (if (eq 'exit (process-status process)) + (run-at-time + 60.0 nil + (lambda () + (ignore-errors (delete-file ,file)) + (ignore-errors (delete-directory + ,(file-name-directory + file)))))))) (require 'term) (require 'gnus-win) (set-buffer @@ -880,11 +1008,15 @@ external if displayed external." (set-process-sentinel (get-buffer-process buffer) `(lambda (process state) - (if (eq 'exit (process-status process)) - (gnus-configure-windows - ',gnus-current-window-configuration)))) + (when (eq 'exit (process-status process)) + (ignore-errors (delete-file ,file)) + (ignore-errors + (delete-directory ,(file-name-directory file))) + (gnus-configure-windows + ',gnus-current-window-configuration)))) (gnus-configure-windows 'display-term)) - (mm-handle-set-external-undisplayer handle (cons file buffer))) + (mm-handle-set-external-undisplayer handle (cons file buffer)) + (add-to-list 'mm-temp-files-to-be-deleted file t)) (message "Displaying %s..." command)) 'external) (copiousoutput @@ -917,7 +1049,7 @@ external if displayed external." (let ((command (mm-mailcap-command method file (mm-handle-type handle)))) (unwind-protect - (progn + (let ((process-connection-type nil)) (start-process "*display*" (setq buffer (generate-new-buffer " *mm*")) @@ -925,48 +1057,37 @@ external if displayed external." shell-command-switch command) (set-process-sentinel (get-buffer-process buffer) - (lexical-let ;; Don't use `let'. - ;; Function used to remove temp file and directory. - ((fn `(lambda nil - ;; Don't use `ignore-errors'. - (condition-case nil - (delete-file ,file) - (error)) - (condition-case nil - (delete-directory - ,(file-name-directory file)) - (error)))) - ;; Form uses to kill the process buffer and - ;; remove the undisplayer. - (fm `(progn - (kill-buffer ,buffer) - ,(macroexpand - (list 'mm-handle-set-undisplayer - (list 'quote handle) - nil)))) - ;; Message to be issued when the process exits. - (done (format "Displaying %s...done" command)) - ;; In particular, the timer object (which is - ;; a vector in Emacs but is a list in XEmacs) - ;; requires that it is lexically scoped. - (timer (run-at-time 30.0 nil 'ignore))) - (if (featurep 'xemacs) - (lambda (process state) - (when (eq 'exit (process-status process)) - (if (memq timer itimer-list) - (set-itimer-function timer fn) - (funcall fn)) - (ignore-errors (eval fm)) - (message "%s" done))) - (lambda (process state) - (when (eq 'exit (process-status process)) - (if (memq timer timer-list) - (timer-set-function timer fn) - (funcall fn)) - (ignore-errors (eval fm)) - (message "%s" done))))))) + (lexical-let ((outbuf outbuf) + (file file) + (buffer buffer) + (command command) + (handle handle)) + (lambda (process state) + (when (eq (process-status process) 'exit) + (run-at-time + 60.0 nil + (lambda () + (ignore-errors (delete-file file)) + (ignore-errors (delete-directory + (file-name-directory file))))) + (when (buffer-live-p outbuf) + (with-current-buffer outbuf + (let ((buffer-read-only nil) + (point (point))) + (forward-line 2) + (let ((start (point))) + (mm-insert-inline + handle (with-current-buffer buffer + (buffer-string))) + (put-text-property start (point) + 'face 'mm-command-output)) + (goto-char point)))) + (when (buffer-live-p buffer) + (kill-buffer buffer))) + (message "Displaying %s...done" command))))) (mm-handle-set-external-undisplayer - handle (cons file buffer))) + handle (cons file buffer)) + (add-to-list 'mm-temp-files-to-be-deleted file t)) (message "Displaying %s..." command)) 'external))))))) @@ -1274,14 +1395,26 @@ PROMPT overrides the default one used to ask user for a file name." (when filename (setq filename (gnus-map-function mm-file-name-rewrite-functions (file-name-nondirectory filename)))) - (setq file - (read-file-name - (or prompt - (format "Save MIME part to (default %s): " - (or filename ""))) - (or mm-default-directory default-directory) - (expand-file-name (or filename "") - (or mm-default-directory default-directory)))) + (while + (progn + (setq file + (read-file-name + (or prompt + (format "Save MIME part to (default %s): " + (or filename ""))) + (or mm-default-directory default-directory) + (expand-file-name (or filename "") + (or mm-default-directory default-directory)))) + (cond ((or (not file) (equal file "")) + (message "Please enter a file name") + t) + ((and (file-directory-p file) + (not filename)) + (message "Please enter a non-directory file name") + t) + (t nil))) + (sit-for 2) + (discard-input)) (if (file-directory-p file) (setq file (expand-file-name filename file)) (setq file (expand-file-name @@ -1309,7 +1442,7 @@ Return t if meta tag is added or replaced." (goto-char (point-min)) (if (re-search-forward "\ ]*>" nil t) +text/\\(\\sw+\\)\\(?:\;\\s-*charset=\\([^\"'>]+\\)\\)?[^>]*>" nil t) (if (and (not force-charset) (match-beginning 2) (string-match "\\`html\\'" (match-string 1))) @@ -1500,7 +1633,7 @@ be determined." (let ((image (mm-get-image handle))) (or (not image) (if (featurep 'xemacs) - ;; XEmacs' glyphs can actually tell us about their width, so + ;; XEmacs's glyphs can actually tell us about their width, so ;; let's be nice and smart about them. (or mm-inline-large-images (and (<= (glyph-width image) (window-pixel-width)) @@ -1748,7 +1881,8 @@ If RECURSIVE, search recursively." (insert (prog1 (if (and charset (setq charset - (mm-charset-to-coding-system charset)) + (mm-charset-to-coding-system charset + nil t)) (not (eq charset 'ascii))) (mm-decode-coding-string (buffer-string) charset) (mm-string-as-multibyte (buffer-string))) @@ -1764,9 +1898,14 @@ If RECURSIVE, search recursively." (string-to-number (match-string 2))) mm-extra-numeric-entities))) (replace-match (char-to-string char)))) + ;; Remove "soft hyphens". + (goto-char (point-min)) + (while (search-forward "­" nil t) + (replace-match "" t t)) (libxml-parse-html-region (point-min) (point-max)))) (unless (bobp) (insert "\n")) + (mm-convert-shr-links) (mm-handle-set-undisplayer handle `(lambda () @@ -1774,6 +1913,25 @@ If RECURSIVE, search recursively." (delete-region ,(point-min-marker) ,(point-max-marker)))))))) +(defvar shr-map) + +(autoload 'widget-convert-button "wid-edit") + +(defun mm-convert-shr-links () + (let ((start (point-min)) + end) + (while (and start + (< start (point-max))) + (when (setq start (text-property-not-all start (point-max) 'shr-url nil)) + (setq end (next-single-property-change start 'shr-url nil (point-max))) + (widget-convert-button + 'url-link start end + :help-echo (get-text-property start 'help-echo) + :keymap shr-map + (get-text-property start 'shr-url)) + (put-text-property start end 'local-map nil) + (setq start end))))) + (defun mm-handle-filename (handle) "Return filename of HANDLE if any." (or (mail-content-type-get (mm-handle-type handle) @@ -1783,4 +1941,8 @@ If RECURSIVE, search recursively." (provide 'mm-decode) +;; Local Variables: +;; coding: utf-8 +;; End: + ;;; mm-decode.el ends here