Reformatted.
[chise/xemacs-chise.git.1] / lisp / coding.el
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
8
9 ;; This file is part of XEmacs.
10
11 ;; This file is very similar to mule-coding.el
12
13 ;; XEmacs is free software; you can redistribute it and/or modify it
14 ;; under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; any later version.
17
18 ;; XEmacs is distributed in the hope that it will be useful, but
19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
21 ;; General Public License for more details.
22
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with XEmacs; see the file COPYING.  If not, write to the
25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26 ;; Boston, MA 02111-1307, USA.
27
28 ;;; Commentary:
29
30 ;;; split off of mule.el.
31
32 ;;; Code:
33
34 (defalias 'check-coding-system 'get-coding-system)
35
36 (defconst modeline-multibyte-status '("%C")
37   "Modeline control for showing multibyte extension status.")
38
39 ;; override the default value defined in loaddefs.el.
40 (setq-default modeline-format
41               (cons ""
42                     (cons 'modeline-multibyte-status
43                           (cdr modeline-format))))
44
45 (defun modify-coding-system-alist (target-type regexp coding-system)
46   "Modify one of look up tables for finding a coding system on I/O operation.
47 There are three of such tables, `file-coding-system-alist',
48 `process-coding-system-alist', and `network-coding-system-alist'.
49
50 TARGET-TYPE specifies which of them to modify.
51 If it is `file', it affects `file-coding-system-alist' (which see).
52 If it is `process', it affects `process-coding-system-alist' (which see).
53 If it is `network', it affects `network-coding-system-alist' (which see).
54
55 REGEXP is a regular expression matching a target of I/O operation.
56 The target is a file name if TARGET-TYPE is `file', a program name if
57 TARGET-TYPE is `process', or a network service name or a port number
58 to connect to if TARGET-TYPE is `network'.
59
60 CODING-SYSTEM is a coding system to perform code conversion on the I/O
61 operation, or a cons cell (DECODING . ENCODING) specifying the coding systems
62 for decoding and encoding respectively,
63 or a function symbol which, when called, returns such a cons cell."
64   (or (memq target-type '(file process network))
65       (error "Invalid target type: %s" target-type))
66   (or (stringp regexp)
67       (and (eq target-type 'network) (integerp regexp))
68       (error "Invalid regular expression: %s" regexp))
69   (if (symbolp coding-system)
70       (if (not (fboundp coding-system))
71           (progn
72             (check-coding-system coding-system)
73             (setq coding-system (cons coding-system coding-system))))
74     (check-coding-system (car coding-system))
75     (check-coding-system (cdr coding-system)))
76   (cond ((eq target-type 'file)
77          (let ((slot (assoc regexp file-coding-system-alist)))
78            (if slot
79                (setcdr slot coding-system)
80              (setq file-coding-system-alist
81                    (cons (cons regexp coding-system)
82                          file-coding-system-alist)))))
83         ((eq target-type 'process)
84          (let ((slot (assoc regexp process-coding-system-alist)))
85            (if slot
86                (setcdr slot coding-system)
87              (setq process-coding-system-alist
88                    (cons (cons regexp coding-system)
89                          process-coding-system-alist)))))
90         (t
91          (let ((slot (assoc regexp network-coding-system-alist)))
92            (if slot
93                (setcdr slot coding-system)
94              (setq network-coding-system-alist
95                    (cons (cons regexp coding-system)
96                          network-coding-system-alist)))))))
97
98 (defsubst keyboard-coding-system ()
99   "Return coding-system of what is sent from terminal keyboard."
100   keyboard-coding-system)
101
102 (defun set-keyboard-coding-system (coding-system)
103   "Set the coding system used for TTY keyboard input. Currently broken."
104   (interactive "zkeyboard-coding-system: ")
105   (get-coding-system coding-system) ; correctness check
106   (setq keyboard-coding-system coding-system)
107   (if (eq (device-type) 'tty)
108       (set-console-tty-input-coding-system
109        (device-console) keyboard-coding-system))
110   (redraw-modeline t))
111
112 (defsubst terminal-coding-system ()
113   "Return coding-system of your terminal."
114   terminal-coding-system)
115
116 (defun set-terminal-coding-system (coding-system)
117   "Set the coding system used for TTY display output. Currently broken."
118   (interactive "zterminal-coding-system: ")
119   (get-coding-system coding-system) ; correctness check
120   (setq terminal-coding-system coding-system)
121   ; #### should this affect all current tty consoles ?
122   (if (eq (device-type) 'tty)
123       (set-console-tty-output-coding-system
124        (device-console) terminal-coding-system))
125   (redraw-modeline t))
126
127 (defun set-pathname-coding-system (coding-system)
128   "Set the coding system used for file system path names."
129   (interactive "zPathname-coding-system: ")
130   (get-coding-system coding-system) ; correctness check
131   (setq file-name-coding-system coding-system))
132
133 (defun what-coding-system (start end &optional arg)
134   "Show the encoding of text in the region.
135 This function is meant to be called interactively;
136 from a Lisp program, use `detect-coding-region' instead."
137   (interactive "r\nP")
138   (princ (detect-coding-region start end)))
139
140 (defun decode-coding-string (str coding-system)
141   "Decode the string STR which is encoded in CODING-SYSTEM.
142 Does not modify STR.  Returns the decoded string on successful conversion."
143   (with-string-as-buffer-contents
144    str (decode-coding-region (point-min) (point-max) coding-system)))
145
146 (defun encode-coding-string (str coding-system)
147   "Encode the string STR using CODING-SYSTEM.
148 Does not modify STR.  Returns the encoded string on successful conversion."
149   (with-string-as-buffer-contents
150    str (encode-coding-region (point-min) (point-max) coding-system)))
151
152 \f
153 ;;;; Coding system accessors
154
155 (defun coding-system-mnemonic (coding-system)
156   "Return the 'mnemonic property of CODING-SYSTEM."
157   (coding-system-property coding-system 'mnemonic))
158
159 (defalias 'coding-system-docstring 'coding-system-doc-string)
160
161 (defun coding-system-eol-type (coding-system)
162   "Return the 'eol-type property of CODING-SYSTEM."
163   (coding-system-property coding-system 'eol-type))
164
165 (defun coding-system-eol-lf (coding-system)
166   "Return the 'eol-lf property of CODING-SYSTEM."
167   (coding-system-property coding-system 'eol-lf))
168
169 (defun coding-system-eol-crlf (coding-system)
170   "Return the 'eol-crlf property of CODING-SYSTEM."
171   (coding-system-property coding-system 'eol-crlf))
172
173 (defun coding-system-eol-cr (coding-system)
174   "Return the 'eol-cr property of CODING-SYSTEM."
175   (coding-system-property coding-system 'eol-cr))
176
177 (defun coding-system-post-read-conversion (coding-system)
178   "Return the 'post-read-conversion property of CODING-SYSTEM."
179   (coding-system-property coding-system 'post-read-conversion))
180
181 (defun coding-system-pre-write-conversion (coding-system)
182   "Return the 'pre-write-conversion property of CODING-SYSTEM."
183   (coding-system-property coding-system 'pre-write-conversion))
184
185 (defun coding-system-base (coding-system)
186   "Return the base coding system of CODING-SYSTEM."
187   (if (not (coding-system-eol-type coding-system))
188       coding-system
189     (find-coding-system
190      (intern
191       (substring
192        (symbol-name (coding-system-name coding-system))
193        0
194        (string-match "-unix$\\|-dos$\\|-mac$"
195                      (symbol-name (coding-system-name coding-system))))))))
196 \f
197 ;;;; Definitions of predefined coding systems
198
199 (make-coding-system
200  'undecided 'undecided
201  "Automatic conversion."
202  '(mnemonic "Auto"))
203
204 ;;; Make certain variables equivalent to coding-system aliases
205 (defun dontusethis-set-value-file-name-coding-system-handler (sym args fun harg handlers)
206   (define-coding-system-alias 'file-name (or (car args) 'binary)))
207
208 (dontusethis-set-symbol-value-handler
209  'file-name-coding-system
210  'set-value
211  'dontusethis-set-value-file-name-coding-system-handler)
212
213 (defun dontusethis-set-value-terminal-coding-system-handler (sym args fun harg handlers)
214   (define-coding-system-alias 'terminal (or (car args) 'binary)))
215
216 (dontusethis-set-symbol-value-handler
217  'terminal-coding-system
218  'set-value
219  'dontusethis-set-value-terminal-coding-system-handler)
220
221 (defun dontusethis-set-value-keyboard-coding-system-handler (sym args fun harg handlers)
222   (define-coding-system-alias 'keyboard (or (car args) 'binary)))
223
224 (dontusethis-set-symbol-value-handler
225  'keyboard-coding-system
226  'set-value
227  'dontusethis-set-value-keyboard-coding-system-handler)
228
229 (unless (boundp 'file-name-coding-system)
230   (setq file-name-coding-system nil))
231
232 (when (not (featurep 'mule))
233   ;; these are so that gnus and friends work when not mule
234   (copy-coding-system 'undecided 'iso-8859-1)
235   (copy-coding-system 'undecided 'iso-8859-2)
236
237   (define-coding-system-alias 'ctext 'binary))
238
239
240 ;; compatibility for old XEmacsen (don't use it)
241 (copy-coding-system 'undecided 'automatic-conversion)
242
243 (make-compatible-variable 'enable-multibyte-characters "Unimplemented")
244
245 (define-obsolete-variable-alias
246   'pathname-coding-system 'file-name-coding-system)
247
248 ;;; mule-coding.el ends here