1 ;;; mm-util.el --- Utility functions for MIME things
2 ;; Copyright (C) 1998,99 Free Software Foundation, Inc.
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5 ;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;; This file is part of GNU Emacs.
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)
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.
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.
27 (defvar mm-running-xemacs (string-match "XEmacs" emacs-version))
29 (defvar mm-running-ntemacs
30 (and (not mm-running-xemacs)
31 (string-match "nt" system-configuration)))
33 (defvar mm-binary-coding-system
35 'binary 'no-conversion)
36 "100% binary coding system.")
38 (defvar mm-text-coding-system
40 ((not (fboundp 'coding-system-p)) nil)
41 (mm-running-xemacs ;; XEmacs
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
47 "100% text coding system, for removing ^M.")
49 (defvar mm-mime-mule-charset-alist
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)
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
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
90 "Alist of MIME-charset/MULE-charsets.")
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)
111 . (lambda (charset int)
115 "Prompt the user for a coding system."
117 prompt (mapcar (lambda (s) (list (symbol-name (car s))))
118 mm-mime-mule-charset-alist)))))))
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))))
126 (defvar mm-charset-synonym-alist
128 (gb2312 . cn-gb-2312)
129 (iso-2022-jp-2 . iso-2022-7bit-ss2)
131 "A mapping from invalid charset names to the real charset names.")
133 ;;; Internal variables:
137 (defun mm-mule-charset-to-mime-charset (charset)
138 "Return the MIME charset corresponding to MULE CHARSET."
139 (let ((alist mm-mime-mule-charset-alist)
142 (when (memq charset (cdar alist))
143 (setq out (caar alist)
148 (defun mm-charset-to-coding-system (charset &optional lbt)
149 "Return coding-system corresponding to CHARSET.
150 CHARSET is a symbol naming a MIME charset.
151 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
152 used as the line break code type of the coding system."
153 (when (stringp charset)
154 (setq charset (intern (downcase charset))))
156 (or (cdr (assq charset mm-charset-synonym-alist))
159 (setq charset (intern (format "%s-%s" charset lbt))))
161 ;; Running in a non-MULE environment.
162 ((null (mm-get-coding-system-list))
165 ((eq charset 'us-ascii)
167 ;; Check to see whether we can handle this charset.
168 ((memq charset (mm-get-coding-system-list))
174 (defun mm-replace-chars-in-string (string from to)
175 "Replace characters in STRING from FROM to TO."
176 (let ((string (substring string 0)) ;Copy string.
177 (len (length string))
179 ;; Replace all occurrences of FROM with TO.
181 (when (= (aref string idx) from)
182 (aset string idx to))
186 (defsubst mm-enable-multibyte ()
187 "Enable multibyte in the current buffer."
188 (when (and (fboundp 'set-buffer-multibyte)
189 (default-value 'enable-multibyte-characters))
190 (set-buffer-multibyte t)))
192 (defsubst mm-disable-multibyte ()
193 "Disable multibyte in the current buffer."
194 (when (fboundp 'set-buffer-multibyte)
195 (set-buffer-multibyte nil)))
197 (defun mm-mime-charset (charset)
198 "Return the MIME charset corresponding to the MULE CHARSET."
199 (if (fboundp 'coding-system-get)
200 ;; This exists in Emacs 20.
202 (and (get-charset-property charset 'prefered-coding-system)
204 (get-charset-property charset 'prefered-coding-system)
206 (and (eq charset 'ascii)
208 (get-charset-property charset 'prefered-coding-system)
209 (mm-mule-charset-to-mime-charset charset))
210 ;; This is for XEmacs.
211 (mm-mule-charset-to-mime-charset charset)))
213 (defun mm-find-mime-charset-region (b e)
214 "Return the MIME charsets needed to encode the region between B and E."
216 (mapcar 'mm-mime-charset
218 (mm-find-charset-region b e)))))
219 (delete-duplicates charsets)))
221 (defsubst mm-multibyte-p ()
222 "Say whether multibyte is enabled."
223 (and (boundp 'enable-multibyte-characters)
224 enable-multibyte-characters))
226 (defmacro mm-with-unibyte-buffer (&rest forms)
227 "Create a temporary buffer, and evaluate FORMS there like `progn'.
228 See also `with-temp-file' and `with-output-to-string'."
229 (let ((temp-buffer (make-symbol "temp-buffer"))
230 (multibyte (make-symbol "multibyte")))
231 `(if (not (boundp 'enable-multibyte-characters))
232 (with-temp-buffer ,@forms)
233 (let ((,multibyte (default-value 'enable-multibyte-characters))
237 (setq-default enable-multibyte-characters nil)
239 (get-buffer-create (generate-new-buffer-name " *temp*")))
241 (with-current-buffer ,temp-buffer
242 (let ((buffer-file-coding-system mm-binary-coding-system)
243 (coding-system-for-read mm-binary-coding-system)
244 (coding-system-for-write mm-binary-coding-system))
246 (and (buffer-name ,temp-buffer)
247 (kill-buffer ,temp-buffer))))
248 (setq-default enable-multibyte-characters ,multibyte))))))
249 (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
250 (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
252 (defun mm-find-charset-region (b e)
253 "Return a list of charsets in the region."
255 ((and (boundp 'enable-multibyte-characters)
256 enable-multibyte-characters
257 (fboundp 'find-charset-region))
258 (find-charset-region b e))
259 ((not (boundp 'current-language-environment))
262 (narrow-to-region b e)
263 (goto-char (point-min))
264 (skip-chars-forward "\0-\177")
267 (delq nil (list 'ascii mail-parse-charset))))))
269 ;; We are in a unibyte buffer, so we futz around a bit.
272 (narrow-to-region b e)
273 (goto-char (point-min))
274 (let ((entry (assoc (capitalize current-language-environment)
275 language-info-alist)))
276 (skip-chars-forward "\0-\177")
279 (list 'ascii (car (last (assq 'charset entry)))))))))))
281 (defun mm-read-charset (prompt)
286 (mapcar (lambda (e) (list (symbol-name (car e))))
287 mm-mime-mule-charset-alist)
292 ;;; mm-util.el ends here