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