* 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.

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index d1237a4..58b00a2 100644 (file)
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,26 @@
+2005-02-07  Katsumi Yamaoka  <yamaoka@jpl.org>
+
+       * 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  <tsuchiya@namazu.org>
+
+       * mm-view.el (mm-display-inline-fontify): Decode a part according
+       to the charset parameter.
+

 2005-02-03  Katsumi Yamaoka  <yamaoka@jpl.org>
 
        * gnus-art.el (gnus-mime-inline-part): Show the raw contents if a
 2005-02-03  Katsumi Yamaoka  <yamaoka@jpl.org>
 
        * 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 1965d55..4f3fb3d 100644 (file)
--- 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)
   "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)
       (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)
        (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))
         ((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))
         (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)
        (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)
        (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 3dcca9b..453dffd 100644 (file)
--- 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
 ;;; 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 <larsi@gnus.org>
 ;;   Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>


@@ -73,6 +73,12 @@
      (string-as-unibyte . identity)
      (string-make-unibyte . identity)
      (string-as-multibyte . identity)
      (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)
      (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)))
     (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)))
 
   (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)
 
 
 (provide 'mm-util)
 

diff --git a/lisp/mm-view.el b/lisp/mm-view.el
index 9d3f0b0..4b23930 100644 (file)
--- a/lisp/mm-view.el
+++ b/lisp/mm-view.el
@@ -1,5 +1,5 @@
 ;;; mm-view.el --- functions for viewing MIME objects
 ;;; 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 <larsi@gnus.org>
 ;; Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>


@@ -378,6 +378,8 @@
   "Insert TEXT inline from HANDLE."
   (let ((b (point)))
     (insert text)
   "Insert TEXT inline from HANDLE."
   (let ((b (point)))
     (insert text)

+    (unless (bolp)
+      (insert "\n"))

     (mm-handle-set-undisplayer
      handle
      `(lambda ()
     (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)
              (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
     ;; 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
     (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 31d0f39..c131407 100644 (file)
--- 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)))
       (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
          (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")))
                  (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))))
                      (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))
               ((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)
               (t
                (insert (cdr (assq 'contents cont)))))
              (setq encoding (mm-encode-buffer type)