X-Git-Url: https://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmm-decode.el;h=725adcf559c8671d476e2889572a88dafebc82d1;hp=ce3010f3d4c1b102dada092d89a75428d0138c28;hb=c9a393eeb329a99695566342a9f03b8a30000898;hpb=620be6ca92cc5032780f2cc4363f822882c672af diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index ce3010f3d..725adcf55 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -1,42 +1,46 @@ ;;; mm-decode.el --- Functions for decoding MIME things ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006 Free Software Foundation, Inc. +;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: ;;; Code: +;; For Emacs < 22.2. +(eval-and-compile + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + (require 'mail-parse) -(require 'mailcap) (require 'mm-bodies) (eval-when-compile (require 'cl) (require 'term)) -(eval-and-compile - (autoload 'mm-inline-partial "mm-partial") - (autoload 'mm-inline-external-body "mm-extern") - (autoload 'mm-extern-cache-contents "mm-extern") - (autoload 'mm-insert-inline "mm-view")) +(autoload 'gnus-map-function "gnus-util") +(autoload 'gnus-replace-in-string "gnus-util") +(autoload 'gnus-read-shell-command "gnus-util") + +(autoload 'mm-inline-partial "mm-partial") +(autoload 'mm-inline-external-body "mm-extern") +(autoload 'mm-extern-cache-contents "mm-extern") +(autoload 'mm-insert-inline "mm-view") (defvar gnus-current-window-configuration) @@ -101,31 +105,32 @@ ,disposition ,description ,cache ,id)) (defcustom mm-text-html-renderer - (cond ((locate-library "w3") 'w3) - ((executable-find "w3m") (if (locate-library "w3m") - 'w3m - 'w3m-standalone)) + (cond ((and (executable-find "w3m") + (executable-find "curl")) + 'gnus-article-html) ((executable-find "links") 'links) ((executable-find "lynx") 'lynx) - (t 'html2text)) + ((locate-library "w3") 'w3) + ((locate-library "html2text") 'html2text) + (t nil)) "Render of HTML contents. It is one of defined renderer types, or a rendering function. The defined renderer types are: -`w3' : use Emacs/W3; `w3m' : use emacs-w3m; `w3m-standalone': use w3m; `links': use links; `lynx' : use lynx; +`w3' : use Emacs/W3; `html2text' : use html2text; -nil : use external viewer." - :version "22.1" +nil : use external viewer (default web browser)." + :version "24.1" :type '(choice (const w3) - (const w3m) - (const w3m-standalone) + (const w3m :tag "emacs-w3m") + (const w3m-standalone :tag "standalone w3m" ) (const links) (const lynx) (const html2text) - (const nil) + (const nil :tag "External viewer") (function)) :group 'mime-display) @@ -228,6 +233,9 @@ before the external MIME handler is invoked." ;; makes it possible to install another package which provides an ;; alternative implementation of diff-mode. --Stef (fboundp 'diff-mode))) + ;; In case mime.types uses x-diff (as does Debian's mime-support-3.40). + ("text/x-diff" mm-display-patch-inline + (lambda (handle) (fboundp 'diff-mode))) ("application/emacs-lisp" mm-display-elisp-inline identity) ("application/x-emacs-lisp" mm-display-elisp-inline identity) ("text/dns" mm-display-dns-inline identity) @@ -364,20 +372,34 @@ enables you to choose manually one of two types those mails include." :type 'boolean :group 'mime-display) -(defvar mm-file-name-rewrite-functions +(defcustom mm-file-name-rewrite-functions '(mm-file-name-delete-control mm-file-name-delete-gotchas) - "*List of functions used for rewriting file names of MIME parts. + "List of functions used for rewriting file names of MIME parts. Each function takes a file name as input and returns a file name. -Ready-made functions include -`mm-file-name-delete-control' -`mm-file-name-delete-gotchas' -`mm-file-name-delete-whitespace', -`mm-file-name-trim-whitespace', -`mm-file-name-collapse-whitespace', -`mm-file-name-replace-whitespace', -`capitalize', `downcase', `upcase', and -`upcase-initials'.") +Ready-made functions include `mm-file-name-delete-control', +`mm-file-name-delete-gotchas' (you should not remove these two +functions), `mm-file-name-delete-whitespace', +`mm-file-name-trim-whitespace', `mm-file-name-collapse-whitespace', +`mm-file-name-replace-whitespace', `capitalize', `downcase', +`upcase', and `upcase-initials'." + :type '(list (set :inline t + (const mm-file-name-delete-control) + (const mm-file-name-delete-gotchas) + (const mm-file-name-delete-whitespace) + (const mm-file-name-trim-whitespace) + (const mm-file-name-collapse-whitespace) + (const mm-file-name-replace-whitespace) + (const capitalize) + (const downcase) + (const upcase) + (const upcase-initials) + (repeat :inline t + :tag "Function" + function))) + :version "23.1" ;; No Gnus + :group 'mime-display) + (defvar mm-path-name-rewrite-functions nil "*List of functions for rewriting the full file names of MIME parts. @@ -529,6 +551,8 @@ Postpone undisplaying of viewers for types in (message "Destroying external MIME viewers") (mm-destroy-parts mm-postponed-undisplay-list))) +(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." (save-excursion @@ -542,7 +566,9 @@ Postpone undisplaying of viewers for types in ctl (and ct (mail-header-parse-content-type ct)) cte (mail-fetch-field "content-transfer-encoding") cd (mail-fetch-field "content-disposition") - description (mail-fetch-field "content-description") + ;; Newlines in description should be stripped so as + ;; not to break the MIME tag into two or more lines. + description (message-fetch-field "content-description") id (mail-fetch-field "content-id")) (unless from (setq from (mail-fetch-field "from"))) @@ -551,7 +577,10 @@ Postpone undisplaying of viewers for types in ;; creates unibyte buffers. This `if', though not a perfect ;; solution, avoids most of them. (if from - (setq from (cadr (mail-extract-address-components from)))))) + (setq from (cadr (mail-extract-address-components from)))) + (if description + (setq description (mail-decode-encoded-word-string + description))))) (if (or (not ctl) (not (string-match "/" (car ctl)))) (mm-dissect-singlepart @@ -639,15 +668,16 @@ Postpone undisplaying of viewers for types in (defun mm-copy-to-buffer () "Copy the contents of the current buffer to a fresh buffer." - (let ((obuf (current-buffer)) - beg) - (goto-char (point-min)) - (search-forward-regexp "^\n" nil t) - (setq beg (point)) + (let ((obuf (current-buffer)) + (mb (mm-multibyte-p)) + beg) + (goto-char (point-min)) + (search-forward-regexp "^\n" nil t) + (setq beg (point)) (with-current-buffer - ;; Preserve the data's unibyteness (for url-insert-file-contents). - (let ((default-enable-multibyte-characters (mm-multibyte-p))) - (generate-new-buffer " *mm*")) + (generate-new-buffer " *mm*") + ;; Preserve the data's unibyteness (for url-insert-file-contents). + (mm-set-buffer-multibyte mb) (insert-buffer-substring obuf beg) (current-buffer)))) @@ -661,6 +691,9 @@ Postpone undisplaying of viewers for types in (goto-char (point-max))) (mapcar 'mm-display-parts handle)))) +(autoload 'mailcap-parse-mailcaps "mailcap") +(autoload 'mailcap-mime-info "mailcap") + (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; @@ -719,6 +752,9 @@ external if displayed external." (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 + (defun mm-display-external (handle method) "Display HANDLE using METHOD." (let ((outbuf (current-buffer))) @@ -730,6 +766,7 @@ external if displayed external." (set-buffer (generate-new-buffer " *mm*")) (setq method nil)) (mm-insert-part handle) + (mm-add-meta-html-tag handle) (let ((win (get-buffer-window cur t))) (when win (select-window win))) @@ -753,6 +790,7 @@ external if displayed external." (mm-handle-set-undisplayer handle mm))))) ;; The function is a string to be executed. (mm-insert-part handle) + (mm-add-meta-html-tag handle) (let* ((dir (mm-make-temp-file (expand-file-name "emm." mm-tmp-directory) 'dir)) (filename (or @@ -767,7 +805,7 @@ external if displayed external." (copiousoutput (assoc "copiousoutput" mime-info)) file buffer) ;; We create a private sub-directory where we store our files. - (set-file-modes dir 448) + (set-file-modes dir #o700) (if filename (setq file (expand-file-name (gnus-map-function mm-file-name-rewrite-functions @@ -787,6 +825,10 @@ external if displayed external." nil suffix)))) (let ((coding-system-for-write mm-binary-coding-system)) (write-region (point-min) (point-max) file nil 'nomesg)) + ;; The file is deleted after the viewer exists. If the users edits + ;; the file, changes will be lost. Set file to read-only to make it + ;; clear. + (set-file-modes file #o400) (message "Viewing with %s" method) (cond (needsterm @@ -881,13 +923,21 @@ external if displayed external." ;; a vector in Emacs but is a list in XEmacs) ;; requires that it is lexically scoped. (timer (run-at-time 2.0 nil 'ignore))) - (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)))))) + (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))))))) (mm-handle-set-external-undisplayer handle (cons file buffer))) (message "Displaying %s..." command)) @@ -968,7 +1018,8 @@ external if displayed external." (cond ;; Internally displayed part. ((mm-annotationp object) - (delete-annotation object)) + (if (featurep 'xemacs) + (delete-annotation object))) ((or (functionp object) (and (listp object) (eq (car object) 'lambda))) @@ -1090,17 +1141,15 @@ in HANDLE." (defmacro mm-with-part (handle &rest forms) "Run FORMS in the temp buffer containing the contents of HANDLE." - `(let* ((handle ,handle) - ;; The multibyteness of the temp buffer should be turned on - ;; if inserting a multibyte string. Contrarily, the buffer's - ;; multibyteness should be off if inserting a unibyte string, - ;; especially if a string contains 8bit data. - (default-enable-multibyte-characters - (with-current-buffer (mm-handle-buffer handle) - (mm-multibyte-p)))) + ;; The handle-buffer's content is a sequence of bytes, not a sequence of + ;; chars, so the buffer should be unibyte. It may happen that the + ;; handle-buffer is multibyte for some reason, in which case now is a good + ;; time to adjust it, since we know at this point that it should + ;; be unibyte. + `(let* ((handle ,handle)) (with-temp-buffer - (insert-buffer-substring (mm-handle-buffer handle)) (mm-disable-multibyte) + (insert-buffer-substring (mm-handle-buffer handle)) (mm-decode-content-transfer-encoding (mm-handle-encoding handle) (mm-handle-media-type handle)) @@ -1126,16 +1175,26 @@ are ignored." "Insert the contents of HANDLE in the current buffer. If NO-CACHE is non-nil, cached contents of a message/external-body part are ignored." - (save-excursion - (insert - (cond ((eq (mail-content-type-get (mm-handle-type handle) 'charset) - 'gnus-decoded) - (with-current-buffer (mm-handle-buffer handle) - (buffer-string))) - ((mm-multibyte-p) - (mm-string-to-multibyte (mm-get-part handle no-cache))) - (t - (mm-get-part handle no-cache)))))) + (let ((text (cond ((eq (mail-content-type-get (mm-handle-type handle) + 'charset) + 'gnus-decoded) + (with-current-buffer (mm-handle-buffer handle) + (buffer-string))) + ((mm-multibyte-p) + (mm-string-to-multibyte (mm-get-part handle no-cache))) + (t + (mm-get-part handle no-cache))))) + (save-restriction + (widen) + (goto-char + (prog1 + (point) + (if (and (eq (get-char-property (max (point-min) (1- (point))) 'face) + 'mm-uu-extract) + (eq (get-char-property 0 'face text) 'mm-uu-extract)) + ;; Separate the extracted parts that have the same faces. + (insert "\n" text) + (insert text))))))) (defun mm-file-name-delete-whitespace (file-name) "Remove all whitespace characters from FILE-NAME." @@ -1187,10 +1246,9 @@ PROMPT overrides the default one used to ask user for a file name." (setq filename (gnus-map-function mm-file-name-rewrite-functions (file-name-nondirectory filename)))) (setq file - (mm-with-multibyte - (read-file-name (or prompt "Save MIME part to: ") - (or mm-default-directory default-directory) - nil nil (or filename "")))) + (read-file-name (or prompt "Save MIME part to: ") + (or mm-default-directory default-directory) + nil nil (or filename ""))) (setq mm-default-directory (file-name-directory file)) (and (or (not (file-exists-p file)) (yes-or-no-p (format "File %s already exists; overwrite? " @@ -1199,29 +1257,59 @@ PROMPT overrides the default one used to ask user for a file name." (mm-save-part-to-file handle file) file)))) +(defun mm-add-meta-html-tag (handle &optional charset force-charset) + "Add meta html tag to specify CHARSET of HANDLE in the current buffer. +CHARSET defaults to the one HANDLE specifies. Existing meta tag that +specifies charset will not be modified unless FORCE-CHARSET is non-nil. +Return t if meta tag is added or replaced." + (when (equal (mm-handle-media-type handle) "text/html") + (when (or charset + (setq charset (mail-content-type-get (mm-handle-type handle) + 'charset))) + (setq charset (format "\ +" charset)) + (let ((case-fold-search t)) + (goto-char (point-min)) + (if (re-search-forward "\ +]*>" nil t) + (if (and (not force-charset) + (match-beginning 2) + (string-match "\\`html\\'" (match-string 1))) + ;; Don't modify existing meta tag. + nil + ;; Replace it with the one specifying charset. + (replace-match charset) + t) + (if (re-search-forward "\\s-*" nil t) + (insert charset "\n") + (re-search-forward "]+\\|\\s-*\\)>\\s-*" nil t) + (insert "\n" charset "\n\n")) + t))))) + (defun mm-save-part-to-file (handle file) (mm-with-unibyte-buffer (mm-insert-part handle) - (let ((coding-system-for-write 'binary) - (current-file-modes (default-file-modes)) + (mm-add-meta-html-tag handle) + (let ((current-file-modes (default-file-modes))) + (set-default-file-modes mm-attachment-file-modes) + (unwind-protect ;; Don't re-compress .gz & al. Arguably we should make ;; `file-name-handler-alist' nil, but that would chop ;; ange-ftp, which is reasonable to use here. - (inhibit-file-name-operation 'write-region) - (inhibit-file-name-handlers - (cons 'jka-compr-handler inhibit-file-name-handlers))) - (set-default-file-modes mm-attachment-file-modes) - (unwind-protect - (write-region (point-min) (point-max) file) + (mm-write-region (point-min) (point-max) file nil nil nil 'binary t) (set-default-file-modes current-file-modes))))) -(defun mm-pipe-part (handle) - "Pipe HANDLE to a process." - (let* ((name (mail-content-type-get (mm-handle-type handle) 'name)) - (command - (read-string "Shell command on MIME part: " mm-last-shell-command))) +(defun mm-pipe-part (handle &optional cmd) + "Pipe HANDLE to a process. +Use CMD as the process." + (let ((name (mail-content-type-get (mm-handle-type handle) 'name)) + (command (or cmd + (gnus-read-shell-command + "Shell command on MIME part: " mm-last-shell-command)))) (mm-with-unibyte-buffer (mm-insert-part handle) + (mm-add-meta-html-tag handle) (let ((coding-system-for-write 'binary)) (shell-command-on-region (point-min) (point-max) command nil))))) @@ -1336,44 +1424,48 @@ be determined." (mm-handle-set-cache handle spec)))))) (defun mm-create-image-xemacs (type) - (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 (mm-make-temp-file - (expand-file-name "emm" mm-tmp-directory) - nil ".xbm"))) - (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 - (or (mm-image-type-from-buffer) - (intern type)) - :data (buffer-string)))))) + (when (featurep 'xemacs) + (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 (mm-make-temp-file + (expand-file-name "emm" mm-tmp-directory) + nil ".xbm"))) + (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 + (or (mm-image-type-from-buffer) + (intern type)) + :data (buffer-string))))))) + +(declare-function image-size "image.c" (spec &optional pixels frame)) (defun mm-image-fit-p (handle) "Say whether the image in HANDLE will fit the current window." (let ((image (mm-get-image handle))) - (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)))))))) + (or (not image) + (if (featurep 'xemacs) + ;; 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." @@ -1460,6 +1552,8 @@ If RECURSIVE, search recursively." (put-text-property 0 (length (car handle)) parameter value (car handle)))) +(autoload 'mm-view-pkcs7 "mm-view") + (defun mm-possibly-verify-or-decrypt (parts ctl) (let ((type (car ctl)) (subtype (cadr (split-string (car ctl) "/"))) @@ -1507,7 +1601,7 @@ If RECURSIVE, search recursively." (format "protocol=%s" protocol)))))) (save-excursion (if func - (funcall func parts ctl) + (setq parts (funcall func parts ctl)) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-details (format "Unknown sign protocol (%s)" protocol)))))) @@ -1576,5 +1670,4 @@ If RECURSIVE, search recursively." (provide 'mm-decode) -;; arch-tag: 4f35d360-56b8-4030-9388-3ed82d359b9b ;;; mm-decode.el ends here