Importing Pterodactyl Gnus v0.95.

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

diff --git a/lisp/mm-util.el b/lisp/mm-util.el
index e0d8920..a8e8f8b 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,11 +24,18 @@
 
 ;;; Code:
 
 
 ;;; Code:
 

-(defvar mm-default-coding-system nil
-  "The default coding system to use.")  
+(defconst mm-running-xemacs (string-match "XEmacs" emacs-version))

 
 

-(defvar mm-known-charsets '(iso-8859-1)
-  "List of known charsets.")
+(defconst mm-binary-coding-system
+  (if mm-running-xemacs
+      'binary 'no-conversion)
+  "100% binary coding system.")
+
+(defconst mm-text-coding-system
+  (and (fboundp 'coding-system-list)
+   (if (memq system-type '(windows-nt ms-dos ms-windows))
+       'raw-text-dos 'raw-text))
+  "Text-safe coding system (For removing ^M).")

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

@@ -42,15 +49,19 @@
     (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)

-    (iso-2022-jp latin-jisx0201
-                japanese-jisx0208-1978 japanese-jisx0208)
+    (viscii vietnamese-viscii-lower)
+    (iso-2022-jp latin-jisx0201 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

@@ -101,20 +112,27 @@
   (or mm-coding-system-list
       (setq mm-coding-system-list (mm-coding-system-list))))
 
   (or mm-coding-system-list
       (setq mm-coding-system-list (mm-coding-system-list))))
 

-(defvar mm-charset-coding-system-alist
-  (let ((rest
-        '((gb2312 . cn-gb-2312)
-          (iso-2022-jp-2 . iso-2022-7bit-ss2)
-          (x-ctext . ctext)))
-       (systems (mm-get-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-charset-synonym-alist
+  '((big5 . cn-big5)
+    (gb2312 . cn-gb-2312)
+    (x-ctext . ctext))
+  "A mapping from invalid charset names to the real charset names.")
+
+(defconst mm-auto-save-coding-system
+  (cond 
+   ((memq 'emacs-mule (mm-get-coding-system-list))
+    (if (memq system-type '(windows-nt ms-dos ms-windows))
+       'emacs-mule-dos 'emacs-mule))
+   ((memq 'escape-quoted (mm-get-coding-system-list))
+    'escape-quoted)
+   ((memq 'no-conversion (mm-get-coding-system-list))
+    'no-conversion)
+   (t nil))
+  "Coding system of auto save file.")
+
+;;; 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."

@@ -135,14 +153,13 @@ 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-get-coding-system-list))
-        (memq charset mm-known-charsets))
+   ((null (mm-get-coding-system-list))

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

@@ -169,6 +186,7 @@ used as the line break code type of the coding system."
 (defsubst mm-enable-multibyte ()
   "Enable multibyte in the current buffer."
   (when (and (fboundp 'set-buffer-multibyte)
 (defsubst mm-enable-multibyte ()
   "Enable multibyte in the current buffer."
   (when (and (fboundp 'set-buffer-multibyte)

+             (boundp 'enable-multibyte-characters)

             (default-value 'enable-multibyte-characters))
     (set-buffer-multibyte t)))
 
             (default-value 'enable-multibyte-characters))
     (set-buffer-multibyte t)))
 

@@ -177,22 +195,36 @@ used as the line break code type of the coding system."
   (when (fboundp 'set-buffer-multibyte)
     (set-buffer-multibyte nil)))
 
   (when (fboundp 'set-buffer-multibyte)
     (set-buffer-multibyte nil)))
 

-(defun mm-mime-charset (charset b e)
+(defun mm-preferred-coding-system (charset)
+  ;; A typo in some Emacs versions.
+  (or (get-charset-property charset 'prefered-coding-system)
+      (get-charset-property charset 'preffered-coding-system)))
+
+(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

-       (and
-       mm-default-coding-system
-       (let ((safe (coding-system-get mm-default-coding-system
-                                      'safe-charsets)))
-         (or (eq safe t) (memq charset safe)))
-       (coding-system-get mm-default-coding-system 'mime-charset))
-       (coding-system-get
-       (get-charset-property charset 'prefered-coding-system)
-       'mime-charset)
-       (car (memq charset (find-coding-systems-region
-                          (point-min) (point-max)))))
+       (and (mm-preferred-coding-system charset)
+           (coding-system-get
+            (mm-preferred-coding-system charset) 'mime-charset))
+       (and (eq charset 'ascii)
+           'us-ascii)
+       (mm-preferred-coding-system charset)
+       (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)))))
+    (when (memq 'iso-2022-jp-2 charsets)
+      (setq charsets (delq 'iso-2022-jp charsets)))
+    (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)

@@ -214,7 +246,9 @@ See also `with-temp-file' and `with-output-to-string'."
                     (get-buffer-create (generate-new-buffer-name " *temp*")))
               (unwind-protect
                   (with-current-buffer ,temp-buffer
                     (get-buffer-create (generate-new-buffer-name " *temp*")))
               (unwind-protect
                   (with-current-buffer ,temp-buffer

-                    (let (buffer-file-coding-system)
+                    (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))))
                       ,@forms))
                 (and (buffer-name ,temp-buffer)
                      (kill-buffer ,temp-buffer))))

@@ -224,9 +258,21 @@ See also `with-temp-file' and `with-output-to-string'."
 
 (defun mm-find-charset-region (b e)
   "Return a list of charsets in the region."
 
 (defun mm-find-charset-region (b e)
   "Return a list of charsets in the region."

-  (if (and (boundp 'enable-multibyte-characters)
-          enable-multibyte-characters)
-      (find-charset-region b e)
+  (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
     ;; We are in a unibyte buffer, so we futz around a bit.
     (save-excursion
       (save-restriction

@@ -237,7 +283,54 @@ See also `with-temp-file' and `with-output-to-string'."
          (skip-chars-forward "\0-\177")
          (if (eobp)
              '(ascii)
          (skip-chars-forward "\0-\177")
          (if (eobp)
              '(ascii)

-           (list 'ascii (car (last (assq 'charset entry))))))))))
+           (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)))
+
+(defun mm-quote-arg (arg)
+  "Return a version of ARG that is safe to evaluate in a shell."
+  (let ((pos 0) new-pos accum)
+    ;; *** bug: we don't handle newline characters properly
+    (while (setq new-pos (string-match "[]*[;!'`\"$\\& \t{} |()<>]" arg pos))
+      (push (substring arg pos new-pos) accum)
+      (push "\\" accum)
+      (push (list (aref arg new-pos)) accum)
+      (setq pos (1+ new-pos)))
+    (if (= pos 0)
+        arg
+      (apply 'concat (nconc (nreverse accum) (list (substring arg pos)))))))
+
+(defun mm-auto-mode-alist ()
+  "Return an `auto-mode-alist' with only the .gz (etc) thingies."
+  (let ((alist auto-mode-alist)
+       out)
+    (while alist
+      (when (listp (cdar alist))
+       (push (car alist) out))
+      (pop alist))
+    (nreverse out)))
+
+(defun mm-insert-file-contents (filename &optional visit beg end replace)
+  "Like `insert-file-contents', q.v., but only reads in the file.
+A buffer may be modified in several ways after reading into the buffer due
+to advanced Emacs features, such as file-name-handlers, format decoding,
+find-file-hooks, etc.
+  This function ensures that none of these modifications will take place."
+  (let ((format-alist nil)
+       (auto-mode-alist (mm-auto-mode-alist))
+       (default-major-mode 'fundamental-mode)
+       (enable-local-variables nil)
+        (after-insert-file-functions nil)
+       (enable-local-eval nil)
+       (find-file-hooks nil))
+    (insert-file-contents filename visit beg end replace)))

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