X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmm-decode.el;h=3fdcdba45c0ee47cf1474eaaf4f7590f8852c948;hp=b5e4d3e38e8d09fb10d37b79debe2a719dcda2fd;hb=cae9659706ab3769973b310e7c93f972337e6b8a;hpb=8f7476d4cfadb358d635238ae62c48a89efc6db2 diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index b5e4d3e38..3fdcdba45 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-2013 Free Software Foundation, Inc. +;; Copyright (C) 1998-2015 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -23,19 +23,17 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (require 'mail-parse) (require 'mm-bodies) -(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") (autoload 'gnus-read-shell-command "gnus-util") +(autoload 'gnus-overlays-at "gnus") +(autoload 'gnus-overlay-put "gnus") + (autoload 'mm-inline-partial "mm-partial") (autoload 'mm-inline-external-body "mm-extern") (autoload 'mm-extern-cache-contents "mm-extern") @@ -48,6 +46,7 @@ (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." @@ -64,6 +63,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) @@ -112,7 +123,6 @@ ((executable-find "w3m") 'gnus-w3m) ((executable-find "links") 'links) ((executable-find "lynx") 'lynx) - ((locate-library "w3") 'w3) ((locate-library "html2text") 'html2text) (t nil)) "Render of HTML contents. @@ -124,13 +134,11 @@ The defined renderer types are: `w3m-standalone': use plain w3m; `links': use links; `lynx': use lynx; -`w3': use Emacs/W3; `html2text': use html2text; nil : use external viewer (default web browser)." :version "24.1" :type '(choice (const shr) (const gnus-w3m) - (const w3) (const w3m :tag "emacs-w3m") (const w3m-standalone :tag "standalone w3m" ) (const links) @@ -141,9 +149,9 @@ nil : use external viewer (default web browser)." :group 'mime-display) (defcustom mm-inline-text-html-with-images nil - "If non-nil, Gnus will allow retrieving images in HTML contents with -the tags. It has no effect on Emacs/w3. See also the -documentation for the `mm-w3m-safe-url-regexp' variable." + "If non-nil, Gnus will allow retrieving images in HTML that has tags. +See also the documentation for the `mm-w3m-safe-url-regexp' +variable." :version "22.1" :type 'boolean :group 'mime-display) @@ -459,6 +467,11 @@ If not set, `default-directory' will be used." (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 @@ -521,14 +534,6 @@ result of the verification." map) "Keymap for input viewer with completion.") -(defvar mm-viewer-completion-map - (let ((map (make-sparse-keymap 'mm-viewer-completion-map))) - (set-keymap-parent map minibuffer-local-completion-map) - ;; Should we bind other key to minibuffer-complete-word? - (define-key map " " 'self-insert-command) - map) - "Keymap for input viewer with completion.") - ;;; The functions. (defun mm-alist-to-plist (alist) @@ -575,6 +580,46 @@ 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) @@ -605,7 +650,7 @@ MIME-Version header before proceeding." (unless from (setq from (mail-fetch-field "from"))) ;; FIXME: In some circumstances, this code is running within - ;; an unibyte macro. mail-extract-address-components + ;; a unibyte macro. mail-extract-address-components ;; creates unibyte buffers. This `if', though not a perfect ;; solution, avoids most of them. (if from @@ -615,9 +660,9 @@ MIME-Version header before proceeding." description))))) (if (or (not ctl) (not (string-match "/" (car ctl)))) - (mm-dissect-singlepart + (mm-dissect-singlepart (list mm-dissect-default-type) - (and cte (intern (downcase (mail-header-strip cte)))) + (and cte (intern (downcase (mail-header-strip cte)))) no-strict-mime (and cd (mail-header-parse-content-disposition cd)) description) @@ -779,7 +824,6 @@ external if displayed external." 'inline) ((and (mm-inlinable-p ehandle) (mm-inlined-p ehandle)) - (forward-line 1) (mm-display-inline handle) 'inline) ((or method @@ -792,18 +836,18 @@ external if displayed external." '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) (y-or-n-p (concat "Display part (" type - ") using external program" - ;; Can non-string method ever happen? + ") " (if (stringp method) (concat - " \"" (format method filename) "\"") - "") + "using external program \"" + (format method filename) "\"") + (format + "by calling `%s' on the contents)" method)) "? ")))))) (if external (mm-display-external @@ -813,6 +857,8 @@ external if displayed external." (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." @@ -842,7 +888,15 @@ external if displayed external." (mm-handle-media-type handle) t)))) (unwind-protect (if method - (funcall method) + (progn + (when (and (boundp 'gnus-summary-buffer) + (bufferp gnus-summary-buffer) + (buffer-name gnus-summary-buffer)) + ;; So that we pop back to the right place, sort of. + (switch-to-buffer gnus-summary-buffer) + (switch-to-buffer mm)) + (delete-other-windows) + (funcall method)) (mm-save-part handle)) (when (and (not non-viewer) method) @@ -895,10 +949,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 @@ -912,11 +976,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 @@ -949,7 +1017,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*")) @@ -962,35 +1030,32 @@ external if displayed external." (buffer buffer) (command command) (handle handle)) - (run-at-time - 30.0 nil - (lambda () - (ignore-errors - (delete-file file)) - (ignore-errors - (delete-directory (file-name-directory file))))) (lambda (process state) (when (eq (process-status process) 'exit) - (condition-case nil - (delete-file file) - (error)) - (condition-case nil - (delete-directory (file-name-directory file)) - (error)) + (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) - (mm-insert-inline - handle (with-current-buffer buffer - (buffer-string))) + (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))))))) @@ -1298,14 +1363,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 @@ -1333,7 +1410,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))) @@ -1741,6 +1818,7 @@ If RECURSIVE, search recursively." (start end &optional base-url)) (declare-function shr-insert-document "shr" (dom)) (defvar shr-blocked-images) +(defvar shr-use-fonts) (defvar gnus-inhibit-images) (autoload 'gnus-blocked-images "gnus-art") @@ -1748,6 +1826,10 @@ If RECURSIVE, search recursively." ;; Require since we bind its variables. (require 'shr) (let ((article-buffer (current-buffer)) + (shr-width (if (and (boundp 'shr-use-fonts) + shr-use-fonts) + nil + fill-column)) (shr-content-function (lambda (id) (let ((handle (mm-get-content-id id))) (when handle @@ -1791,18 +1873,40 @@ If RECURSIVE, search recursively." (replace-match (char-to-string char)))) ;; Remove "soft hyphens". (goto-char (point-min)) - (while (search-forward "­" nil t) + (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 () (let ((inhibit-read-only t)) - (delete-region ,(point-min-marker) + (delete-region ,(copy-marker (point-min) t) ,(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) + (dolist (overlay (gnus-overlays-at start)) + (gnus-overlay-put overlay 'face nil)) + (setq start end))))) + (defun mm-handle-filename (handle) "Return filename of HANDLE if any." (or (mail-content-type-get (mm-handle-type handle) @@ -1813,7 +1917,7 @@ If RECURSIVE, search recursively." (provide 'mm-decode) ;; Local Variables: -;; coding: iso-8859-1 +;; coding: utf-8 ;; End: ;;; mm-decode.el ends here