Mercurial > hg > xemacs-beta

comparison lisp/mule/mule-coding.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents
children 54cc21c15cbb
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; mule-coding.el --- Coding-system functions for Mule.
2
3 ;; Copyright (C) 1992,93,94,95 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Amdahl Corporation.
5 ;; Copyright (C) 1995 Sun Microsystems.
6
7 ;; This file is part of XEmacs.
8
9 ;; XEmacs is free software; you can redistribute it and/or modify it
10 ;; under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
12 ;; any later version.
13
14 ;; XEmacs is distributed in the hope that it will be useful, but
15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 ;; General Public License for more details.
18
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with XEmacs; see the file COPYING. If not, write to the
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
23
24 ;;; Commentary:
25
26 ;;; split off of mule.el.
27
28 ;;; Code:
29
30 (defun set-terminal-coding-system (coding-system)
31 "Set the coding system used for TTY display output."
32 (interactive "zterminal-coding-system: ")
33 (get-coding-system coding-system) ;; correctness check
34 (setq terminal-coding-system coding-system)
35 (redraw-modeline t))
36
37 (defun set-pathname-coding-system (coding-system)
38 "Set the coding system used for file system path names."
39 (interactive "zPathname-coding-system: ")
40 (get-coding-system coding-system) ;; correctness check
41 (setq pathname-coding-system coding-system))
42
43 (defun what-coding-system (start end &optional arg)
44 "Show the encoding of text in the region.
45 With prefix arg, show all possible coding systems.
46 This function is meant to be called interactively;
47 from a Lisp program, use `detect-coding-region' instead."
48 (interactive "r\nP")
49 (let ((codings (detect-coding-region start end)))
50 (message "%s" (if (or arg (symbolp codings)) codings (car codings)))))
51
52 (defmacro with-string-as-buffer-contents (str &rest body)
53 "With the contents of the current buffer being STR, run BODY.
54 Returns the new contents of the buffer, as modified by BODY.
55 The original current buffer is restored afterwards."
56 `(let ((curbuf (current-buffer))
57 (tempbuf (get-buffer-create " *string-as-buffer-contents*")))
58 (unwind-protect
59 (progn
60 (set-buffer tempbuf)
61 (buffer-disable-undo (current-buffer))
62 (erase-buffer)
63 (insert ,str)
64 ,@body
65 (buffer-string))
66 (erase-buffer tempbuf)
67 (set-buffer curbuf))))
68
69 (defun decode-coding-string (str coding-system)
70 "Decode the string STR which is encoded in CODING-SYSTEM.
71 Does not modify STR. Returns the decoded string on successful conversion."
72 (with-string-as-buffer-contents
73 str (decode-coding-region (point-min) (point-max) coding-system)))
74
75 (defun encode-coding-string (str coding-system)
76 "Encode the string STR using CODING-SYSTEM.
77 Does not modify STR. Returns the encoded string on successful conversion."
78 (with-string-as-buffer-contents
79 str (encode-coding-region (point-min) (point-max) coding-system)))
80
81
82 ;;;; Coding system accessors
83
84 (defun coding-system-mnemonic (coding-system)
85 "Return the 'mnemonic property of CODING-SYSTEM."
86 (coding-system-property coding-system 'mnemonic))
87
88 (defun coding-system-eol-type (coding-system)
89 "Return the 'eol-type property of CODING-SYSTEM."
90 (coding-system-property coding-system 'eol-type))
91
92 (defun coding-system-eol-lf (coding-system)
93 "Return the 'eol-lf property of CODING-SYSTEM."
94 (coding-system-property coding-system 'eol-lf))
95
96 (defun coding-system-eol-crlf (coding-system)
97 "Return the 'eol-crlf property of CODING-SYSTEM."
98 (coding-system-property coding-system 'eol-crlf))
99
100 (defun coding-system-eol-cr (coding-system)
101 "Return the 'eol-cr property of CODING-SYSTEM."
102 (coding-system-property coding-system 'eol-cr))
103
104 (defun coding-system-post-read-conversion (coding-system)
105 "Return the 'post-read-conversion property of CODING-SYSTEM."
106 (coding-system-property coding-system 'post-read-conversion))
107
108 (defun coding-system-pre-write-conversion (coding-system)
109 "Return the 'pre-write-conversion property of CODING-SYSTEM."
110 (coding-system-property coding-system 'pre-write-conversion))
111
112 (defun coding-system-charset (coding-system register)
113 "Return the 'charset property of CODING-SYSTEM for the specified REGISTER."
114 (cond ((not (integerp register))
115 (signal 'wrong-type-argument (list 'integerp register)))
116 ((= register 0)
117 (coding-system-property coding-system 'charset-g0))
118 ((= register 1)
119 (coding-system-property coding-system 'charset-g1))
120 ((= register 2)
121 (coding-system-property coding-system 'charset-g2))
122 ((= register 3)
123 (coding-system-property coding-system 'charset-g3))
124 (t
125 (signal 'args-out-of-range (list register 0 3)))))
126
127 (defun coding-system-force-on-output (coding-system register)
128 "Return the 'force-on-output property of CODING-SYSTEM for the specified REGISTER."
129 (cond ((not (integerp register))
130 (signal 'wrong-type-argument (list 'integerp register)))
131 ((= register 0)
132 (coding-system-property coding-system 'force-g0-on-output))
133 ((= register 1)
134 (coding-system-property coding-system 'force-g1-on-output))
135 ((= register 2)
136 (coding-system-property coding-system 'force-g2-on-output))
137 ((= register 3)
138 (coding-system-property coding-system 'force-g3-on-output))
139 (t
140 (signal 'args-out-of-range (list register 0 3)))))
141
142 (defun coding-system-short (coding-system)
143 "Return the 'short property of CODING-SYSTEM."
144 (coding-system-property coding-system 'short))
145
146 (defun coding-system-no-ascii-eol (coding-system)
147 "Return the 'no-ascii-eol property of CODING-SYSTEM."
148 (coding-system-property coding-system 'no-ascii-eol))
149
150 (defun coding-system-no-ascii-cntl (coding-system)
151 "Return the 'no-ascii-cntl property of CODING-SYSTEM."
152 (coding-system-property coding-system 'no-ascii-cntl))
153
154 (defun coding-system-seven (coding-system)
155 "Return the 'seven property of CODING-SYSTEM."
156 (coding-system-property coding-system 'seven))
157
158 (defun coding-system-lock-shift (coding-system)
159 "Return the 'lock-shift property of CODING-SYSTEM."
160 (coding-system-property coding-system 'lock-shift))
161
162 (defun coding-system-use-japanese-jisx0201-roman (coding-system)
163 "Return the 'use-japanese-jisx0201-roman property of CODING-SYSTEM."
164 (coding-system-property coding-system 'use-japanese-jisx0201-roman))
165
166 (defun coding-system-use-japanese-jisx0208-1978 (coding-system)
167 "Return the 'use-japanese-jisx0208-1978 property of CODING-SYSTEM."
168 (coding-system-property coding-system 'use-japanese-jisx0208-2978))
169
170 (defun coding-system-no-iso6429 (coding-system)
171 "Return the 'no-iso6429 property of CODING-SYSTEM."
172 (coding-system-property coding-system 'no-iso6429))
173
174 (defun coding-system-ccl-encode (coding-system)
175 "Return the CCL 'encode property of CODING-SYSTEM."
176 (coding-system-property coding-system 'encode))
177
178 (defun coding-system-ccl-decode (coding-system)
179 "Return the CCL 'decode property of CODING-SYSTEM."
180 (coding-system-property coding-system 'decode))
181
182
183 ;;;; Definitions of predefined coding systems
184
185 (make-coding-system
186 'autodetect 'autodetect
187 "Automatic conversion."
188 '(mnemonic "Auto"))
189
190 (make-coding-system
191 'ctext 'iso2022
192 "Coding-system used in X as Compound Text Encoding."
193 '(charset-g0 ascii
194 charset-g1 latin-1
195 eol-type lf
196 mnemonic "CText"
197 ))
198
199 (make-coding-system
200 'iso-2022-ss2-8 'iso2022
201 "ISO-2022 coding system using SS2 for 96-charset in 8-bit code."
202 '(charset-g0 ascii
203 charset-g1 latin-1
204 charset-g2 t ;; unspecified but can be used later.
205 short t
206 mnemonic "ISO8/SS"
207 ))
208
209 (make-coding-system
210 'iso-2022-ss2-7 'iso2022
211 "ISO-2022 coding system using SS2 for 96-charset in 7-bit code."
212 '(charset-g0 ascii
213 charset-g2 t ;; unspecified but can be used later.
214 seven t
215 short t
216 mnemonic "ISO7/SS"
217 ))
218
219 (make-coding-system
220 'iso-2022-7 'iso2022
221 "ISO-2022 seven-bit coding system. No single-shift or locking-shift."
222 '(charset-g0 ascii
223 seven t
224 short t
225 mnemonic "ISO7"
226 ))
227
228 (make-coding-system
229 'iso-2022-8 'iso2022
230 "ISO-2022 eight-bit coding system. No single-shift or locking-shift."
231 '(charset-g0 ascii
232 charset-g1 latin-1
233 short t
234 mnemonic "ISO8"
235 ))
236
237 (make-coding-system
238 'escape-quoted 'iso2022
239 "ISO-2022 eight-bit coding system with escape quoting; used for .ELC files."
240 '(charset-g0 ascii
241 charset-g1 latin-1
242 eol-type lf
243 escape-quoted t
244 mnemonic "ESC/Quot"
245 ))
246
247 (make-coding-system
248 'iso-2022-lock 'iso2022
249 "ISO-2022 coding system using Locking-Shift for 96-charset."
250 '(charset-g0 ascii
251 charset-g1 t ;; unspecified but can be used later.
252 seven t
253 lock-shift t
254 mnemonic "ISO7/Lock"
255 ))
256
257 ;; initialize the coding categories to something semi-reasonable
258 ;; so that the remaining Lisp files can contain extended characters.
259 ;; (They will be in ISO-7 format)
260
261 (set-coding-priority-list '(iso-8-2 shift-jis iso-8-designate iso-8-1 big5
262 iso-7 iso-lock-shift no-conversion))
263
264 (set-coding-category-system 'iso-7 'iso-2022-7)
265 (set-coding-category-system 'iso-8-designate 'ctext)
266 (set-coding-category-system 'iso-8-1 'ctext)
267 (set-coding-category-system 'iso-lock-shift 'iso-2022-lock)
268 (set-coding-category-system 'no-conversion 'no-conversion)