home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / mule / mule-coding.el.z / mule-coding.el
Encoding:
Text File  |  1998-05-21  |  11.2 KB  |  327 lines
  1. ;;; mule-coding.el --- Coding-system functions for Mule.
  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. ;; XEmacs is free software; you can redistribute it and/or modify it
  12. ;; under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; XEmacs is distributed in the hope that it will be useful, but
  17. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19. ;; General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  23. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24. ;; Boston, MA 02111-1307, USA.
  25.  
  26. ;;; Commentary:
  27.  
  28. ;;; split off of mule.el.
  29.  
  30. ;;; Code:
  31.  
  32. (defalias 'check-coding-system 'get-coding-system)
  33.  
  34. (defun modify-coding-system-alist (target-type regexp coding-system)
  35.   "Modify one of look up tables for finding a coding system on I/O operation.
  36. There are three of such tables, `file-coding-system-alist',
  37. `process-coding-system-alist', and `network-coding-system-alist'.
  38.  
  39. TARGET-TYPE specifies which of them to modify.
  40. If it is `file', it affects `file-coding-system-alist' (which see).
  41. If it is `process', it affects `process-coding-system-alist' (which see).
  42. If it is `network', it affects `network-codign-system-alist' (which see).
  43.  
  44. REGEXP is a regular expression matching a target of I/O operation.
  45. The target is a file name if TARGET-TYPE is `file', a program name if
  46. TARGET-TYPE is `process', or a network service name or a port number
  47. to connect to if TARGET-TYPE is `network'.
  48.  
  49. CODING-SYSTEM is a coding system to perform code conversion on the I/O
  50. operation, or a cons cell (DECODING . ENCODING) specifying the coding systems
  51. for decoding and encoding respectively,
  52. or a function symbol which, when called, returns such a cons cell."
  53.   (or (memq target-type '(file process network))
  54.       (error "Invalid target type: %s" target-type))
  55.   (or (stringp regexp)
  56.       (and (eq target-type 'network) (integerp regexp))
  57.       (error "Invalid regular expression: %s" regexp))
  58.   (if (symbolp coding-system)
  59.       (if (not (fboundp coding-system))
  60.       (progn
  61.         (check-coding-system coding-system)
  62.         (setq coding-system (cons coding-system coding-system))))
  63.     (check-coding-system (car coding-system))
  64.     (check-coding-system (cdr coding-system)))
  65.   (cond ((eq target-type 'file)
  66.      (let ((slot (assoc regexp file-coding-system-alist)))
  67.        (if slot
  68.            (setcdr slot coding-system)
  69.          (setq file-coding-system-alist
  70.            (cons (cons regexp coding-system)
  71.              file-coding-system-alist)))))
  72.     ((eq target-type 'process)
  73.      (let ((slot (assoc regexp process-coding-system-alist)))
  74.        (if slot
  75.            (setcdr slot coding-system)
  76.          (setq process-coding-system-alist
  77.            (cons (cons regexp coding-system)
  78.              process-coding-system-alist)))))
  79.     (t
  80.      (let ((slot (assoc regexp network-coding-system-alist)))
  81.        (if slot
  82.            (setcdr slot coding-system)
  83.          (setq network-coding-system-alist
  84.            (cons (cons regexp coding-system)
  85.              network-coding-system-alist)))))))
  86.  
  87. (defsubst keyboard-coding-system ()
  88.   "Return coding-system of what is sent from terminal keyboard."
  89.   keyboard-coding-system)
  90.  
  91. (defun set-keyboard-coding-system (coding-system)
  92.   "Set the coding system used for TTY keyboard input. Currently broken."
  93.   (interactive "zkeyboard-coding-system: ")
  94.   (get-coding-system coding-system) ; correctness check
  95.   (setq keyboard-coding-system coding-system)
  96.   (redraw-modeline t))
  97.  
  98. (defsubst terminal-coding-system ()
  99.   "Return coding-system of your terminal."
  100.   terminal-coding-system)
  101.  
  102. (defun set-terminal-coding-system (coding-system)
  103.   "Set the coding system used for TTY display output. Currently broken."
  104.   (interactive "zterminal-coding-system: ")
  105.   (get-coding-system coding-system) ; correctness check
  106.   (setq terminal-coding-system coding-system)
  107.   (redraw-modeline t))
  108.  
  109. (defun set-pathname-coding-system (coding-system)
  110.   "Set the coding system used for file system path names."
  111.   (interactive "zPathname-coding-system: ")
  112.   (get-coding-system coding-system) ; correctness check
  113.   (setq file-name-coding-system coding-system))
  114.  
  115. (defun what-coding-system (start end &optional arg)
  116.   "Show the encoding of text in the region.
  117. This function is meant to be called interactively;
  118. from a Lisp program, use `detect-coding-region' instead."
  119.   (interactive "r\nP")
  120.   (princ (detect-coding-region start end)))
  121.  
  122. (defun decode-coding-string (str coding-system)
  123.   "Decode the string STR which is encoded in CODING-SYSTEM.
  124. Does not modify STR.  Returns the decoded string on successful conversion."
  125.   (with-string-as-buffer-contents
  126.    str (decode-coding-region (point-min) (point-max) coding-system)))
  127.  
  128. (defun encode-coding-string (str coding-system)
  129.   "Encode the string STR using CODING-SYSTEM.
  130. Does not modify STR.  Returns the encoded string on successful conversion."
  131.   (with-string-as-buffer-contents
  132.    str (encode-coding-region (point-min) (point-max) coding-system)))
  133.  
  134.  
  135. ;;;; Coding system accessors
  136.  
  137. (defun coding-system-mnemonic (coding-system)
  138.   "Return the 'mnemonic property of CODING-SYSTEM."
  139.   (coding-system-property coding-system 'mnemonic))
  140.  
  141. (defalias 'coding-system-docstring 'coding-system-doc-string)
  142.  
  143. (defun coding-system-eol-type (coding-system)
  144.   "Return the 'eol-type property of CODING-SYSTEM."
  145.   (coding-system-property coding-system 'eol-type))
  146.  
  147. (defun coding-system-eol-lf (coding-system)
  148.   "Return the 'eol-lf property of CODING-SYSTEM."
  149.   (coding-system-property coding-system 'eol-lf))
  150.  
  151. (defun coding-system-eol-crlf (coding-system)
  152.   "Return the 'eol-crlf property of CODING-SYSTEM."
  153.   (coding-system-property coding-system 'eol-crlf))
  154.  
  155. (defun coding-system-eol-cr (coding-system)
  156.   "Return the 'eol-cr property of CODING-SYSTEM."
  157.   (coding-system-property coding-system 'eol-cr))
  158.  
  159. (defun coding-system-post-read-conversion (coding-system)
  160.   "Return the 'post-read-conversion property of CODING-SYSTEM."
  161.   (coding-system-property coding-system 'post-read-conversion))
  162.  
  163. (defun coding-system-pre-write-conversion (coding-system)
  164.   "Return the 'pre-write-conversion property of CODING-SYSTEM."
  165.   (coding-system-property coding-system 'pre-write-conversion))
  166.  
  167. (defun coding-system-force-on-output (coding-system register)
  168.   "Return the 'force-on-output property of CODING-SYSTEM for the specified REGISTER."
  169.   (unless (integerp register)
  170.     (signal 'wrong-type-argument (list 'integerp register)))
  171.   (coding-system-property
  172.    coding-system
  173.    (case register
  174.      (0 'force-g0-on-output)
  175.      (1 'force-g1-on-output)
  176.      (2 'force-g2-on-output)
  177.      (3 'force-g3-on-output)
  178.      (t (signal 'args-out-of-range (list register 0 3))))))
  179.  
  180. (defun coding-system-short (coding-system)
  181.   "Return the 'short property of CODING-SYSTEM."
  182.   (coding-system-property coding-system 'short))
  183.  
  184. (defun coding-system-no-ascii-eol (coding-system)
  185.   "Return the 'no-ascii-eol property of CODING-SYSTEM."
  186.   (coding-system-property coding-system 'no-ascii-eol))
  187.  
  188. (defun coding-system-no-ascii-cntl (coding-system)
  189.   "Return the 'no-ascii-cntl property of CODING-SYSTEM."
  190.   (coding-system-property coding-system 'no-ascii-cntl))
  191.  
  192. (defun coding-system-seven (coding-system)
  193.   "Return the 'seven property of CODING-SYSTEM."
  194.   (coding-system-property coding-system 'seven))
  195.  
  196. (defun coding-system-lock-shift (coding-system)
  197.   "Return the 'lock-shift property of CODING-SYSTEM."
  198.   (coding-system-property coding-system 'lock-shift))
  199.  
  200. ;;(defun coding-system-use-japanese-jisx0201-roman (coding-system)
  201. ;;  "Return the 'use-japanese-jisx0201-roman property of CODING-SYSTEM."
  202. ;;  (coding-system-property coding-system 'use-japanese-jisx0201-roman))
  203.  
  204. ;;(defun coding-system-use-japanese-jisx0208-1978 (coding-system)
  205. ;;  "Return the 'use-japanese-jisx0208-1978 property of CODING-SYSTEM."
  206. ;;  (coding-system-property coding-system 'use-japanese-jisx0208-2978))
  207.  
  208. (defun coding-system-no-iso6429 (coding-system)
  209.   "Return the 'no-iso6429 property of CODING-SYSTEM."
  210.   (coding-system-property coding-system 'no-iso6429))
  211.  
  212. (defun coding-system-ccl-encode (coding-system)
  213.   "Return the CCL 'encode property of CODING-SYSTEM."
  214.   (coding-system-property coding-system 'encode))
  215.  
  216. (defun coding-system-ccl-decode (coding-system)
  217.   "Return the CCL 'decode property of CODING-SYSTEM."
  218.   (coding-system-property coding-system 'decode))
  219.  
  220.  
  221. ;;;; Definitions of predefined coding systems
  222.  
  223. (make-coding-system
  224.  'undecided 'undecided
  225.  "Automatic conversion."
  226.  '(mnemonic "Auto"))
  227.  
  228. ;; compatibility for old XEmacsen (don't use it)
  229. (copy-coding-system 'undecided 'automatic-conversion)
  230.  
  231. (copy-coding-system 'no-conversion 'raw-text)
  232.  
  233. (make-coding-system
  234.  'ctext 'iso2022
  235.  "Coding-system used in X as Compound Text Encoding."
  236.  '(charset-g0 ascii
  237.    charset-g1 latin-iso8859-1
  238.    eol-type lf
  239.    mnemonic "CText"
  240.    ))
  241.  
  242. ;;; iso-8859-1 and ctext are aliases.
  243.  
  244. (copy-coding-system 'ctext 'iso-8859-1)
  245.  
  246. (make-coding-system
  247.  'iso-2022-8bit-ss2 'iso2022
  248.  "ISO-2022 coding system using SS2 for 96-charset in 8-bit code."
  249.  '(charset-g0 ascii
  250.    charset-g1 latin-iso8859-1
  251.    charset-g2 t ;; unspecified but can be used later.
  252.    short t
  253.    mnemonic "ISO8/SS"
  254.    ))
  255.  
  256. (make-coding-system
  257.  'iso-2022-7bit-ss2 'iso2022
  258.  "ISO-2022 coding system using SS2 for 96-charset in 7-bit code."
  259.  '(charset-g0 ascii
  260.    charset-g2 t ;; unspecified but can be used later.
  261.    seven t
  262.    short t
  263.    mnemonic "ISO7/SS"
  264.    ))
  265.  
  266. (copy-coding-system 'iso-2022-7bit-ss2 'iso-2022-jp-2)
  267.  
  268. (make-coding-system
  269.  'iso-2022-7bit 'iso2022
  270.  "ISO 2022 based 7-bit encoding using only G0"
  271.  '(charset-g0 ascii
  272.    seven t
  273.    short t
  274.    mnemonic "ISO7"))
  275.  
  276. ;; compatibility for old XEmacsen
  277. (copy-coding-system 'iso-2022-7bit 'iso-2022-7)
  278.  
  279. (make-coding-system
  280.  'iso-2022-8 'iso2022
  281.  "ISO-2022 eight-bit coding system.  No single-shift or locking-shift."
  282.  '(charset-g0 ascii
  283.    charset-g1 latin-iso8859-1
  284.    short t
  285.    mnemonic "ISO8"
  286.    ))
  287.  
  288. (make-coding-system
  289.  'escape-quoted 'iso2022
  290.  "ISO-2022 eight-bit coding system with escape quoting; used for .ELC files."
  291.  '(charset-g0 ascii
  292.    charset-g1 latin-iso8859-1
  293.    eol-type lf
  294.    escape-quoted t
  295.    mnemonic "ESC/Quot"
  296.    ))
  297.  
  298. (make-coding-system
  299.  'iso-2022-lock 'iso2022
  300.  "ISO-2022 coding system using Locking-Shift for 96-charset."
  301.  '(charset-g0 ascii
  302.    charset-g1 t ;; unspecified but can be used later.
  303.    seven t
  304.    lock-shift t
  305.    mnemonic "ISO7/Lock"
  306.    ))
  307.  
  308. ;; initialize the coding categories to something semi-reasonable
  309. ;; so that the remaining Lisp files can contain extended characters.
  310. ;; (They will be in ISO-7 format)
  311.  
  312. (set-coding-priority-list '(iso-8-2 iso-8-designate iso-8-1
  313.                 iso-7 iso-lock-shift no-conversion))
  314.  
  315. (set-coding-category-system 'iso-7 'iso-2022-7)
  316. (set-coding-category-system 'iso-8-designate 'ctext)
  317. (set-coding-category-system 'iso-8-1 'ctext)
  318. (set-coding-category-system 'iso-lock-shift 'iso-2022-lock)
  319. (set-coding-category-system 'no-conversion 'no-conversion)
  320.  
  321. (make-compatible-variable 'enable-multibyte-characters "Unimplemented")
  322.  
  323. (define-obsolete-variable-alias
  324.   'pathname-coding-system 'file-name-coding-system)
  325.  
  326. ;;; mule-coding.el ends here
  327.