Sync up with Pterodactyl Gnus v0.83.
[elisp/gnus.git-] / lisp / mm-util.el
1 ;;; mm-util.el --- Utility functions for MIME things
2 ;; Copyright (C) 1998,99 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-running-xemacs (string-match "XEmacs" emacs-version))
28
29 (defvar mm-running-ntemacs
30   (and (not mm-running-xemacs)
31        (string-match "nt" system-configuration)))
32
33 (defvar mm-binary-coding-system
34   (if mm-running-xemacs
35       'binary 'no-conversion)
36   "100% binary coding system.")
37
38 (defvar mm-text-coding-system
39   (cond
40    ((not (fboundp 'coding-system-p)) nil)
41    (mm-running-xemacs  ;; XEmacs
42     'no-conversion)
43    (mm-running-ntemacs ;; NTEmacs
44     (and (coding-system-p 'raw-text-dos) 'raw-text-dos))
45    ((coding-system-p 'raw-text) 'raw-text) ;; Emacs
46    (t nil))
47   "100% text coding system, for removing ^M.")
48
49 (defvar mm-mime-mule-charset-alist
50   '((us-ascii ascii)
51     (iso-8859-1 latin-iso8859-1)
52     (iso-8859-2 latin-iso8859-2)
53     (iso-8859-3 latin-iso8859-3)
54     (iso-8859-4 latin-iso8859-4)
55     (iso-8859-5 cyrillic-iso8859-5)
56     (koi8-r cyrillic-iso8859-5)
57     (iso-8859-6 arabic-iso8859-6)
58     (iso-8859-7 greek-iso8859-7)
59     (iso-8859-8 hebrew-iso8859-8)
60     (iso-8859-9 latin-iso8859-9)
61     (viscii vietnamese-viscii-lower)
62     (iso-2022-jp-2 japanese-jisx0208)
63     (iso-2022-jp latin-jisx0201
64                  japanese-jisx0208-1978)
65     (euc-kr korean-ksc5601)
66     (cn-gb-2312 chinese-gb2312)
67     (cn-big5 chinese-big5-1 chinese-big5-2)
68     (tibetan tibetan)
69     (thai-tis620 thai-tis620)
70     (iso-2022-7bit ethiopic arabic-1-column arabic-2-column)
71     (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
72                    latin-jisx0201 japanese-jisx0208-1978
73                    chinese-gb2312 japanese-jisx0208
74                    korean-ksc5601 japanese-jisx0212
75                    katakana-jisx0201)
76     (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
77                     latin-jisx0201 japanese-jisx0208-1978
78                     chinese-gb2312 japanese-jisx0208
79                     korean-ksc5601 japanese-jisx0212
80                     chinese-cns11643-1 chinese-cns11643-2)
81     (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
82                     cyrillic-iso8859-5 greek-iso8859-7
83                     latin-jisx0201 japanese-jisx0208-1978
84                     chinese-gb2312 japanese-jisx0208
85                     korean-ksc5601 japanese-jisx0212
86                     chinese-cns11643-1 chinese-cns11643-2
87                     chinese-cns11643-3 chinese-cns11643-4
88                     chinese-cns11643-5 chinese-cns11643-6
89                     chinese-cns11643-7))
90   "Alist of MIME-charset/MULE-charsets.")
91
92
93 (eval-and-compile
94   (mapcar
95    (lambda (elem)
96      (let ((nfunc (intern (format "mm-%s" (car elem)))))
97        (if (fboundp (car elem))
98            (fset nfunc (car elem))
99          (fset nfunc (cdr elem)))))
100    '((decode-coding-string . (lambda (s a) s))
101      (encode-coding-string . (lambda (s a) s))
102      (encode-coding-region . ignore)
103      (coding-system-list . ignore)
104      (decode-coding-region . ignore)
105      (char-int . identity)
106      (device-type . ignore)
107      (coding-system-equal . equal)
108      (annotationp . ignore)
109      (set-buffer-file-coding-system . ignore)
110      (make-char
111       . (lambda (charset int)
112           (int-to-char int)))
113      (read-coding-system
114       . (lambda (prompt)
115           "Prompt the user for a coding system."
116           (completing-read
117            prompt (mapcar (lambda (s) (list (symbol-name (car s))))
118                           mm-mime-mule-charset-alist)))))))
119
120 (defvar mm-coding-system-list nil)
121 (defun mm-get-coding-system-list ()
122   "Get the coding system list."
123   (or mm-coding-system-list
124       (setq mm-coding-system-list (mm-coding-system-list))))
125
126 (defvar mm-charset-synonym-alist
127   '((big5 . cn-big5)
128     (gb2312 . cn-gb-2312)
129     (x-ctext . ctext))
130   "A mapping from invalid charset names to the real charset names.")
131
132 ;;; Internal variables:
133
134 ;;; Functions:
135
136 (defun mm-mule-charset-to-mime-charset (charset)
137   "Return the MIME charset corresponding to MULE CHARSET."
138   (let ((alist mm-mime-mule-charset-alist)
139         out)
140     (while alist
141       (when (memq charset (cdar alist))
142         (setq out (caar alist)
143               alist nil))
144       (pop alist))
145     out))
146
147 (defun mm-charset-to-coding-system (charset &optional lbt)
148   "Return coding-system corresponding to CHARSET.
149 CHARSET is a symbol naming a MIME charset.
150 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
151 used as the line break code type of the coding system."
152   (when (stringp charset)
153     (setq charset (intern (downcase charset))))
154   (setq charset
155         (or (cdr (assq charset mm-charset-synonym-alist))
156             charset))
157   (when lbt
158     (setq charset (intern (format "%s-%s" charset lbt))))
159   (cond
160    ;; Running in a non-MULE environment.
161    ((null (mm-get-coding-system-list))
162     charset)
163    ;; ascii
164    ((eq charset 'us-ascii)
165     'ascii)
166    ;; Check to see whether we can handle this charset.
167    ((memq charset (mm-get-coding-system-list))
168     charset)
169    ;; Nope.
170    (t
171     nil)))
172
173 (defun mm-replace-chars-in-string (string from to)
174   "Replace characters in STRING from FROM to TO."
175   (let ((string (substring string 0))   ;Copy string.
176         (len (length string))
177         (idx 0))
178     ;; Replace all occurrences of FROM with TO.
179     (while (< idx len)
180       (when (= (aref string idx) from)
181         (aset string idx to))
182       (setq idx (1+ idx)))
183     string))
184
185 (defsubst mm-enable-multibyte ()
186   "Enable multibyte in the current buffer."
187   (when (and (fboundp 'set-buffer-multibyte)
188              (default-value 'enable-multibyte-characters))
189     (set-buffer-multibyte t)))
190
191 (defsubst mm-disable-multibyte ()
192   "Disable multibyte in the current buffer."
193   (when (fboundp 'set-buffer-multibyte)
194     (set-buffer-multibyte nil)))
195
196 (defun mm-mime-charset (charset)
197   "Return the MIME charset corresponding to the MULE CHARSET."
198   (if (fboundp 'coding-system-get)
199       ;; This exists in Emacs 20.
200       (or
201        (and (get-charset-property charset 'prefered-coding-system)
202             (coding-system-get
203              (get-charset-property charset 'prefered-coding-system)
204              'mime-charset))
205        (and (eq charset 'ascii)
206             'us-ascii)
207        (get-charset-property charset 'prefered-coding-system)
208        (mm-mule-charset-to-mime-charset charset))
209     ;; This is for XEmacs.
210     (mm-mule-charset-to-mime-charset charset)))
211
212 (defun mm-find-mime-charset-region (b e)
213   "Return the MIME charsets needed to encode the region between B and E."
214   (let ((charsets
215          (mapcar 'mm-mime-charset
216                  (delq 'ascii
217                        (mm-find-charset-region b e)))))
218     (delete-duplicates charsets)))
219
220 (defsubst mm-multibyte-p ()
221   "Say whether multibyte is enabled."
222   (and (boundp 'enable-multibyte-characters)
223        enable-multibyte-characters))
224
225 (defmacro mm-with-unibyte-buffer (&rest forms)
226   "Create a temporary buffer, and evaluate FORMS there like `progn'.
227 See also `with-temp-file' and `with-output-to-string'."
228   (let ((temp-buffer (make-symbol "temp-buffer"))
229         (multibyte (make-symbol "multibyte")))
230     `(if (not (boundp 'enable-multibyte-characters))
231          (with-temp-buffer ,@forms)
232        (let ((,multibyte (default-value 'enable-multibyte-characters))
233              ,temp-buffer)
234          (unwind-protect
235              (progn
236                (setq-default enable-multibyte-characters nil)
237                (setq ,temp-buffer
238                      (get-buffer-create (generate-new-buffer-name " *temp*")))
239                (unwind-protect
240                    (with-current-buffer ,temp-buffer
241                      (let ((buffer-file-coding-system mm-binary-coding-system)
242                            (coding-system-for-read mm-binary-coding-system)
243                            (coding-system-for-write mm-binary-coding-system))
244                        ,@forms))
245                  (and (buffer-name ,temp-buffer)
246                       (kill-buffer ,temp-buffer))))
247            (setq-default enable-multibyte-characters ,multibyte))))))
248 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
249 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
250
251 (defun mm-find-charset-region (b e)
252   "Return a list of charsets in the region."
253   (cond
254    ((and (boundp 'enable-multibyte-characters)
255          enable-multibyte-characters
256          (fboundp 'find-charset-region))
257     (find-charset-region b e))
258    ((not (boundp 'current-language-environment))
259     (save-excursion
260       (save-restriction
261         (narrow-to-region b e)
262         (goto-char (point-min))
263         (skip-chars-forward "\0-\177")
264         (if (eobp)
265             '(ascii)
266           (delq nil (list 'ascii mail-parse-charset))))))
267    (t
268     ;; We are in a unibyte buffer, so we futz around a bit.
269     (save-excursion
270       (save-restriction
271         (narrow-to-region b e)
272         (goto-char (point-min))
273         (let ((entry (assoc (capitalize current-language-environment)
274                             language-info-alist)))
275           (skip-chars-forward "\0-\177")
276           (if (eobp)
277               '(ascii)
278             (list 'ascii (car (last (assq 'charset entry)))))))))))
279
280 (defun mm-read-charset (prompt)
281   "Return a charset."
282   (intern
283    (completing-read
284     prompt
285     (mapcar (lambda (e) (list (symbol-name (car e))))
286             mm-mime-mule-charset-alist)
287     nil t)))
288
289 (provide 'mm-util)
290
291 ;;; mm-util.el ends here