Sync up with Pterodactyl Gnus 0.40.
[elisp/gnus.git-] / lisp / mm-util.el
1 ;;; mm-util.el --- Utility functions for MIME things
2 ;; Copyright (C) 1998 Free Software Foundation, Inc.
3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;; This file is part of GNU Emacs.
7
8 ;; GNU Emacs is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation; either version 2, or (at your option)
11 ;; any later version.
12
13 ;; GNU Emacs is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;; GNU General Public License for more details.
17
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 ;; Boston, MA 02111-1307, USA.
22
23 ;;; Commentary:
24
25 ;;; Code:
26
27 (defvar mm-default-coding-system nil
28   "The default coding system to use.")  
29
30 (defvar mm-known-charsets '(iso-8859-1)
31   "List of known charsets.")
32
33 (defvar mm-mime-mule-charset-alist
34   '((us-ascii ascii)
35     (iso-8859-1 latin-iso8859-1)
36     (iso-8859-2 latin-iso8859-2)
37     (iso-8859-3 latin-iso8859-3)
38     (iso-8859-4 latin-iso8859-4)
39     (iso-8859-5 cyrillic-iso8859-5)
40     (koi8-r cyrillic-iso8859-5)
41     (iso-8859-6 arabic-iso8859-6)
42     (iso-8859-7 greek-iso8859-7)
43     (iso-8859-8 hebrew-iso8859-8)
44     (iso-8859-9 latin-iso8859-9)
45     (iso-2022-jp latin-jisx0201
46                  japanese-jisx0208-1978 japanese-jisx0208)
47     (euc-kr korean-ksc5601)
48     (cn-gb-2312 chinese-gb2312)
49     (cn-big5 chinese-big5-1 chinese-big5-2)
50     (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
51                    latin-jisx0201 japanese-jisx0208-1978
52                    chinese-gb2312 japanese-jisx0208
53                    korean-ksc5601 japanese-jisx0212)
54     (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
55                     latin-jisx0201 japanese-jisx0208-1978
56                     chinese-gb2312 japanese-jisx0208
57                     korean-ksc5601 japanese-jisx0212
58                     chinese-cns11643-1 chinese-cns11643-2)
59     (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
60                     cyrillic-iso8859-5 greek-iso8859-7
61                     latin-jisx0201 japanese-jisx0208-1978
62                     chinese-gb2312 japanese-jisx0208
63                     korean-ksc5601 japanese-jisx0212
64                     chinese-cns11643-1 chinese-cns11643-2
65                     chinese-cns11643-3 chinese-cns11643-4
66                     chinese-cns11643-5 chinese-cns11643-6
67                     chinese-cns11643-7))
68   "Alist of MIME-charset/MULE-charsets.")
69
70
71 (eval-and-compile
72   (mapcar
73    (lambda (elem)
74      (let ((nfunc (intern (format "mm-%s" (car elem)))))
75        (if (fboundp (car elem))
76            (fset nfunc (car elem))
77          (fset nfunc (cdr elem)))))
78    '((decode-coding-string . (lambda (s a) s))
79      (encode-coding-string . (lambda (s a) s))
80      (encode-coding-region . ignore)
81      (coding-system-list . ignore)
82      (decode-coding-region . ignore)
83      (char-int . identity)
84      (device-type . ignore)
85      (coding-system-equal . equal)
86      (annotationp . ignore)
87      (set-buffer-file-coding-system . ignore)
88      (make-char
89       . (lambda (charset int)
90           (int-to-char int)))
91      (read-coding-system
92       . (lambda (prompt)
93           "Prompt the user for a coding system."
94           (completing-read
95            prompt (mapcar (lambda (s) (list (symbol-name (car s))))
96                           mm-mime-mule-charset-alist)))))))
97
98 (defvar mm-coding-system-list nil)
99 (defun mm-get-coding-system-list ()
100   "Get the coding system list."
101   (or mm-coding-system-list
102       (setq mm-coding-system-list (mm-coding-system-list))))
103
104 (defvar mm-charset-coding-system-alist
105   (let ((rest
106          '((gb2312 . cn-gb-2312)
107            (iso-2022-jp-2 . iso-2022-7bit-ss2)
108            (x-ctext . ctext)))
109         (systems (mm-get-coding-system-list))
110         dest)
111     (while rest
112       (let ((pair (car rest)))
113         (unless (memq (car pair) systems)
114           (setq dest (cons pair dest))))
115       (setq rest (cdr rest)))
116     dest)
117   "Charset/coding system alist.")
118
119 (defun mm-mule-charset-to-mime-charset (charset)
120   "Return the MIME charset corresponding to MULE CHARSET."
121   (let ((alist mm-mime-mule-charset-alist)
122         out)
123     (while alist
124       (when (memq charset (cdar alist))
125         (setq out (caar alist)
126               alist nil))
127       (pop alist))
128     out))
129
130 (defun mm-charset-to-coding-system (charset &optional lbt)
131   "Return coding-system corresponding to CHARSET.
132 CHARSET is a symbol naming a MIME charset.
133 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
134 used as the line break code type of the coding system."
135   (when (stringp charset)
136     (setq charset (intern (downcase charset))))
137   (setq charset
138         (or (cdr (assq charset mm-charset-coding-system-alist))
139             charset))
140   (when lbt
141     (setq charset (intern (format "%s-%s" charset lbt))))
142   (cond
143    ;; Running in a non-MULE environment.
144    ((and (null (mm-get-coding-system-list))
145          (memq charset mm-known-charsets))
146     charset)
147    ;; ascii
148    ((eq charset 'us-ascii)
149     'ascii)
150    ;; Check to see whether we can handle this charset.
151    ((memq charset (mm-get-coding-system-list))
152     charset)
153    ;; Nope.
154    (t
155     nil)))
156
157 (defun mm-replace-chars-in-string (string from to)
158   "Replace characters in STRING from FROM to TO."
159   (let ((string (substring string 0))   ;Copy string.
160         (len (length string))
161         (idx 0))
162     ;; Replace all occurrences of FROM with TO.
163     (while (< idx len)
164       (when (= (aref string idx) from)
165         (aset string idx to))
166       (setq idx (1+ idx)))
167     string))
168
169 (defsubst mm-enable-multibyte ()
170   "Enable multibyte in the current buffer."
171   (when (and (fboundp 'set-buffer-multibyte)
172              (default-value enable-multibyte-characters))
173     (set-buffer-multibyte t)))
174
175 (defsubst mm-disable-multibyte ()
176   "Disable multibyte in the current buffer."
177   (when (fboundp 'set-buffer-multibyte)
178     (set-buffer-multibyte nil)))
179
180 (defun mm-mime-charset (charset b e)
181   (if (fboundp 'coding-system-get)
182       (or
183        (and
184         mm-default-coding-system
185         (let ((safe (coding-system-get mm-default-coding-system
186                                        'safe-charsets)))
187           (or (eq safe t) (memq charset safe)))
188         (coding-system-get mm-default-coding-system 'mime-charset))
189        (coding-system-get
190         (get-charset-property charset 'prefered-coding-system)
191         'mime-charset)
192        (car (memq charset (find-coding-systems-region
193                            (point-min) (point-max)))))
194     (mm-mule-charset-to-mime-charset charset)))
195
196 (defsubst mm-multibyte-p ()
197   "Say whether multibyte is enabled."
198   (and (boundp 'enable-multibyte-characters)
199        enable-multibyte-characters))
200
201 (defmacro mm-with-unibyte-buffer (&rest forms)
202   "Create a temporary buffer, and evaluate FORMS there like `progn'.
203 See also `with-temp-file' and `with-output-to-string'."
204   (let ((temp-buffer (make-symbol "temp-buffer"))
205         (multibyte (make-symbol "multibyte")))
206     `(if (not (boundp 'enable-multibyte-characters))
207          (with-temp-buffer ,@forms)
208        (let ((,multibyte (default-value enable-multibyte-characters))
209              ,temp-buffer)
210          (unwind-protect
211              (progn
212                (setq-default enable-multibyte-characters nil)
213                (setq ,temp-buffer
214                      (get-buffer-create (generate-new-buffer-name " *temp*")))
215                (unwind-protect
216                    (with-current-buffer ,temp-buffer
217                      (let (buffer-file-coding-system)
218                        ,@forms))
219                  (and (buffer-name ,temp-buffer)
220                       (kill-buffer ,temp-buffer))))
221            (setq-default enable-multibyte-characters ,multibyte))))))
222 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
223 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
224
225 (provide 'mm-util)
226
227 ;;; mm-util.el ends here