Importing Pterodactyl Gnus v0.83.

[elisp/gnus.git-] / lisp / mm-util.el

diff --git a/lisp/mm-util.el b/lisp/mm-util.el
index bcba15b..dfad2a2 100644 (file)
--- a/lisp/mm-util.el
+++ b/lisp/mm-util.el
@@ -1,5 +1,5 @@
 ;;; mm-util.el --- Utility functions for MIME things
 ;;; mm-util.el --- Utility functions for MIME things

-;; Copyright (C) 1998 Free Software Foundation, Inc.
+;; Copyright (C) 1998,99 Free Software Foundation, Inc.

 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;;     MORIOKA Tomohiko <morioka@jaist.ac.jp>
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;;     MORIOKA Tomohiko <morioka@jaist.ac.jp>

@@ -24,8 +24,27 @@
 
 ;;; Code:
 
 
 ;;; Code:
 

-(defvar mm-known-charsets '(iso-8859-1)
-  "List of known charsets.")
+(defvar mm-running-xemacs (string-match "XEmacs" emacs-version))
+
+(defvar mm-running-ntemacs
+  (and (not mm-running-xemacs)
+       (string-match "nt" system-configuration)))
+
+(defvar mm-binary-coding-system
+  (if mm-running-xemacs
+      'binary 'no-conversion)
+  "100% binary coding system.")
+
+(defvar mm-text-coding-system
+  (cond
+   ((not (fboundp 'coding-system-p)) nil)
+   (mm-running-xemacs  ;; XEmacs
+    'no-conversion)
+   (mm-running-ntemacs ;; NTEmacs
+    (and (coding-system-p 'raw-text-dos) 'raw-text-dos))
+   ((coding-system-p 'raw-text) 'raw-text) ;; Emacs
+   (t nil))
+  "100% text coding system, for removing ^M.")

 
 (defvar mm-mime-mule-charset-alist
   '((us-ascii ascii)
 
 (defvar mm-mime-mule-charset-alist
   '((us-ascii ascii)

@@ -39,15 +58,21 @@
     (iso-8859-7 greek-iso8859-7)
     (iso-8859-8 hebrew-iso8859-8)
     (iso-8859-9 latin-iso8859-9)
     (iso-8859-7 greek-iso8859-7)
     (iso-8859-8 hebrew-iso8859-8)
     (iso-8859-9 latin-iso8859-9)

+    (viscii vietnamese-viscii-lower)
+    (iso-2022-jp-2 japanese-jisx0208)

     (iso-2022-jp latin-jisx0201
     (iso-2022-jp latin-jisx0201

-                japanese-jisx0208-1978 japanese-jisx0208)
+                japanese-jisx0208-1978)

     (euc-kr korean-ksc5601)
     (cn-gb-2312 chinese-gb2312)
     (cn-big5 chinese-big5-1 chinese-big5-2)
     (euc-kr korean-ksc5601)
     (cn-gb-2312 chinese-gb2312)
     (cn-big5 chinese-big5-1 chinese-big5-2)

+    (tibetan tibetan)
+    (thai-tis620 thai-tis620)
+    (iso-2022-7bit ethiopic arabic-1-column arabic-2-column)

     (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
                   latin-jisx0201 japanese-jisx0208-1978
                   chinese-gb2312 japanese-jisx0208
     (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
                   latin-jisx0201 japanese-jisx0208-1978
                   chinese-gb2312 japanese-jisx0208

-                  korean-ksc5601 japanese-jisx0212)
+                  korean-ksc5601 japanese-jisx0212
+                  katakana-jisx0201)

     (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
                    latin-jisx0201 japanese-jisx0208-1978
                    chinese-gb2312 japanese-jisx0208
     (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
                    latin-jisx0201 japanese-jisx0208-1978
                    chinese-gb2312 japanese-jisx0208

@@ -75,12 +100,13 @@
    '((decode-coding-string . (lambda (s a) s))
      (encode-coding-string . (lambda (s a) s))
      (encode-coding-region . ignore)
    '((decode-coding-string . (lambda (s a) s))
      (encode-coding-string . (lambda (s a) s))
      (encode-coding-region . ignore)

-     (decode-coding-region . ignore)

      (coding-system-list . ignore)
      (coding-system-list . ignore)

+     (decode-coding-region . ignore)

      (char-int . identity)
      (device-type . ignore)
      (coding-system-equal . equal)
      (annotationp . ignore)
      (char-int . identity)
      (device-type . ignore)
      (coding-system-equal . equal)
      (annotationp . ignore)

+     (set-buffer-file-coding-system . ignore)

      (make-char
       . (lambda (charset int)
          (int-to-char int)))
      (make-char
       . (lambda (charset int)
          (int-to-char int)))

@@ -91,22 +117,21 @@
           prompt (mapcar (lambda (s) (list (symbol-name (car s))))
                          mm-mime-mule-charset-alist)))))))
 
           prompt (mapcar (lambda (s) (list (symbol-name (car s))))
                          mm-mime-mule-charset-alist)))))))
 

