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