1 | ;;; mcs-xm.el --- MIME charset implementation for XEmacs-mule |
---|
2 | |
---|
3 | ;; Copyright (C) 1997,1998,1999,2000 Free Software Foundation, Inc. |
---|
4 | |
---|
5 | ;; Author: MORIOKA Tomohiko <tomo@m17n.org> |
---|
6 | ;; Keywords: MIME-charset, coding-system, emulation, compatibility, Mule |
---|
7 | |
---|
8 | ;; This file is part of APEL (A Portable Emacs Library). |
---|
9 | |
---|
10 | ;; This program is free software; you can redistribute it and/or |
---|
11 | ;; modify it under the terms of the GNU General Public License as |
---|
12 | ;; published by the Free Software Foundation; either version 2, or (at |
---|
13 | ;; your option) any later version. |
---|
14 | |
---|
15 | ;; This program is distributed in the hope that it will be useful, but |
---|
16 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
---|
18 | ;; General Public License for more details. |
---|
19 | |
---|
20 | ;; You should have received a copy of the GNU General Public License |
---|
21 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
---|
22 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
---|
23 | ;; Boston, MA 02111-1307, USA. |
---|
24 | |
---|
25 | ;;; Commentary: |
---|
26 | |
---|
27 | ;; This module requires Emacs 20.0.93, XEmacs 20.3-b5 (with mule) |
---|
28 | ;; or later. |
---|
29 | |
---|
30 | ;;; Code: |
---|
31 | |
---|
32 | (require 'poem) |
---|
33 | |
---|
34 | |
---|
35 | (defun encode-mime-charset-region (start end charset &optional lbt) |
---|
36 | "Encode the text between START and END as MIME CHARSET." |
---|
37 | (let ((cs (mime-charset-to-coding-system charset lbt))) |
---|
38 | (if cs |
---|
39 | (encode-coding-region start end cs) |
---|
40 | ))) |
---|
41 | |
---|
42 | |
---|
43 | (defcustom mime-charset-decoder-alist |
---|
44 | (let ((alist |
---|
45 | '((hz-gb-2312 . decode-mime-charset-region-for-hz) |
---|
46 | (t . decode-mime-charset-region-default)))) |
---|
47 | (if (featurep 'utf-2000) |
---|
48 | alist |
---|
49 | (list* |
---|
50 | '(iso-2022-jp . decode-mime-charset-region-with-iso646-unification) |
---|
51 | '(iso-2022-jp-2 . decode-mime-charset-region-with-iso646-unification) |
---|
52 | alist))) |
---|
53 | "Alist MIME-charset vs. decoder function." |
---|
54 | :group 'i18n |
---|
55 | :type '(repeat (cons mime-charset function))) |
---|
56 | |
---|
57 | (defsubst decode-mime-charset-region-default (start end charset lbt) |
---|
58 | (let ((cs (mime-charset-to-coding-system charset lbt))) |
---|
59 | (if cs |
---|
60 | (decode-coding-region start end cs) |
---|
61 | ))) |
---|
62 | |
---|
63 | (unless (featurep 'utf-2000) |
---|
64 | (require 'mcs-xmu)) |
---|
65 | |
---|
66 | (defun decode-mime-charset-region-for-hz (start end charset lbt) |
---|
67 | (if lbt |
---|
68 | (save-restriction |
---|
69 | (narrow-to-region start end) |
---|
70 | (decode-coding-region (point-min)(point-max) |
---|
71 | (mime-charset-to-coding-system 'raw-text lbt)) |
---|
72 | (decode-hz-region (point-min)(point-max))) |
---|
73 | (decode-hz-region start end))) |
---|
74 | |
---|
75 | (defun decode-mime-charset-region (start end charset &optional lbt) |
---|
76 | "Decode the text between START and END as MIME CHARSET." |
---|
77 | (if (stringp charset) |
---|
78 | (setq charset (intern (downcase charset))) |
---|
79 | ) |
---|
80 | (let ((func (cdr (or (assq charset mime-charset-decoder-alist) |
---|
81 | (assq t mime-charset-decoder-alist))))) |
---|
82 | (funcall func start end charset lbt))) |
---|
83 | |
---|
84 | (defsubst encode-mime-charset-string (string charset &optional lbt) |
---|
85 | "Encode the STRING as MIME CHARSET." |
---|
86 | (let ((cs (mime-charset-to-coding-system charset lbt))) |
---|
87 | (if cs |
---|
88 | (encode-coding-string string cs) |
---|
89 | string))) |
---|
90 | |
---|
91 | ;; (defsubst decode-mime-charset-string (string charset) |
---|
92 | ;; "Decode the STRING as MIME CHARSET." |
---|
93 | ;; (let ((cs (mime-charset-to-coding-system charset))) |
---|
94 | ;; (if cs |
---|
95 | ;; (decode-coding-string string cs) |
---|
96 | ;; string))) |
---|
97 | (defun decode-mime-charset-string (string charset &optional lbt) |
---|
98 | "Decode the STRING as MIME CHARSET." |
---|
99 | (with-temp-buffer |
---|
100 | (insert string) |
---|
101 | (decode-mime-charset-region (point-min)(point-max) charset lbt) |
---|
102 | (buffer-string))) |
---|
103 | |
---|
104 | |
---|
105 | (defvar charsets-mime-charset-alist |
---|
106 | `(((ascii) . us-ascii) |
---|
107 | ((ascii latin-iso8859-1) . iso-8859-1) |
---|
108 | ((ascii latin-iso8859-2) . iso-8859-2) |
---|
109 | ((ascii latin-iso8859-3) . iso-8859-3) |
---|
110 | ((ascii latin-iso8859-4) . iso-8859-4) |
---|
111 | ((ascii cyrillic-iso8859-5) . iso-8859-5) |
---|
112 | ;;; ((ascii cyrillic-iso8859-5) . koi8-r) |
---|
113 | ((ascii arabic-iso8859-6) . iso-8859-6) |
---|
114 | ((ascii greek-iso8859-7) . iso-8859-7) |
---|
115 | ((ascii hebrew-iso8859-8) . iso-8859-8) |
---|
116 | ((ascii latin-iso8859-9) . iso-8859-9) |
---|
117 | ,(if (featurep 'utf-2000) |
---|
118 | '((ascii latin-jisx0201 |
---|
119 | japanese-jisx0208-1978 |
---|
120 | japanese-jisx0208 |
---|
121 | japanese-jisx0208-1990) . iso-2022-jp) |
---|
122 | '((ascii latin-jisx0201 |
---|
123 | japanese-jisx0208-1978 japanese-jisx0208) |
---|
124 | . iso-2022-jp)) |
---|
125 | ,(if (featurep 'utf-2000) |
---|
126 | '((ascii latin-jisx0201 |
---|
127 | japanese-jisx0208-1978 |
---|
128 | japanese-jisx0208 |
---|
129 | japanese-jisx0208-1990 |
---|
130 | japanese-jisx0213-1 |
---|
131 | japanese-jisx0213-2) . iso-2022-jp-3) |
---|
132 | '((ascii latin-jisx0201 |
---|
133 | japanese-jisx0208-1978 japanese-jisx0208 |
---|
134 | japanese-jisx0213-1 |
---|
135 | japanese-jisx0213-2) . iso-2022-jp-3)) |
---|
136 | ,(if (featurep 'utf-2000) |
---|
137 | '((ascii latin-jisx0201 katakana-jisx0201 |
---|
138 | japanese-jisx0208-1990) . shift_jis) |
---|
139 | '((ascii latin-jisx0201 |
---|
140 | katakana-jisx0201 japanese-jisx0208) . shift_jis)) |
---|
141 | ((ascii korean-ksc5601) . euc-kr) |
---|
142 | ((ascii chinese-gb2312) . gb2312) |
---|
143 | ((ascii chinese-big5-1 chinese-big5-2) . big5) |
---|
144 | ((ascii thai-xtis) . tis-620) |
---|
145 | ,(if (featurep 'utf-2000) |
---|
146 | '((ascii latin-jisx0201 latin-iso8859-1 |
---|
147 | greek-iso8859-7 |
---|
148 | japanese-jisx0208-1978 japanese-jisx0208 |
---|
149 | japanese-jisx0208-1990 |
---|
150 | japanese-jisx0212 |
---|
151 | chinese-gb2312 |
---|
152 | korean-ksc5601) . iso-2022-jp-2) |
---|
153 | '((ascii latin-jisx0201 latin-iso8859-1 |
---|
154 | greek-iso8859-7 |
---|
155 | japanese-jisx0208-1978 japanese-jisx0208 |
---|
156 | japanese-jisx0212 |
---|
157 | chinese-gb2312 |
---|
158 | korean-ksc5601) . iso-2022-jp-2)) |
---|
159 | ;; ((ascii latin-iso8859-1 greek-iso8859-7 |
---|
160 | ;; latin-jisx0201 japanese-jisx0208-1978 |
---|
161 | ;; chinese-gb2312 japanese-jisx0208 |
---|
162 | ;; korean-ksc5601 japanese-jisx0212 |
---|
163 | ;; chinese-cns11643-1 chinese-cns11643-2) . iso-2022-int-1) |
---|
164 | )) |
---|
165 | |
---|
166 | |
---|
167 | (defun coding-system-to-mime-charset (coding-system) |
---|
168 | "Convert CODING-SYSTEM to a MIME-charset. |
---|
169 | Return nil if corresponding MIME-charset is not found." |
---|
170 | (setq coding-system |
---|
171 | (coding-system-name (coding-system-base coding-system))) |
---|
172 | (or (car (rassq coding-system mime-charset-coding-system-alist)) |
---|
173 | coding-system)) |
---|
174 | |
---|
175 | (defun mime-charset-list () |
---|
176 | "Return a list of all existing MIME-charset." |
---|
177 | (let ((dest (mapcar (function car) mime-charset-coding-system-alist)) |
---|
178 | (rest (coding-system-list)) |
---|
179 | cs) |
---|
180 | (while rest |
---|
181 | (setq cs (coding-system-name (coding-system-base (car rest)))) |
---|
182 | (or (rassq cs mime-charset-coding-system-alist) |
---|
183 | (memq cs dest) |
---|
184 | (setq dest (cons cs dest))) |
---|
185 | (setq rest (cdr rest))) |
---|
186 | dest)) |
---|
187 | |
---|
188 | |
---|
189 | ;;; @ end |
---|
190 | ;;; |
---|
191 | |
---|
192 | (require 'product) |
---|
193 | (product-provide (provide 'mcs-xm) (require 'apel-ver)) |
---|
194 | |
---|
195 | ;;; mcs-xm.el ends here |
---|