Mercurial > hg > xemacs-beta
annotate lisp/coding.el @ 4525:d64f1060cd65
Fix off-by-one error in ccl_driver. <87iqr7v7p0.fsf@uwakimon.sk.tsukuba.ac.jp>
| author | Stephen J. Turnbull <stephen@xemacs.org> |
|---|---|
| date | Sat, 01 Nov 2008 23:32:53 +0900 |
| parents | e34711681f30 |
| children | 46ddeaa7c738 |
| rev | line source |
|---|---|
| 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) | |
|
4477
e34711681f30
Don't determine whether to call general device-type code at startup,
Aidan Kehoe <kehoea@parhasard.net>
parents:
4227
diff
changeset
|
111 "Set the coding system used for TTY display output." |
| 428 | 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) | |
| 3767 | 203 (unicode (case (coding-system-property coding-system 'unicode-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 |
| 4227 | 269 (define-coding-system-alias 'iso-8859-1 'raw-text) |
| 4222 | 270 ;; We're misrepresenting ourselves to the gnus code by saying we support |
| 271 ;; both. | |
| 4227 | 272 ; (define-coding-system-alias 'iso-8859-2 'raw-text) |
| 273 (define-coding-system-alias 'ctext 'raw-text)) | |
| 440 | 274 |
| 428 | 275 (make-compatible-variable 'enable-multibyte-characters "Unimplemented") |
| 276 | |
| 728 | 277 ;;; coding.el ends here |