|
428
|
1 ;;; coding.el --- Coding-system functions for XEmacs.
|
|
|
2
|
|
|
3 ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
|
|
|
4 ;; Licensed to the Free Software Foundation.
|
|
|
5 ;; Copyright (C) 1995 Amdahl Corporation.
|
|
|
6 ;; Copyright (C) 1995 Sun Microsystems.
|
|
|
7 ;; Copyright (C) 1997 MORIOKA Tomohiko
|
|
771
|
8 ;; Copyright (C) 2000, 2001, 2002 Ben Wing.
|
|
428
|
9
|
|
|
10 ;; This file is part of XEmacs.
|
|
|
11
|
|
|
12 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
13 ;; under the terms of the GNU General Public License as published by
|
|
|
14 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
15 ;; any later version.
|
|
|
16
|
|
|
17 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
20 ;; General Public License for more details.
|
|
|
21
|
|
|
22 ;; You should have received a copy of the GNU General Public License
|
|
440
|
23 ;; along with XEmacs; see the file COPYING. If not, write to the
|
|
428
|
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
25 ;; Boston, MA 02111-1307, USA.
|
|
|
26
|
|
|
27 ;;; Commentary:
|
|
|
28
|
|
|
29 ;;; split off of mule.el.
|
|
|
30
|
|
|
31 ;;; Code:
|
|
|
32
|
|
502
|
33 (globally-declare-fboundp
|
|
|
34 '(coding-system-lock-shift
|
|
|
35 coding-system-seven coding-system-charset charset-dimension))
|
|
|
36
|
|
428
|
37 (defalias 'check-coding-system 'get-coding-system)
|
|
|
38
|
|
|
39 (defun modify-coding-system-alist (target-type regexp coding-system)
|
|
|
40 "Modify one of look up tables for finding a coding system on I/O operation.
|
|
|
41 There are three of such tables, `file-coding-system-alist',
|
|
|
42 `process-coding-system-alist', and `network-coding-system-alist'.
|
|
|
43
|
|
|
44 TARGET-TYPE specifies which of them to modify.
|
|
|
45 If it is `file', it affects `file-coding-system-alist' (which see).
|
|
|
46 If it is `process', it affects `process-coding-system-alist' (which see).
|
|
599
|
47 If it is `network', it affects `network-coding-system-alist' (which see).
|
|
428
|
48
|
|
|
49 REGEXP is a regular expression matching a target of I/O operation.
|
|
|
50 The target is a file name if TARGET-TYPE is `file', a program name if
|
|
|
51 TARGET-TYPE is `process', or a network service name or a port number
|
|
|
52 to connect to if TARGET-TYPE is `network'.
|
|
|
53
|
|
|
54 CODING-SYSTEM is a coding system to perform code conversion on the I/O
|
|
|
55 operation, or a cons cell (DECODING . ENCODING) specifying the coding systems
|
|
|
56 for decoding and encoding respectively,
|
|
|
57 or a function symbol which, when called, returns such a cons cell."
|
|
|
58 (or (memq target-type '(file process network))
|
|
|
59 (error "Invalid target type: %s" target-type))
|
|
|
60 (or (stringp regexp)
|
|
|
61 (and (eq target-type 'network) (integerp regexp))
|
|
|
62 (error "Invalid regular expression: %s" regexp))
|
|
|
63 (if (symbolp coding-system)
|
|
|
64 (if (not (fboundp coding-system))
|
|
|
65 (progn
|
|
|
66 (check-coding-system coding-system)
|
|
|
67 (setq coding-system (cons coding-system coding-system))))
|
|
|
68 (check-coding-system (car coding-system))
|
|
|
69 (check-coding-system (cdr coding-system)))
|
|
|
70 (cond ((eq target-type 'file)
|
|
|
71 (let ((slot (assoc regexp file-coding-system-alist)))
|
|
|
72 (if slot
|
|
|
73 (setcdr slot coding-system)
|
|
|
74 (setq file-coding-system-alist
|
|
|
75 (cons (cons regexp coding-system)
|
|
|
76 file-coding-system-alist)))))
|
|
|
77 ((eq target-type 'process)
|
|
|
78 (let ((slot (assoc regexp process-coding-system-alist)))
|
|
|
79 (if slot
|
|
|
80 (setcdr slot coding-system)
|
|
|
81 (setq process-coding-system-alist
|
|
|
82 (cons (cons regexp coding-system)
|
|
|
83 process-coding-system-alist)))))
|
|
|
84 (t
|
|
|
85 (let ((slot (assoc regexp network-coding-system-alist)))
|
|
|
86 (if slot
|
|
|
87 (setcdr slot coding-system)
|
|
|
88 (setq network-coding-system-alist
|
|
|
89 (cons (cons regexp coding-system)
|
|
|
90 network-coding-system-alist)))))))
|
|
|
91
|
|
|
92 (defsubst keyboard-coding-system ()
|
|
|
93 "Return coding-system of what is sent from terminal keyboard."
|
|
|
94 keyboard-coding-system)
|
|
|
95
|
|
|
96 (defun set-keyboard-coding-system (coding-system)
|
|
|
97 "Set the coding system used for TTY keyboard input. Currently broken."
|
|
|
98 (interactive "zkeyboard-coding-system: ")
|
|
|
99 (get-coding-system coding-system) ; correctness check
|
|
|
100 (setq keyboard-coding-system coding-system)
|
|
442
|
101 (if (eq (device-type) 'tty)
|
|
502
|
102 (declare-fboundp (set-console-tty-input-coding-system
|
|
|
103 (device-console) keyboard-coding-system)))
|
|
428
|
104 (redraw-modeline t))
|
|
|
105
|
|
|
106 (defsubst terminal-coding-system ()
|
|
|
107 "Return coding-system of your terminal."
|
|
|
108 terminal-coding-system)
|
|
|
109
|
|
|
110 (defun set-terminal-coding-system (coding-system)
|
|
|
111 "Set the coding system used for TTY display output. Currently broken."
|
|
|
112 (interactive "zterminal-coding-system: ")
|
|
|
113 (get-coding-system coding-system) ; correctness check
|
|
|
114 (setq terminal-coding-system coding-system)
|
|
|
115 ; #### should this affect all current tty consoles ?
|
|
|
116 (if (eq (device-type) 'tty)
|
|
502
|
117 (declare-fboundp (set-console-tty-output-coding-system
|
|
|
118 (device-console) terminal-coding-system)))
|
|
428
|
119 (redraw-modeline t))
|
|
|
120
|
|
|
121 (defun what-coding-system (start end &optional arg)
|
|
|
122 "Show the encoding of text in the region.
|
|
|
123 This function is meant to be called interactively;
|
|
|
124 from a Lisp program, use `detect-coding-region' instead."
|
|
|
125 (interactive "r\nP")
|
|
|
126 (princ (detect-coding-region start end)))
|
|
|
127
|
|
|
128 (defun decode-coding-string (str coding-system)
|
|
|
129 "Decode the string STR which is encoded in CODING-SYSTEM.
|
|
|
130 Does not modify STR. Returns the decoded string on successful conversion."
|
|
|
131 (with-string-as-buffer-contents
|
|
|
132 str (decode-coding-region (point-min) (point-max) coding-system)))
|
|
|
133
|
|
|
134 (defun encode-coding-string (str coding-system)
|
|
|
135 "Encode the string STR using CODING-SYSTEM.
|
|
|
136 Does not modify STR. Returns the encoded string on successful conversion."
|
|
|
137 (with-string-as-buffer-contents
|
|
|
138 str (encode-coding-region (point-min) (point-max) coding-system)))
|
|
|
139
|
|
|
140
|
|
|
141 ;;;; Coding system accessors
|
|
|
142
|
|
|
143 (defun coding-system-mnemonic (coding-system)
|
|
|
144 "Return the 'mnemonic property of CODING-SYSTEM."
|
|
|
145 (coding-system-property coding-system 'mnemonic))
|
|
|
146
|
|
771
|
147 (defun coding-system-documentation (coding-system)
|
|
|
148 "Return the 'documentation property of CODING-SYSTEM."
|
|
|
149 (coding-system-property coding-system 'documentation))
|
|
|
150
|
|
|
151 (define-obsolete-function-alias 'coding-system-doc-string
|
|
|
152 'coding-system-description)
|
|
428
|
153
|
|
|
154 (defun coding-system-eol-type (coding-system)
|
|
|
155 "Return the 'eol-type property of CODING-SYSTEM."
|
|
|
156 (coding-system-property coding-system 'eol-type))
|
|
|
157
|
|
|
158 (defun coding-system-eol-lf (coding-system)
|
|
|
159 "Return the 'eol-lf property of CODING-SYSTEM."
|
|
|
160 (coding-system-property coding-system 'eol-lf))
|
|
|
161
|
|
|
162 (defun coding-system-eol-crlf (coding-system)
|
|
|
163 "Return the 'eol-crlf property of CODING-SYSTEM."
|
|
|
164 (coding-system-property coding-system 'eol-crlf))
|
|
|
165
|
|
|
166 (defun coding-system-eol-cr (coding-system)
|
|
|
167 "Return the 'eol-cr property of CODING-SYSTEM."
|
|
|
168 (coding-system-property coding-system 'eol-cr))
|
|
|
169
|
|
|
170 (defun coding-system-post-read-conversion (coding-system)
|
|
|
171 "Return the 'post-read-conversion property of CODING-SYSTEM."
|
|
|
172 (coding-system-property coding-system 'post-read-conversion))
|
|
|
173
|
|
|
174 (defun coding-system-pre-write-conversion (coding-system)
|
|
|
175 "Return the 'pre-write-conversion property of CODING-SYSTEM."
|
|
|
176 (coding-system-property coding-system 'pre-write-conversion))
|
|
|
177
|
|
502
|
178 ;;; #### bleagh!!!!!!!
|
|
|
179
|
|
|
180 (defun coding-system-get (coding-system prop)
|
|
|
181 "Extract a value from CODING-SYSTEM's property list for property PROP."
|
|
|
182 (or (plist-get
|
|
|
183 (get (coding-system-name coding-system) 'coding-system-property)
|
|
|
184 prop)
|
|
|
185 (condition-case nil
|
|
|
186 (coding-system-property coding-system prop)
|
|
|
187 (error nil))))
|
|
|
188
|
|
|
189 (defun coding-system-put (coding-system prop value)
|
|
|
190 "Change value in CODING-SYSTEM's property list PROP to VALUE."
|
|
|
191 (put (coding-system-name coding-system)
|
|
|
192 'coding-system-property
|
|
|
193 (plist-put (get (coding-system-name coding-system)
|
|
|
194 'coding-system-property)
|
|
|
195 prop value)))
|
|
|
196
|
|
|
197 (defun coding-system-category (coding-system)
|
|
|
198 "Return the coding category of CODING-SYSTEM."
|
|
|
199 (or (coding-system-get coding-system 'category)
|
|
771
|
200 (case (coding-system-type coding-system)
|
|
|
201 (no-conversion 'no-conversion)
|
|
|
202 (shift-jis 'shift-jis)
|
|
|
203 (unicode (case (coding-system-property coding-system 'type)
|
|
985
|
204 (utf-8 (let ((bom (coding-system-property coding-system
|
|
|
205 'need-bom)))
|
|
|
206 (cond (bom 'utf-8-bom)
|
|
|
207 ((not bom) 'utf-8))))
|
|
771
|
208 (ucs-4 'ucs-4)
|
|
|
209 (utf-16 (let ((bom (coding-system-property coding-system
|
|
|
210 'need-bom))
|
|
|
211 (le (coding-system-property coding-system
|
|
|
212 'little-endian)))
|
|
|
213 (cond ((and bom le) 'utf-16-little-endian-bom)
|
|
|
214 ((and bom (not le) 'utf-16-bom))
|
|
|
215 ((and (not bom) le) 'utf-16-little-endian)
|
|
|
216 ((and (not bom) (not le) 'utf-16)))))))
|
|
|
217 (big5 'big5)
|
|
|
218 (iso2022 (cond ((coding-system-lock-shift coding-system)
|
|
|
219 'iso-lock-shift)
|
|
|
220 ((coding-system-seven coding-system)
|
|
|
221 'iso-7)
|
|
|
222 (t
|
|
|
223 (let ((dim 0)
|
|
|
224 ccs
|
|
|
225 (i 0))
|
|
|
226 (while (< i 4)
|
|
|
227 (setq ccs (declare-fboundp
|
|
|
228 (coding-system-iso2022-charset
|
|
|
229 coding-system i)))
|
|
|
230 (if (and ccs
|
|
|
231 (> (charset-dimension ccs) dim))
|
|
|
232 (setq dim (charset-dimension ccs))
|
|
|
233 )
|
|
|
234 (setq i (1+ i)))
|
|
|
235 (cond ((= dim 1) 'iso-8-1)
|
|
|
236 ((= dim 2) 'iso-8-2)
|
|
|
237 (t 'iso-8-designate))))))
|
|
|
238 )))
|
|
502
|
239
|
|
428
|
240
|
|
440
|
241 ;;; Make certain variables equivalent to coding-system aliases
|
|
|
242 (defun dontusethis-set-value-file-name-coding-system-handler (sym args fun harg handlers)
|
|
|
243 (define-coding-system-alias 'file-name (or (car args) 'binary)))
|
|
|
244
|
|
|
245 (dontusethis-set-symbol-value-handler
|
|
|
246 'file-name-coding-system
|
|
|
247 'set-value
|
|
|
248 'dontusethis-set-value-file-name-coding-system-handler)
|
|
|
249
|
|
|
250 (defun dontusethis-set-value-terminal-coding-system-handler (sym args fun harg handlers)
|
|
|
251 (define-coding-system-alias 'terminal (or (car args) 'binary)))
|
|
|
252
|
|
|
253 (dontusethis-set-symbol-value-handler
|
|
|
254 'terminal-coding-system
|
|
|
255 'set-value
|
|
|
256 'dontusethis-set-value-terminal-coding-system-handler)
|
|
|
257
|
|
|
258 (defun dontusethis-set-value-keyboard-coding-system-handler (sym args fun harg handlers)
|
|
|
259 (define-coding-system-alias 'keyboard (or (car args) 'binary)))
|
|
|
260
|
|
|
261 (dontusethis-set-symbol-value-handler
|
|
|
262 'keyboard-coding-system
|
|
|
263 'set-value
|
|
|
264 'dontusethis-set-value-keyboard-coding-system-handler)
|
|
|
265
|
|
|
266 (when (not (featurep 'mule))
|
|
771
|
267 (define-coding-system-alias 'escape-quoted 'binary)
|
|
440
|
268 ;; these are so that gnus and friends work when not mule
|
|
771
|
269 (define-coding-system-alias 'iso-8859-1 'undecided)
|
|
|
270 (define-coding-system-alias 'iso-8859-2 'undecided)
|
|
440
|
271 (define-coding-system-alias 'ctext 'binary))
|
|
|
272
|
|
428
|
273
|
|
|
274 ;; compatibility for old XEmacsen (don't use it)
|
|
771
|
275 (define-coding-system-alias 'automatic-conversion 'undecided)
|
|
428
|
276
|
|
|
277 (make-compatible-variable 'enable-multibyte-characters "Unimplemented")
|
|
|
278
|
|
728
|
279 ;;; coding.el ends here
|
