Synch with Oort Gnus.

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

diff --git a/lisp/mm-util.el b/lisp/mm-util.el
index 59dae6d..750c3ec 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 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002 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>

@@ -43,7 +43,6 @@
      (coding-system-list . ignore)
      (decode-coding-region . ignore)
      (char-int . identity)
      (coding-system-list . ignore)
      (decode-coding-region . ignore)
      (char-int . identity)

-     (device-type . ignore)

      (coding-system-equal . equal)
      (annotationp . ignore)
      (set-buffer-file-coding-system . ignore)
      (coding-system-equal . equal)
      (annotationp . ignore)
      (set-buffer-file-coding-system . ignore)

@@ -124,7 +123,7 @@
        '((iso-8859-15 . iso-8859-1)))
     ;; Windows-1252 is actually a superset of Latin-1.  See also
     ;; `gnus-article-dumbquotes-map'.
        '((iso-8859-15 . iso-8859-1)))
     ;; Windows-1252 is actually a superset of Latin-1.  See also
     ;; `gnus-article-dumbquotes-map'.

-    ,@(unless (mm-coding-system-p 'windows-1252)       
+    ,@(unless (mm-coding-system-p 'windows-1252)

        (if (mm-coding-system-p 'cp1252)
           '((windows-1252 . cp1252))
         '((windows-1252 . iso-8859-1))))
        (if (mm-coding-system-p 'cp1252)
           '((windows-1252 . cp1252))
         '((windows-1252 . iso-8859-1))))

@@ -248,7 +247,7 @@ Valid elements include:
 `iso-2022-jp-2'  convert ISO-2022-jp to ISO-2022-jp-2 if ISO-2022-jp-2 exists."
 )
 
 `iso-2022-jp-2'  convert ISO-2022-jp to ISO-2022-jp-2 if ISO-2022-jp-2 exists."
 )
 

-(defvar mm-iso-8859-15-compatible 
+(defvar mm-iso-8859-15-compatible

   '((iso-8859-1 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE")
     (iso-8859-9 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE\xD0\xDD\xDE\xF0\xFD\xFE"))
   "ISO-8859-15 exchangeable coding systems and inconvertible characters.")
   '((iso-8859-1 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE")
     (iso-8859-9 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE\xD0\xDD\xDE\xF0\xFD\xFE"))
   "ISO-8859-15 exchangeable coding systems and inconvertible characters.")

@@ -256,22 +255,22 @@ Valid elements include:
 (defvar mm-iso-8859-x-to-15-table
   (and (fboundp 'coding-system-p)
        (mm-coding-system-p 'iso-8859-15)
 (defvar mm-iso-8859-x-to-15-table
   (and (fboundp 'coding-system-p)
        (mm-coding-system-p 'iso-8859-15)

-       (mapcar 
+       (mapcar

        (lambda (cs)
          (if (mm-coding-system-p (car cs))
        (lambda (cs)
          (if (mm-coding-system-p (car cs))

-             (let ((c (string-to-char 
+             (let ((c (string-to-char

                        (decode-coding-string "\341" (car cs)))))
                (cons (char-charset c)
                      (cons
                        (decode-coding-string "\341" (car cs)))))
                (cons (char-charset c)
                      (cons

-                      (- (string-to-char 
+                      (- (string-to-char

                           (decode-coding-string "\341" 'iso-8859-15)) c)
                           (decode-coding-string "\341" 'iso-8859-15)) c)

-                      (string-to-list (decode-coding-string (car (cdr cs)) 
+                      (string-to-list (decode-coding-string (car (cdr cs))

                                                             (car cs))))))
            '(gnus-charset 0)))
        mm-iso-8859-15-compatible))
   "A table of the difference character between ISO-8859-X and ISO-8859-15.")
 
                                                             (car cs))))))
            '(gnus-charset 0)))
        mm-iso-8859-15-compatible))
   "A table of the difference character between ISO-8859-X and ISO-8859-15.")
 

-(defvar mm-coding-system-priorities nil
+(defcustom mm-coding-system-priorities nil

   "Preferred coding systems for encoding outgoing mails.
 
 More than one suitable coding systems may be found for some texts.  By
   "Preferred coding systems for encoding outgoing mails.
 
 More than one suitable coding systems may be found for some texts.  By

@@ -281,8 +280,17 @@ it overrides the default priority.  For example, Japanese users may
 prefer iso-2022-jp to japanese-shift-jis:
 
 \(setq mm-coding-system-priorities
 prefer iso-2022-jp to japanese-shift-jis:
 
 \(setq mm-coding-system-priorities

-  '(iso-2022-jp iso-2022-jp-2 japanese-shift-jis utf-8))
-")
+  '(iso-2022-jp iso-2022-jp-2 japanese-shift-jis iso-latin-1 utf-8))
+"
+  :type '(repeat (symbol :tag "Coding system"))
+  :group 'mime)
+
+(defvar mm-use-find-coding-systems-region
+  (fboundp 'find-coding-systems-region)
+  "Use `find-coding-systems-region' to find proper coding systems.
+
+Setting it to nil is useful on Emacsen supporting Unicode if sending
+mail with multiple parts is preferred to sending a Unicode one.")

 
 ;;; Internal variables:
 
 
 ;;; Internal variables:
 

@@ -334,10 +342,8 @@ used as the line break code type of the coding system."
         )
     charset)
    ;; Translate invalid charsets.
         )
     charset)
    ;; Translate invalid charsets.

-   ((mm-coding-system-p (setq charset
-                          (cdr (assq charset
-                                     mm-charset-synonym-alist))))
-    charset)
+   ((let ((cs (cdr (assq charset mm-charset-synonym-alist))))
+      (and cs (mm-coding-system-p cs) cs)))

    ;; Last resort: search the coding system list for entries which
    ;; have the right mime-charset in case the canonical name isn't
    ;; defined (though it should be).
    ;; Last resort: search the coding system list for entries which
    ;; have the right mime-charset in case the canonical name isn't
    ;; defined (though it should be).

@@ -359,7 +365,7 @@ used as the line break code type of the coding system."
                             default-enable-multibyte-characters
                             (fboundp 'set-buffer-multibyte))
     "Emacs mule.")
                             default-enable-multibyte-characters
                             (fboundp 'set-buffer-multibyte))
     "Emacs mule.")

-  
+

   (defvar mm-mule4-p (and mm-emacs-mule
                          (fboundp 'charsetp)
                          (not (charsetp 'eight-bit-control)))
   (defvar mm-mule4-p (and mm-emacs-mule
                          (fboundp 'charsetp)
                          (not (charsetp 'eight-bit-control)))

@@ -386,7 +392,7 @@ This is a no-op in XEmacs."
 Only used in Emacs Mule 4."
        (set-buffer-multibyte t))
     (defalias 'mm-enable-multibyte-mule4 'ignore))
 Only used in Emacs Mule 4."
        (set-buffer-multibyte t))
     (defalias 'mm-enable-multibyte-mule4 'ignore))

-  
+

   (if mm-mule4-p
       (defun mm-disable-multibyte-mule4 ()
        "Disable multibyte in the current buffer.
   (if mm-mule4-p
       (defun mm-disable-multibyte-mule4 ()
        "Disable multibyte in the current buffer.

@@ -399,6 +405,26 @@ Only used in Emacs Mule 4."
   (or (get-charset-property charset 'preferred-coding-system)
       (get-charset-property charset 'prefered-coding-system)))
 
   (or (get-charset-property charset 'preferred-coding-system)
       (get-charset-property charset 'prefered-coding-system)))
 

+(defsubst mm-guess-charset ()
+  "Guess Mule charset from the language environment."
+  (or
+   mail-parse-mule-charset ;; cached mule-charset
+   (progn
+     (setq mail-parse-mule-charset
+          (and (boundp 'current-language-environment)
+               (car (last
+                     (assq 'charset
+                           (assoc current-language-environment
+                                  language-info-alist))))))
+     (if (or (not mail-parse-mule-charset)
+            (eq mail-parse-mule-charset 'ascii))
+        (setq mail-parse-mule-charset
+              (or (car (last (assq mail-parse-charset
+                                   mm-mime-mule-charset-alist)))
+                  ;; default
+                  'latin-iso8859-1)))
+     mail-parse-mule-charset)))
+

 (defun mm-charset-after (&optional pos)
   "Return charset of a character in current buffer at position POS.
 If POS is nil, it defauls to the current point.
 (defun mm-charset-after (&optional pos)
   "Return charset of a character in current buffer at position POS.
 If POS is nil, it defauls to the current point.

@@ -415,23 +441,7 @@ If the charset is `composition', return the actual one."
        (if (and charset (not (memq charset '(ascii eight-bit-control
                                                    eight-bit-graphic))))
            charset
        (if (and charset (not (memq charset '(ascii eight-bit-control
                                                    eight-bit-graphic))))
            charset

-         (or
-          mail-parse-mule-charset ;; cached mule-charset
-          (progn
-            (setq mail-parse-mule-charset
-                  (and (boundp 'current-language-environment)
-                       (car (last
-                             (assq 'charset
-                                   (assoc current-language-environment
-                                          language-info-alist))))))
-            (if (or (not mail-parse-mule-charset)
-                    (eq mail-parse-mule-charset 'ascii))
-                (setq mail-parse-mule-charset
-                      (or (car (last (assq mail-parse-charset
-                                           mm-mime-mule-charset-alist)))
-                          ;; Fixme: don't fix that!
-                          'latin-iso8859-1)))
-            mail-parse-mule-charset)))))))
+         (mm-guess-charset))))))

 
 (defun mm-mime-charset (charset)
   "Return the MIME charset corresponding to the given Mule CHARSET."
 
 (defun mm-mime-charset (charset)
   "Return the MIME charset corresponding to the given Mule CHARSET."

@@ -459,14 +469,13 @@ If the charset is `composition', return the actual one."
       (setq result (cons head result)))
     (nreverse result)))
 
       (setq result (cons head result)))
     (nreverse result)))
 

-;; It's not clear whether this is supposed to mean the global or local
-;; setting.  I think it's used inconsistently.  -- fx
-(defsubst mm-multibyte-p ()
-  "Say whether multibyte is enabled."
-  (if (and (not (featurep 'xemacs))
-          (boundp 'enable-multibyte-characters))
-      enable-multibyte-characters
-    (featurep 'mule)))
+(if (and (not (featurep 'xemacs))
+        (boundp 'enable-multibyte-characters))
+    (defalias 'mm-multibyte-p
+      (lambda ()
+       "Say whether multibyte is enabled in the current buffer."
+       enable-multibyte-characters))
+  (defalias 'mm-multibyte-p (lambda () (featurep 'mule))))

 
 (defun mm-iso-8859-x-to-15-region (&optional b e)
   (if (fboundp 'char-charset)
 
 (defun mm-iso-8859-x-to-15-region (&optional b e)
   (if (fboundp 'char-charset)

@@ -476,15 +485,15 @@ If the charset is `composition', return the actual one."
          (goto-char (point-min))
          (skip-chars-forward "\0-\177")
          (while (not (eobp))
          (goto-char (point-min))
          (skip-chars-forward "\0-\177")
          (while (not (eobp))

-           (cond 
-            ((not (setq item (assq (char-charset (setq c (char-after))) 
+           (cond
+            ((not (setq item (assq (char-charset (setq c (char-after)))

                                    mm-iso-8859-x-to-15-table)))
              (forward-char))
             ((memq c (cdr (cdr item)))
              (setq inconvertible t)
              (forward-char))
             (t
                                    mm-iso-8859-x-to-15-table)))
              (forward-char))
             ((memq c (cdr (cdr item)))
              (setq inconvertible t)
              (forward-char))
             (t

-             (insert-before-markers (prog1 (+ c (car (cdr item))) 
+             (insert-before-markers (prog1 (+ c (car (cdr item)))

                                       (delete-char 1))))
            (skip-chars-forward "\0-\177"))))
        (not inconvertible))))
                                       (delete-char 1))))
            (skip-chars-forward "\0-\177"))))
        (not inconvertible))))

@@ -500,12 +509,12 @@ charset, and a longer list means no appropriate charset."
   (let (charsets)
     ;; The return possibilities of this function are a mess...
     (or (and (mm-multibyte-p)
   (let (charsets)
     ;; The return possibilities of this function are a mess...
     (or (and (mm-multibyte-p)

-            (fboundp 'find-coding-systems-region)
+            mm-use-find-coding-systems-region

             ;; Find the mime-charset of the most preferred coding
             ;; system that has one.
             (let ((systems (find-coding-systems-region b e)))
               (when mm-coding-system-priorities
             ;; Find the mime-charset of the most preferred coding
             ;; system that has one.
             (let ((systems (find-coding-systems-region b e)))
               (when mm-coding-system-priorities

-                (setq systems 
+                (setq systems

                       (sort systems 'mm-sort-coding-systems-predicate)))
               ;; Fixme: The `mime-charset' (`x-ctext') of `compound-text'
               ;; is not in the IANA list.
                       (sort systems 'mm-sort-coding-systems-predicate)))
               ;; Fixme: The `mime-charset' (`x-ctext') of `compound-text'
               ;; is not in the IANA list.

@@ -519,7 +528,7 @@ charset, and a longer list means no appropriate charset."
               charsets))
        ;; Otherwise we're not multibyte, XEmacs or a single coding
        ;; system won't cover it.
               charsets))
        ;; Otherwise we're not multibyte, XEmacs or a single coding
        ;; system won't cover it.

-       (setq charsets 
+       (setq charsets

              (mm-delete-duplicates
               (mapcar 'mm-mime-charset
                       (delq 'ascii
              (mm-delete-duplicates
               (mapcar 'mm-mime-charset
                       (delq 'ascii

@@ -548,8 +557,8 @@ Also bind `default-enable-multibyte-characters' to nil.
 Equivalent to `progn' in XEmacs"
   (let ((multibyte (make-symbol "multibyte"))
        (buffer (make-symbol "buffer")))
 Equivalent to `progn' in XEmacs"
   (let ((multibyte (make-symbol "multibyte"))
        (buffer (make-symbol "buffer")))

-    `(if mm-emacs-mule 
-        (let ((,multibyte enable-multibyte-characters)
+    `(if mm-emacs-mule
+        (let ((,multibyte enable-multibyte-characters)

               (,buffer (current-buffer)))
           (unwind-protect
               (let (default-enable-multibyte-characters)
               (,buffer (current-buffer)))
           (unwind-protect
               (let (default-enable-multibyte-characters)

@@ -568,7 +577,7 @@ Mule4 only."
   (let ((multibyte (make-symbol "multibyte"))
        (buffer (make-symbol "buffer")))
     `(if mm-mule4-p
   (let ((multibyte (make-symbol "multibyte"))
        (buffer (make-symbol "buffer")))
     `(if mm-mule4-p

-        (let ((,multibyte enable-multibyte-characters)
+        (let ((,multibyte enable-multibyte-characters)

               (,buffer (current-buffer)))
           (unwind-protect
               (let (default-enable-multibyte-characters)
               (,buffer (current-buffer)))
           (unwind-protect
               (let (default-enable-multibyte-characters)

@@ -725,6 +734,70 @@ If INHIBIT is non-nil, inhibit mm-inhibit-file-name-handlers."
          (push dir result))
       (push path result))))
 
          (push dir result))
       (push path result))))
 

+(if (fboundp 'detect-coding-region)
+    (defun mm-detect-coding-region (start end)
+      "Like 'detect-coding-region' except returning the best one."
+      (let ((coding-systems
+            (detect-coding-region (point) (point-max))))
+       (or (car-safe coding-systems)
+           coding-systems)))
+  (defun mm-detect-coding-region (start end)
+    (let ((point (point)))
+      (goto-char start)
+      (skip-chars-forward "\0-\177" end)
+      (prog1
+         (if (eq (point) end) 'ascii (mm-guess-charset))
+       (goto-char point)))))
+
+(if (fboundp 'coding-system-get)
+    (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)))
+  (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-guess-mime-charset ()
+  "Guess the default MIME charset from the language environment."
+  (let ((language-info
+        (and (boundp 'current-language-environment)
+             (assoc current-language-environment
+                    language-info-alist)))
+       item)
+    (cond
+     ((null language-info)
+      'iso-8859-1)
+     ((setq item
+           (cadr
+            (or (assq 'coding-priority language-info)
+                (assq 'coding-system language-info))))
+      (if (fboundp 'coding-system-get)
+         (or (coding-system-get item 'mime-charset)
+             item)
+       item))
+     ((setq item (car (last (assq 'charset language-info))))
+      (if (eq item 'ascii)
+         'iso-8859-1
+       (mm-mime-charset item)))
+     (t
+      'iso-8859-1))))
+
+;; It is not a MIME function, but some MIME functions use it.
+(defalias 'mm-make-temp-file
+  (if (fboundp 'make-temp-file)
+      'make-temp-file
+    (lambda (prefix &optional dir-flag)
+      (let ((file (expand-file-name
+                  (make-temp-name prefix)
+                  (if (fboundp 'temp-directory)
+                      (temp-directory)
+                    temporary-file-directory))))
+       (if dir-flag
+           (make-directory file))
+       file))))
+

 (provide 'mm-util)
 
 ;;; mm-util.el ends here
 (provide 'mm-util)
 
 ;;; mm-util.el ends here