git.chise.org Git - chise/xemacs-chise.git.1/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 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 (purecopy "")
  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-codign-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   (redraw-modeline t))
 108
 109 (defsubst terminal-coding-system ()
 110   "Return coding-system of your terminal."
 111   terminal-coding-system)
 112
 113 (defun set-terminal-coding-system (coding-system)
 114   "Set the coding system used for TTY display output. Currently broken."
 115   (interactive "zterminal-coding-system: ")
 116   (get-coding-system coding-system) ; correctness check
 117   (setq terminal-coding-system coding-system)
 118   ; #### should this affect all current tty consoles ?
 119   (if (eq (device-type) 'tty)
 120       (set-console-tty-coding-system (device-console) terminal-coding-system))
 121   (redraw-modeline t))
 122
 123 (defun set-pathname-coding-system (coding-system)
 124   "Set the coding system used for file system path names."
 125   (interactive "zPathname-coding-system: ")
 126   (get-coding-system coding-system) ; correctness check
 127   (setq file-name-coding-system coding-system))
 128
 129 (defun what-coding-system (start end &optional arg)
 130   "Show the encoding of text in the region.
 131 This function is meant to be called interactively;
 132 from a Lisp program, use `detect-coding-region' instead."
 133   (interactive "r\nP")
 134   (princ (detect-coding-region start end)))
 135
 136 (defun decode-coding-string (str coding-system)
 137   "Decode the string STR which is encoded in CODING-SYSTEM.
 138 Does not modify STR.  Returns the decoded string on successful conversion."
 139   (with-string-as-buffer-contents
 140    str (decode-coding-region (point-min) (point-max) coding-system)))
 141
 142 (defun encode-coding-string (str coding-system)
 143   "Encode the string STR using CODING-SYSTEM.
 144 Does not modify STR.  Returns the encoded string on successful conversion."
 145   (with-string-as-buffer-contents
 146    str (encode-coding-region (point-min) (point-max) coding-system)))
 147
 148 \f
 149 ;;;; Coding system accessors
 150
 151 (defun coding-system-mnemonic (coding-system)
 152   "Return the 'mnemonic property of CODING-SYSTEM."
 153   (coding-system-property coding-system 'mnemonic))
 154
 155 (defalias 'coding-system-docstring 'coding-system-doc-string)
 156
 157 (defun coding-system-eol-type (coding-system)
 158   "Return the 'eol-type property of CODING-SYSTEM."
 159   (coding-system-property coding-system 'eol-type))
 160
 161 (defun coding-system-eol-lf (coding-system)
 162   "Return the 'eol-lf property of CODING-SYSTEM."
 163   (coding-system-property coding-system 'eol-lf))
 164
 165 (defun coding-system-eol-crlf (coding-system)
 166   "Return the 'eol-crlf property of CODING-SYSTEM."
 167   (coding-system-property coding-system 'eol-crlf))
 168
 169 (defun coding-system-eol-cr (coding-system)
 170   "Return the 'eol-cr property of CODING-SYSTEM."
 171   (coding-system-property coding-system 'eol-cr))
 172
 173 (defun coding-system-post-read-conversion (coding-system)
 174   "Return the 'post-read-conversion property of CODING-SYSTEM."
 175   (coding-system-property coding-system 'post-read-conversion))
 176
 177 (defun coding-system-pre-write-conversion (coding-system)
 178   "Return the 'pre-write-conversion property of CODING-SYSTEM."
 179   (coding-system-property coding-system 'pre-write-conversion))
 180
 181 (defun coding-system-base (coding-system)
 182   "Return the base coding system of CODING-SYSTEM."
 183   (if (not (coding-system-eol-type coding-system))
 184       coding-system
 185     (find-coding-system
 186      (intern
 187       (substring
 188        (symbol-name (coding-system-name coding-system))
 189        0
 190        (string-match "-unix$\\|-dos$\\|-mac$"
 191                      (symbol-name (coding-system-name coding-system))))))))
 192 \f
 193 ;;;; Definitions of predefined coding systems
 194
 195 (make-coding-system
 196  'undecided 'undecided
 197  "Automatic conversion."
 198  '(mnemonic "Auto"))
 199
 200 ;;; Make certain variables equivalent to coding-system aliases
 201 (defun dontusethis-set-value-file-name-coding-system-handler (sym args fun harg handlers)
 202   (define-coding-system-alias 'file-name (or (car args) 'binary)))
 203
 204 (dontusethis-set-symbol-value-handler
 205  'file-name-coding-system
 206  'set-value
 207  'dontusethis-set-value-file-name-coding-system-handler)
 208
 209 (defun dontusethis-set-value-terminal-coding-system-handler (sym args fun harg handlers)
 210   (define-coding-system-alias 'terminal (or (car args) 'binary)))
 211
 212 (dontusethis-set-symbol-value-handler
 213  'terminal-coding-system
 214  'set-value
 215  'dontusethis-set-value-terminal-coding-system-handler)
 216
 217 (defun dontusethis-set-value-keyboard-coding-system-handler (sym args fun harg handlers)
 218   (define-coding-system-alias 'keyboard (or (car args) 'binary)))
 219
 220 (dontusethis-set-symbol-value-handler
 221  'keyboard-coding-system
 222  'set-value
 223  'dontusethis-set-value-keyboard-coding-system-handler)
 224
 225 (unless (boundp 'file-name-coding-system)
 226   (setq file-name-coding-system nil))
 227
 228 (when (not (featurep 'mule))
 229   ;; these are so that gnus and friends work when not mule
 230   (copy-coding-system 'undecided 'iso-8859-1)
 231   (copy-coding-system 'undecided 'iso-8859-2)
 232
 233   (define-coding-system-alias 'ctext 'binary))
 234
 235
 236 ;; compatibility for old XEmacsen (don't use it)
 237 (copy-coding-system 'undecided 'automatic-conversion)
 238
 239 (make-compatible-variable 'enable-multibyte-characters "Unimplemented")
 240
 241 (define-obsolete-variable-alias
 242   'pathname-coding-system 'file-name-coding-system)
 243
 244 ;;; mule-coding.el ends here