Sync up with Pterodactyl Gnus 0.22.
[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-known-charsets '(iso-8859-1)
28   "List of known charsets.")
29
30 (defvar mm-mime-mule-charset-alist
31   '((us-ascii ascii)
32     (iso-8859-1 latin-iso8859-1)
33     (iso-8859-2 latin-iso8859-2)
34     (iso-8859-3 latin-iso8859-3)
35     (iso-8859-4 latin-iso8859-4)
36     (iso-8859-5 cyrillic-iso8859-5)
37     (koi8-r cyrillic-iso8859-5)
38     (iso-8859-6 arabic-iso8859-6)
39     (iso-8859-7 greek-iso8859-7)
40     (iso-8859-8 hebrew-iso8859-8)
41     (iso-8859-9 latin-iso8859-9)
42     (iso-2022-jp latin-jisx0201
43                  japanese-jisx0208-1978 japanese-jisx0208)
44     (euc-kr korean-ksc5601)
45     (cn-gb-2312 chinese-gb2312)
46     (cn-big5 chinese-big5-1 chinese-big5-2)
47     (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
48                    latin-jisx0201 japanese-jisx0208-1978
49                    chinese-gb2312 japanese-jisx0208
50                    korean-ksc5601 japanese-jisx0212)
51     (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
52                     latin-jisx0201 japanese-jisx0208-1978
53                     chinese-gb2312 japanese-jisx0208
54                     korean-ksc5601 japanese-jisx0212
55                     chinese-cns11643-1 chinese-cns11643-2)
56     (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
57                     cyrillic-iso8859-5 greek-iso8859-7
58                     latin-jisx0201 japanese-jisx0208-1978
59                     chinese-gb2312 japanese-jisx0208
60                     korean-ksc5601 japanese-jisx0212
61                     chinese-cns11643-1 chinese-cns11643-2
62                     chinese-cns11643-3 chinese-cns11643-4
63                     chinese-cns11643-5 chinese-cns11643-6
64                     chinese-cns11643-7))
65   "Alist of MIME-charset/MULE-charsets.")
66
67
68 (eval-and-compile
69   (if (fboundp 'decode-coding-string)
70       (fset 'mm-decode-coding-string 'decode-coding-string)
71     (fset 'mm-decode-coding-string (lambda (s a) s)))
72
73   (if (fboundp 'encode-coding-string)
74       (fset 'mm-encode-coding-string 'encode-coding-string)
75     (fset 'mm-encode-coding-string (lambda (s a) s)))
76
77   (if (fboundp 'encode-coding-region)
78       (fset 'mm-encode-coding-region 'encode-coding-region)
79     (fset 'mm-encode-coding-region 'ignore))
80
81   (if (fboundp 'decode-coding-region)
82       (fset 'mm-decode-coding-region 'decode-coding-region)
83     (fset 'mm-decode-coding-region 'ignore))
84
85   (if (fboundp 'coding-system-list)
86       (fset 'mm-coding-system-list 'coding-system-list)
87     (fset 'mm-coding-system-list 'ignore))
88
89   (if (fboundp 'char-int)
90       (fset 'mm-char-int 'char-int)
91     (fset 'mm-char-int 'identity))
92
93   (if (fboundp 'coding-system-equal)
94       (fset 'mm-coding-system-equal 'coding-system-equal)
95     (fset 'mm-coding-system-equal 'equal))
96
97   (if (fboundp 'read-coding-system)
98       (fset 'mm-read-coding-system 'read-coding-system)
99     (defun mm-read-coding-system (prompt)
100       "Prompt the user for a coding system."
101       (completing-read
102        prompt (mapcar (lambda (s) (list (symbol-name (car s))))
103                       mm-mime-mule-charset-alist)))))
104
105
106 (defvar mm-charset-coding-system-alist
107   (let ((rest
108          '((us-ascii . iso-8859-1)
109            (gb2312 . cn-gb-2312)
110            (iso-2022-jp-2 . iso-2022-7bit-ss2)
111            (x-ctext . ctext)))
112         (systems (mm-coding-system-list))
113         dest)
114     (while rest
115       (let ((pair (car rest)))
116         (unless (memq (car pair) systems)
117           (setq dest (cons pair dest))))
118       (setq rest (cdr rest)))
119     dest)
120   "Charset/coding system alist.")
121
122
123 (defun mm-mule-charset-to-mime-charset (charset)
124   "Return the MIME charset corresponding to MULE CHARSET."
125   (let ((alist mm-mime-mule-charset-alist)
126         out)
127     (while alist
128       (when (memq charset (cdar alist))
129         (setq out (caar alist)
130               alist nil))
131       (pop alist))
132     out))
133
134 (defun mm-charset-to-coding-system (charset &optional lbt)
135   "Return coding-system corresponding to CHARSET.
136 CHARSET is a symbol naming a MIME charset.
137 If optional argument LBT (`unix', `dos' or `mac') is specified, it is
138 used as the line break code type of the coding system."
139   (when (stringp charset)
140     (setq charset (intern (downcase charset))))
141   (setq charset
142         (or (cdr (assq charset mm-charset-coding-system-alist))
143             charset))
144   (when lbt
145     (setq charset (intern (format "%s-%s" charset lbt))))
146   (cond
147    ;; Running in a non-MULE environment.
148    ((and (null (mm-coding-system-list))
149          (memq charset mm-known-charsets))
150     charset)
151    ;; Check to see whether we can handle this charset.
152    ((memq charset (mm-coding-system-list))
153     charset)
154    ;; Nope.
155    (t
156     nil)))
157
158 (defun mm-replace-chars-in-string (string from to)
159   "Replace characters in STRING from FROM to TO."
160   (let ((string (substring string 0))   ;Copy string.
161         (len (length string))
162         (idx 0))
163     ;; Replace all occurrences of FROM with TO.
164     (while (< idx len)
165       (when (= (aref string idx) from)
166         (aset string idx to))
167       (setq idx (1+ idx)))
168     string))
169
170 (defun mm-enable-multibyte ()
171   "Enable multibyte in the current buffer."
172   (when (fboundp 'set-buffer-multibyte)
173     (set-buffer-multibyte t)))
174
175 (defun mm-insert-rfc822-headers (charset encoding)
176   "Insert text/plain headers with CHARSET and ENCODING."
177   (insert "MIME-Version: 1.0\n")
178   (insert "Content-Type: text/plain; charset=\""
179           (downcase (symbol-name charset)) "\"\n")
180   (insert "Content-Transfer-Encoding: "
181           (downcase (symbol-name encoding)) "\n"))
182
183 (defun mm-content-type-charset (header)
184   "Return the charset parameter from HEADER."
185   (when (string-match "charset *= *\"? *\\([-0-9a-zA-Z_]+\\)\"? *$" header)
186     (intern (downcase (match-string 1 header)))))
187
188
189 (defun mm-mime-charset (charset b e)
190   (if (fboundp 'coding-system-get)
191       (or
192        (coding-system-get
193         (get-charset-property charset 'prefered-coding-system)
194         'mime-charset)
195        (car (memq charset (find-coding-systems-region
196                            (point-min) (point-max)))))
197     (mm-mule-charset-to-mime-charset charset)))
198
199 (defun mm-multibyte-p ()
200   "Say whether multibyte is enabled."
201   (and (boundp 'enable-multibyte-characters)
202        enable-multibyte-characters))
203
204 (provide 'mm-util)
205
206 ;;; mm-util.el ends here