-(defvar mm-charset-coding-system-alist
-  (let ((rest
-        '((us-ascii . iso-8859-1)
-          (gb2312 . cn-gb-2312)
-          (iso-2022-jp-2 . iso-2022-7bit-ss2)
-          (x-ctext . ctext)))
-       (systems (mm-coding-system-list))
-       dest)
-    (while rest
-      (let ((pair (car rest)))
-       (unless (memq (car pair) systems)
-         (setq dest (cons pair dest))))
-      (setq rest (cdr rest)))
-    dest)
-  "Charset/coding system alist.")
+(defvar mm-coding-system-list nil)
+(defun mm-get-coding-system-list ()
+  "Get the coding system list."
+  (or mm-coding-system-list
+      (setq mm-coding-system-list (mm-coding-system-list))))
+
+(defvar mm-charset-synonym-alist
+  '((big5 . cn-big5)
+    (gb2312 . cn-gb-2312)
+    (x-ctext . ctext))
+  "A mapping from invalid charset names to the real charset names.")

 
 

+;;; Internal variables:
+
+;;; Functions:

 
 (defun mm-mule-charset-to-mime-charset (charset)
   "Return the MIME charset corresponding to MULE CHARSET."
 
 (defun mm-mule-charset-to-mime-charset (charset)
   "Return the MIME charset corresponding to MULE CHARSET."

@@ -127,17 +152,19 @@ used as the line break code type of the coding system."
   (when (stringp charset)
     (setq charset (intern (downcase charset))))
   (setq charset
   (when (stringp charset)
     (setq charset (intern (downcase charset))))
   (setq charset

-       (or (cdr (assq charset mm-charset-coding-system-alist))
+       (or (cdr (assq charset mm-charset-synonym-alist))

            charset))
   (when lbt
     (setq charset (intern (format "%s-%s" charset lbt))))
   (cond
    ;; Running in a non-MULE environment.
            charset))
   (when lbt
     (setq charset (intern (format "%s-%s" charset lbt))))
   (cond
    ;; Running in a non-MULE environment.

-   ((and (null (mm-coding-system-list))
-        (memq charset mm-known-charsets))
+   ((null (mm-get-coding-system-list))

     charset)
     charset)

+   ;; ascii
+   ((eq charset 'us-ascii)
+    'ascii)

    ;; Check to see whether we can handle this charset.
    ;; Check to see whether we can handle this charset.

-   ((memq charset (mm-coding-system-list))
+   ((memq charset (mm-get-coding-system-list))

     charset)
    ;; Nope.
    (t
     charset)
    ;; Nope.
    (t

@@ -157,27 +184,39 @@ used as the line break code type of the coding system."
 
 (defsubst mm-enable-multibyte ()
   "Enable multibyte in the current buffer."
 
 (defsubst mm-enable-multibyte ()
   "Enable multibyte in the current buffer."

-  (when (fboundp 'set-buffer-multibyte)
+  (when (and (fboundp 'set-buffer-multibyte)
+            (default-value 'enable-multibyte-characters))

     (set-buffer-multibyte t)))
 
     (set-buffer-multibyte t)))
 

-(defun mm-insert-rfc822-headers (charset encoding)
-  "Insert text/plain headers with CHARSET and ENCODING."
-  (insert "MIME-Version: 1.0\n")
-  (insert "Content-Type: text/plain; charset=\""
-         (downcase (symbol-name charset)) "\"\n")
-  (insert "Content-Transfer-Encoding: "
-         (downcase (symbol-name encoding)) "\n"))
+(defsubst mm-disable-multibyte ()
+  "Disable multibyte in the current buffer."
+  (when (fboundp 'set-buffer-multibyte)
+    (set-buffer-multibyte nil)))

 
 

-(defun mm-mime-charset (charset b e)
+(defun mm-mime-charset (charset)
+  "Return the MIME charset corresponding to the MULE CHARSET."

   (if (fboundp 'coding-system-get)
   (if (fboundp 'coding-system-get)

+      ;; This exists in Emacs 20.

       (or
       (or

-       (coding-system-get
-       (get-charset-property charset 'prefered-coding-system)
-       'mime-charset)
-       (car (memq charset (find-coding-systems-region
-                          (point-min) (point-max)))))
+       (and (get-charset-property charset 'prefered-coding-system)
+           (coding-system-get
+            (get-charset-property charset 'prefered-coding-system)
+            'mime-charset))
+       (and (eq charset 'ascii)
+           'us-ascii)
+       (get-charset-property charset 'prefered-coding-system)
+       (mm-mule-charset-to-mime-charset charset))
+    ;; This is for XEmacs.

     (mm-mule-charset-to-mime-charset charset)))
 
     (mm-mule-charset-to-mime-charset charset)))
 

+(defun mm-find-mime-charset-region (b e)
+  "Return the MIME charsets needed to encode the region between B and E."
+  (let ((charsets
+        (mapcar 'mm-mime-charset
+                (delq 'ascii
+                      (mm-find-charset-region b e)))))
+    (delete-duplicates charsets)))
+

 (defsubst mm-multibyte-p ()
   "Say whether multibyte is enabled."
   (and (boundp 'enable-multibyte-characters)
 (defsubst mm-multibyte-p ()
   "Say whether multibyte is enabled."
   (and (boundp 'enable-multibyte-characters)

@@ -190,20 +229,62 @@ See also `with-temp-file' and `with-output-to-string'."
        (multibyte (make-symbol "multibyte")))
     `(if (not (boundp 'enable-multibyte-characters))
         (with-temp-buffer ,@forms)
        (multibyte (make-symbol "multibyte")))
     `(if (not (boundp 'enable-multibyte-characters))
         (with-temp-buffer ,@forms)

-       (let ((,multibyte (default-value enable-multibyte-characters))
+       (let ((,multibyte (default-value 'enable-multibyte-characters))

             ,temp-buffer)
             ,temp-buffer)

-        (setq-default enable-multibyte-characters nil)
-        (setq ,temp-buffer
-              (get-buffer-create (generate-new-buffer-name " *temp*")))

         (unwind-protect
         (unwind-protect

-            (with-current-buffer ,temp-buffer
-              ,@forms)
-          (and (buffer-name ,temp-buffer)
-               (kill-buffer ,temp-buffer))
+            (progn
+              (setq-default enable-multibyte-characters nil)
+              (setq ,temp-buffer
+                    (get-buffer-create (generate-new-buffer-name " *temp*")))
+              (unwind-protect
+                  (with-current-buffer ,temp-buffer
+                    (let ((buffer-file-coding-system mm-binary-coding-system)
+                          (coding-system-for-read mm-binary-coding-system)
+                          (coding-system-for-write mm-binary-coding-system))
+                      ,@forms))
+                (and (buffer-name ,temp-buffer)
+                     (kill-buffer ,temp-buffer))))

           (setq-default enable-multibyte-characters ,multibyte))))))
 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
 
           (setq-default enable-multibyte-characters ,multibyte))))))
 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
 

+(defun mm-find-charset-region (b e)
+  "Return a list of charsets in the region."
+  (cond
+   ((and (boundp 'enable-multibyte-characters)
+        enable-multibyte-characters
+        (fboundp 'find-charset-region))
+    (find-charset-region b e))
+   ((not (boundp 'current-language-environment))
+    (save-excursion
+      (save-restriction
+       (narrow-to-region b e)
+       (goto-char (point-min))
+       (skip-chars-forward "\0-\177")
+       (if (eobp)
+           '(ascii)
+         (delq nil (list 'ascii mail-parse-charset))))))
+   (t
+    ;; We are in a unibyte buffer, so we futz around a bit.
+    (save-excursion
+      (save-restriction
+       (narrow-to-region b e)
+       (goto-char (point-min))
+       (let ((entry (assoc (capitalize current-language-environment)
+                           language-info-alist)))
+         (skip-chars-forward "\0-\177")
+         (if (eobp)
+             '(ascii)
+           (list 'ascii (car (last (assq 'charset entry)))))))))))
+
+(defun mm-read-charset (prompt)
+  "Return a charset."
+  (intern
+   (completing-read
+    prompt
+    (mapcar (lambda (e) (list (symbol-name (car e))))
+           mm-mime-mule-charset-alist)
+    nil t)))

 
 (provide 'mm-util)
 
 
 (provide 'mm-util)