From 26d9bc63a34cfc507febb91f5f7d3739eb464c5f Mon Sep 17 00:00:00 2001 From: Katsumi Yamaoka Date: Mon, 7 Feb 2005 10:37:48 +0000 Subject: [PATCH] * gnus-art.el (gnus-mime-inline-part): Decode parts according to the coding cookies; decompress compressed parts. * mml.el (mml-generate-mime-1): Add the charaset parameter according to the value which a user specified manually or the coding cookie. * mm-util.el (mm-string-to-multibyte): New function. (mm-detect-mime-charset-region): Work with Emacs 22 as well. (mm-coding-system-to-mime-charset): New function. (mm-decompress-buffer): New function. (mm-find-buffer-file-coding-system): New function. * mm-view.el (mm-insert-inline): Make sure a part ends with a newline. (mm-display-inline-fontify): Rewrite for decoding and decompressing parts. --- lisp/ChangeLog | 23 +++++++ lisp/gnus-art.el | 51 +++++++++------- lisp/mm-util.el | 156 ++++++++++++++++++++++++++++++++++++++++++++++- lisp/mm-view.el | 76 ++++++++++++++--------- lisp/mml.el | 23 ++++--- 5 files changed, 268 insertions(+), 61 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d1237a454..58b00a2c6 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,26 @@ +2005-02-07 Katsumi Yamaoka + + * gnus-art.el (gnus-mime-inline-part): Decode parts according to + the coding cookies; decompress compressed parts. + + * mml.el (mml-generate-mime-1): Add the charaset parameter according + to the value which a user specified manually or the coding cookie. + + * mm-util.el (mm-string-to-multibyte): New function. + (mm-detect-mime-charset-region): Work with Emacs 22 as well. + (mm-coding-system-to-mime-charset): New function. + (mm-decompress-buffer): New function. + (mm-find-buffer-file-coding-system): New function. + + * mm-view.el (mm-insert-inline): Make sure a part ends with a newline. + (mm-display-inline-fontify): Rewrite for decoding and decompressing + parts. + +2004-10-15 TSUCHIYA Masatoshi + + * mm-view.el (mm-display-inline-fontify): Decode a part according + to the charset parameter. + 2005-02-03 Katsumi Yamaoka * gnus-art.el (gnus-mime-inline-part): Show the raw contents if a diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 1965d55f4..4f3fb3dac 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -4316,19 +4316,31 @@ are decompressed." "Insert the MIME part under point into the current buffer." (interactive (list nil current-prefix-arg)) (gnus-article-check-buffer) - (let* ((handle (or handle (get-text-property (point) 'gnus-data))) - contents charset - (b (point)) - (inhibit-read-only t)) - (when handle + (unless handle + (setq handle (get-text-property (point) 'gnus-data))) + (when handle + (let ((b (point)) + (inhibit-read-only t) + contents charset coding-system) (if (and (not arg) (mm-handle-undisplayer handle)) (mm-remove-part handle) - (setq contents (mm-get-part handle)) + (mm-with-unibyte-buffer + (mm-insert-part handle) + (setq contents + (or (mm-decompress-buffer (mail-content-type-get + (mm-handle-disposition handle) + 'filename)) + (buffer-string)))) (cond ((not arg) - (setq charset (or (mail-content-type-get - (mm-handle-type handle) 'charset) - gnus-newsgroup-charset))) + (unless (setq charset (mail-content-type-get + (mm-handle-type handle) 'charset)) + (if (setq coding-system (mm-with-unibyte-buffer + (insert contents) + (mm-find-buffer-file-coding-system))) + (setq contents (mm-decode-coding-string contents + coding-system)) + (setq charset gnus-newsgroup-charset)))) ((numberp arg) (if (mm-handle-undisplayer handle) (mm-remove-part handle)) @@ -4339,20 +4351,15 @@ are decompressed." (t (if (mm-handle-undisplayer handle) (mm-remove-part handle)) - (setq contents - (if (fboundp 'string-to-multibyte) - (string-to-multibyte contents) - (mapconcat - (lambda (ch) (mm-string-as-multibyte (char-to-string ch))) - contents ""))))) + (setq contents (mm-string-to-multibyte contents)))) (forward-line 2) - (mm-insert-inline handle - (if (and charset - (setq charset (mm-charset-to-coding-system - charset)) - (not (eq charset 'ascii))) - (mm-decode-coding-string contents charset) - contents)) + (mm-insert-inline + handle + (if (and charset + (setq coding-system (mm-charset-to-coding-system charset)) + (not (eq charset 'ascii))) + (mm-decode-coding-string contents coding-system) + contents)) (goto-char b))))) (defun gnus-mime-view-part-as-charset (&optional handle arg) diff --git a/lisp/mm-util.el b/lisp/mm-util.el index 3dcca9b1d..453dffd9d 100644 --- a/lisp/mm-util.el +++ b/lisp/mm-util.el @@ -1,5 +1,5 @@ ;;; mm-util.el --- Utility functions for Mule and low level things -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004 +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -73,6 +73,12 @@ (string-as-unibyte . identity) (string-make-unibyte . identity) (string-as-multibyte . identity) + (string-to-multibyte + . (lambda (string) + "Return a multibyte string with the same individual chars as string." + (mapconcat + (lambda (ch) (mm-string-as-multibyte (char-to-string ch))) + string ""))) (multibyte-string-p . ignore) ;; It is not a MIME function, but some MIME functions use it. (make-temp-file . (lambda (prefix &optional dir-flag) @@ -918,12 +924,158 @@ If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'." (defun mm-detect-mime-charset-region (start end) "Detect MIME charset of the text in the region between START and END." (let ((cs (mm-detect-coding-region start end))) - (coding-system-get cs 'mime-charset))) + (or (coding-system-get cs :mime-charset) + (coding-system-get cs 'mime-charset)))) (defun mm-detect-mime-charset-region (start end) "Detect MIME charset of the text in the region between START and END." (let ((cs (mm-detect-coding-region start end))) cs))) +(eval-when-compile + (unless (fboundp 'coding-system-to-mime-charset) + (defalias 'coding-system-to-mime-charset 'ignore))) + +(defun mm-coding-system-to-mime-charset (coding-system) + "Return the MIME charset corresponding to CODING-SYSTEM. +To make this function work with XEmacs, the APEL package is required." + (when coding-system + (or (coding-system-get coding-system :mime-charset) + (coding-system-get coding-system 'mime-charset) + (and (featurep 'xemacs) + (or (and (fboundp 'coding-system-to-mime-charset) + (not (eq (symbol-function 'coding-system-to-mime-charset) + 'ignore))) + (and (condition-case nil + (require 'mcharset) + (error nil)) + (fboundp 'coding-system-to-mime-charset))) + (coding-system-to-mime-charset coding-system))))) + +(defun mm-decompress-buffer (filename &optional inplace) + "Decompress buffer's contents according to the extension of FILENAME. +If INPLACE is nil, return a decompressed string or nil, and the buffer +will not be modified. Otherwise, replace the buffer's contents with +the decompressed one. Decompression is done only when the extension +is \".gz\" or \".bz2\" which does not follow \".tar\"." + (let ((decomp (cond ((or (not filename) + (string-match "\\.tar\\.[^.]+\\'" filename)) + nil) + ((string-match "\\.gz\\'" filename) + '("gzip" "-c" "-d" "-q")) + ((string-match "\\.bz2\\'" filename) + '("bzip2" "-d"))))) + (when decomp + (let ((coding-system-for-read mm-binary-coding-system) + (coding-system-for-write mm-binary-coding-system) + cur mod) + (if inplace + (prog1 + nil + (setq cur (buffer-string) + mod (buffer-modified-p)) + (condition-case nil + (apply 'call-process-region (point-min) (point-max) + (car decomp) t t nil (cdr decomp)) + (error + (erase-buffer) + (insert cur) + (set-buffer-modified-p mod)))) + (setq cur (current-buffer)) + (mm-with-unibyte-buffer + (insert-buffer-substring cur) + (condition-case nil + (progn + (apply 'call-process-region (point-min) (point-max) + (car decomp) t t nil (cdr decomp)) + (buffer-string)) + (error nil)))))))) + +(eval-when-compile + (unless (fboundp 'coding-system-name) + (defalias 'coding-system-name 'ignore)) + (unless (fboundp 'find-file-coding-system-for-read-from-filename) + (defalias 'find-file-coding-system-for-read-from-filename 'ignore)) + (unless (fboundp 'find-operation-coding-system) + (defalias 'find-operation-coding-system 'ignore))) + +(defun mm-find-buffer-file-coding-system (&optional filename) + "Find coding system used to decode the contents of the current buffer. +This function looks for the coding system magic cookie or examines the +coding system specified by `file-coding-system-alist' being associated +with FILENAME which defaults to `buffer-file-name'." + (unless filename + (setq filename buffer-file-name)) + (save-excursion + (let ((decomp (mm-decompress-buffer filename))) + (when decomp + (set-buffer (let (default-enable-multibyte-characters) + (generate-new-buffer " *temp*"))) + (insert decomp) + (setq filename (file-name-sans-extension filename))) + (goto-char (point-min)) + (prog1 + (cond + ((boundp 'set-auto-coding-function) ;; Emacs + (if filename + (or (funcall (symbol-value 'set-auto-coding-function) + filename (- (point-max) (point-min))) + (car (find-operation-coding-system 'insert-file-contents + filename))) + (let (auto-coding-alist) + (condition-case nil + (funcall (symbol-value 'set-auto-coding-function) + nil (- (point-max) (point-min))) + (error nil))))) + ((featurep 'file-coding) ;; XEmacs + (let ((case-fold-search t) + (end (point-at-eol)) + codesys start) + (or + (and (re-search-forward "-\\*-+[\t ]*" end t) + (progn + (setq start (match-end 0)) + (re-search-forward "[\t ]*-+\\*-" end t)) + (progn + (setq end (match-beginning 0)) + (goto-char start) + (or (looking-at "coding:[\t ]*\\([^\t ;]+\\)") + (re-search-forward + "[\t ;]+coding:[\t ]*\\([^\t ;]+\\)" + end t))) + (find-coding-system (setq codesys + (intern (match-string 1)))) + codesys) + (and (re-search-forward "^[\t ]*;+[\t ]*Local[\t ]+Variables:" + nil t) + (progn + (setq start (match-end 0)) + (re-search-forward "^[\t ]*;+[\t ]*End:" nil t)) + (progn + (setq end (match-beginning 0)) + (goto-char start) + (re-search-forward + "^[\t ]*;+[\t ]*coding:[\t ]*\\([^\t\n\r ]+\\)" + end t)) + (find-coding-system (setq codesys + (intern (match-string 1)))) + codesys) + (and (progn + (goto-char (point-min)) + (setq case-fold-search nil) + (re-search-forward "^;;;coding system: " + ;;(+ (point-min) 3000) t)) + nil t)) + (looking-at "[^\t\n\r ]+") + (find-coding-system + (setq codesys (intern (match-string 0)))) + codesys) + (and filename + (setq codesys + (find-file-coding-system-for-read-from-filename + filename)) + (coding-system-name (coding-system-base codesys))))))) + (when decomp + (kill-buffer (current-buffer))))))) (provide 'mm-util) diff --git a/lisp/mm-view.el b/lisp/mm-view.el index 9d3f0b0e8..4b2393099 100644 --- a/lisp/mm-view.el +++ b/lisp/mm-view.el @@ -1,5 +1,5 @@ ;;; mm-view.el --- functions for viewing MIME objects -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004 +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -378,6 +378,8 @@ "Insert TEXT inline from HANDLE." (let ((b (point))) (insert text) + (unless (bolp) + (insert "\n")) (mm-handle-set-undisplayer handle `(lambda () @@ -459,36 +461,52 @@ (delete-region ,(point-min-marker) ,(point-max-marker))))))))) (defun mm-display-inline-fontify (handle mode) - (let (text) + (let ((charset (mail-content-type-get (mm-handle-type handle) 'charset)) + text coding-system) + (unless (eq charset 'gnus-decoded) + (mm-with-unibyte-buffer + (mm-insert-part handle) + (mm-decompress-buffer (mail-content-type-get + (mm-handle-disposition handle) + 'filename) + t) + (unless charset + (setq coding-system (mm-find-buffer-file-coding-system))) + (setq text (buffer-string)))) ;; XEmacs @#$@ version of font-lock refuses to fully turn itself ;; on for buffers whose name begins with " ". That's why we use - ;; save-current-buffer/get-buffer-create rather than - ;; with-temp-buffer. - (save-current-buffer - (set-buffer (generate-new-buffer "*fontification*")) - (unwind-protect - (progn - (buffer-disable-undo) - (mm-insert-part handle) - (require 'font-lock) - ;; Inhibit font-lock this time (*-mode-hook might run - ;; `turn-on-font-lock') so that jit-lock may not turn off - ;; font-lock immediately after this. - (let ((font-lock-mode t)) - (funcall mode)) - (let ((font-lock-verbose nil)) - ;; I find font-lock a bit too verbose. - (font-lock-fontify-buffer)) - ;; By default, XEmacs font-lock uses non-duplicable text - ;; properties. This code forces all the text properties - ;; to be copied along with the text. - (when (fboundp 'extent-list) - (map-extents (lambda (ext ignored) - (set-extent-property ext 'duplicable t) - nil) - nil nil nil nil nil 'text-prop)) - (setq text (buffer-string))) - (kill-buffer (current-buffer)))) + ;; `with-current-buffer'/`generate-new-buffer' rather than + ;; `with-temp-buffer'. + (with-current-buffer (generate-new-buffer "*fontification*") + (buffer-disable-undo) + (mm-enable-multibyte) + (insert (cond ((eq charset 'gnus-decoded) + (mm-insert-part handle)) + (coding-system + (mm-decode-coding-string text coding-system)) + (charset + (mm-decode-string text charset)) + (t + text))) + (require 'font-lock) + ;; Inhibit font-lock this time (*-mode-hook might run + ;; `turn-on-font-lock') so that jit-lock may not turn off + ;; font-lock immediately after this. + (let ((font-lock-mode t)) + (funcall mode)) + (let ((font-lock-verbose nil)) + ;; I find font-lock a bit too verbose. + (font-lock-fontify-buffer)) + ;; By default, XEmacs font-lock uses non-duplicable text + ;; properties. This code forces all the text properties + ;; to be copied along with the text. + (when (fboundp 'extent-list) + (map-extents (lambda (ext ignored) + (set-extent-property ext 'duplicable t) + nil) + nil nil nil nil nil 'text-prop)) + (setq text (buffer-string)) + (kill-buffer (current-buffer))) (mm-insert-inline handle text))) ;; Shouldn't these functions check whether the user even wants to use diff --git a/lisp/mml.el b/lisp/mml.el index 31d0f39d4..c13140744 100644 --- a/lisp/mml.el +++ b/lisp/mml.el @@ -397,22 +397,25 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (cond ((or (eq (car cont) 'part) (eq (car cont) 'mml)) (let ((raw (cdr (assq 'raw cont))) - coded encoding charset filename type flowed) - (setq type (or (cdr (assq 'type cont)) "text/plain")) + type charset coding filename encoding flowed coded) + (setq type (or (cdr (assq 'type cont)) "text/plain") + charset (cdr (assq 'charset cont)) + coding (mm-charset-to-coding-system charset)) + (cond ((eq coding 'ascii) + (setq charset nil + coding nil)) + (charset + (setq charset (intern (downcase charset))))) (if (and (not raw) (member (car (split-string type "/")) '("text" "message"))) (progn (with-temp-buffer - (setq charset (mm-charset-to-coding-system - (cdr (assq 'charset cont)))) - (when (eq charset 'ascii) - (setq charset nil)) (cond ((cdr (assq 'buffer cont)) (insert-buffer-substring (cdr (assq 'buffer cont)))) ((and (setq filename (cdr (assq 'filename cont))) (not (equal (cdr (assq 'nofile cont)) "yes"))) - (let ((coding-system-for-read charset)) + (let ((coding-system-for-read coding)) (mm-insert-file-contents filename))) ((eq 'mml (car cont)) (insert (cdr (assq 'contents cont)))) @@ -474,7 +477,11 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." ((and (setq filename (cdr (assq 'filename cont))) (not (equal (cdr (assq 'nofile cont)) "yes"))) (let ((coding-system-for-read mm-binary-coding-system)) - (mm-insert-file-contents filename nil nil nil nil t))) + (mm-insert-file-contents filename nil nil nil nil t)) + (unless charset + (setq charset (mm-coding-system-to-mime-charset + (mm-find-buffer-file-coding-system + filename))))) (t (insert (cdr (assq 'contents cont))))) (setq encoding (mm-encode-buffer type) -- 2.25.1