emu-x20.el

   1 ;;; emu-x20.el --- emu API implementation for XEmacs with mule
   2
   3 ;; Copyright (C) 1994,1995,1996,1997,1998 MORIOKA Tomohiko
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Keywords: emulation, compatibility, Mule, XEmacs
   7
   8 ;; This file is part of emu.
   9
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;    This module requires XEmacs 20.3-b5 or later with mule.
  28
  29 ;;; Code:
  30
  31 (require 'emu-20)
  32
  33
  34 (and (coding-system-property 'iso-2022-jp 'input-charset-conversion)
  35      (copy-coding-system 'iso-2022-7bit 'iso-2022-jp))
  36
  37 (or (find-coding-system 'raw-text-dos)
  38     (copy-coding-system 'no-conversion-dos 'raw-text-dos))
  39 (or (find-coding-system 'raw-text-mac)
  40     (copy-coding-system 'no-conversion-mac 'raw-text-mac))
  41 (or (find-coding-system 'raw-text-unix)
  42     (copy-coding-system 'no-conversion-unix 'raw-text-unix))
  43
  44 (or (find-coding-system 'euc-kr-dos)
  45     (make-coding-system
  46      'euc-kr 'iso2022
  47      "Coding-system of Korean EUC (Extended Unix Code)."
  48      '(charset-g0 ascii charset-g1 korean-ksc5601
  49                   mnemonic "ko/EUC"
  50                   eol-type nil)))
  51
  52
  53 ;;; @ without code-conversion
  54 ;;;
  55
  56 (define-obsolete-function-alias 'insert-binary-file-contents
  57   'insert-file-contents-as-binary)
  58
  59 (defun insert-binary-file-contents-literally (filename
  60                                               &optional visit beg end replace)
  61   "Like `insert-file-contents-literally', q.v., but don't code conversion.
  62 A buffer may be modified in several ways after reading into the buffer due
  63 to advanced Emacs features, such as file-name-handlers, format decoding,
  64 find-file-hooks, etc.
  65   This function ensures that none of these modifications will take place."
  66   (let ((coding-system-for-read 'binary))
  67     (insert-file-contents-literally filename visit beg end replace)
  68     ))
  69
  70
  71 ;;; @ MIME charset
  72 ;;;
  73
  74 (defun encode-mime-charset-region (start end charset)
  75   "Encode the text between START and END as MIME CHARSET."
  76   (let ((cs (mime-charset-to-coding-system charset)))
  77     (if cs
  78         (encode-coding-region start end cs)
  79       )))
  80
  81 (defcustom mime-charset-decoder-alist
  82   '((iso-2022-jp . decode-mime-charset-region-with-iso646-unification)
  83     (iso-2022-jp-2 . decode-mime-charset-region-with-iso646-unification)
  84     (x-ctext . decode-mime-charset-region-with-iso646-unification)
  85     (hz-gb-2312 . decode-mime-charset-region-for-hz)
  86     (t . decode-mime-charset-region-default))
  87   "Alist MIME-charset vs. decoder function."
  88   :group 'i18n
  89   :type '(repeat (cons mime-charset function)))
  90
  91 (defsubst decode-mime-charset-region-default (start end charset lbt)
  92   (let ((cs (mime-charset-to-coding-system charset lbt)))
  93     (if cs
  94         (decode-coding-region start end cs)
  95       )))
  96
  97 (defcustom mime-iso646-character-unification-alist
  98   `,(let (dest
  99           (i 33))
 100       (while (< i 92)
 101         (setq dest
 102               (cons (cons (char-to-string (make-char 'latin-jisx0201 i))
 103                           (format "%c" i))
 104                     dest))
 105         (setq i (1+ i)))
 106       (setq i 93)
 107       (while (< i 126)
 108         (setq dest
 109               (cons (cons (char-to-string (make-char 'latin-jisx0201 i))
 110                           (format "%c" i))
 111                     dest))
 112         (setq i (1+ i)))
 113       (nreverse dest))
 114   "Alist unified string vs. canonical string."
 115   :group 'i18n
 116   :type '(repeat (cons string string)))
 117
 118 (defcustom mime-unified-character-face nil
 119   "*Face of unified character."
 120   :group 'i18n
 121   :type 'face)
 122
 123 (defcustom mime-character-unification-limit-size 2048
 124   "*Limit size to unify characters."
 125   :group 'i18n
 126   :type 'integer)
 127
 128 (defun decode-mime-charset-region-with-iso646-unification (start end charset
 129                                                                  lbt)
 130   (decode-mime-charset-region-default start end charset lbt)
 131   (if (<= (- end start) mime-character-unification-limit-size)
 132       (save-excursion
 133         (let ((rest mime-iso646-character-unification-alist))
 134           (while rest
 135             (let ((pair (car rest)))
 136               (goto-char (point-min))
 137               (while (search-forward (car pair) nil t)
 138                 (let ((str (cdr pair)))
 139                   (put-text-property 0 (length str)
 140                                      'face mime-unified-character-face str)
 141                   (replace-match str 'fixed-case 'literal)
 142                   )
 143                 ))
 144             (setq rest (cdr rest)))))
 145     ))
 146
 147 (defun decode-mime-charset-region-for-hz (start end charset lbt)
 148   (if lbt
 149       (save-restriction
 150         (narrow-to-region start end)
 151         (decode-coding-region (point-min)(point-max)
 152                               (mime-charset-to-coding-system 'raw-text lbt))
 153         (decode-hz-region (point-min)(point-max))
 154         )
 155     (decode-hz-region start end)
 156     ))
 157
 158 (defun decode-mime-charset-region (start end charset &optional lbt)
 159   "Decode the text between START and END as MIME CHARSET."
 160   (if (stringp charset)
 161       (setq charset (intern (downcase charset)))
 162     )
 163   (let ((func (cdr (or (assq charset mime-charset-decoder-alist)
 164                        (assq t mime-charset-decoder-alist)))))
 165     (funcall func start end charset lbt)
 166     ))
 167
 168 (defsubst encode-mime-charset-string (string charset)
 169   "Encode the STRING as MIME CHARSET."
 170   (let ((cs (mime-charset-to-coding-system charset)))
 171     (if cs
 172         (encode-coding-string string cs)
 173       string)))
 174
 175 ;; (defsubst decode-mime-charset-string (string charset)
 176 ;;   "Decode the STRING as MIME CHARSET."
 177 ;;   (let ((cs (mime-charset-to-coding-system charset)))
 178 ;;     (if cs
 179 ;;         (decode-coding-string string cs)
 180 ;;       string)))
 181 (defun decode-mime-charset-string (string charset &optional lbt)
 182   "Decode the STRING as MIME CHARSET."
 183   (with-temp-buffer
 184     (insert string)
 185     (decode-mime-charset-region (point-min)(point-max) charset lbt)
 186     (buffer-string)
 187     ))
 188
 189
 190 (defvar charsets-mime-charset-alist
 191   '(((ascii)                                            . us-ascii)
 192     ((ascii latin-iso8859-1)                            . iso-8859-1)
 193     ((ascii latin-iso8859-2)                            . iso-8859-2)
 194     ((ascii latin-iso8859-3)                            . iso-8859-3)
 195     ((ascii latin-iso8859-4)                            . iso-8859-4)
 196     ((ascii cyrillic-iso8859-5)                         . iso-8859-5)
 197 ;;; ((ascii cyrillic-iso8859-5)                         . koi8-r)
 198     ((ascii arabic-iso8859-6)                           . iso-8859-6)
 199     ((ascii greek-iso8859-7)                            . iso-8859-7)
 200     ((ascii hebrew-iso8859-8)                           . iso-8859-8)
 201     ((ascii latin-iso8859-9)                            . iso-8859-9)
 202     ((ascii latin-jisx0201
 203             japanese-jisx0208-1978 japanese-jisx0208)   . iso-2022-jp)
 204     ((ascii latin-jisx0201
 205             katakana-jisx0201 japanese-jisx0208)        . shift_jis)
 206     ((ascii korean-ksc5601)                             . euc-kr)
 207     ((ascii chinese-gb2312)                             . cn-gb-2312)
 208     ((ascii chinese-big5-1 chinese-big5-2)              . cn-big5)
 209     ((ascii latin-iso8859-1 greek-iso8859-7
 210             latin-jisx0201 japanese-jisx0208-1978
 211             chinese-gb2312 japanese-jisx0208
 212             korean-ksc5601 japanese-jisx0212)           . iso-2022-jp-2)
 213     ((ascii latin-iso8859-1 greek-iso8859-7
 214             latin-jisx0201 japanese-jisx0208-1978
 215             chinese-gb2312 japanese-jisx0208
 216             korean-ksc5601 japanese-jisx0212
 217             chinese-cns11643-1 chinese-cns11643-2)      . iso-2022-int-1)
 218     ((ascii latin-iso8859-1 latin-iso8859-2
 219             cyrillic-iso8859-5 greek-iso8859-7
 220             latin-jisx0201 japanese-jisx0208-1978
 221             chinese-gb2312 japanese-jisx0208
 222             korean-ksc5601 japanese-jisx0212
 223             chinese-cns11643-1 chinese-cns11643-2
 224             chinese-cns11643-3 chinese-cns11643-4
 225             chinese-cns11643-5 chinese-cns11643-6
 226             chinese-cns11643-7)                         . iso-2022-int-1)
 227     ))
 228
 229
 230 ;;; @ buffer representation
 231 ;;;
 232
 233 (defsubst-maybe set-buffer-multibyte (flag)
 234   "Set the multibyte flag of the current buffer to FLAG.
 235 If FLAG is t, this makes the buffer a multibyte buffer.
 236 If FLAG is nil, this makes the buffer a single-byte buffer.
 237 The buffer contents remain unchanged as a sequence of bytes
 238 but the contents viewed as characters do change.
 239 \[Emacs 20.3 emulating function]"
 240   flag)
 241
 242
 243 ;;; @ character
 244 ;;;
 245
 246 ;; avoid bug of XEmacs
 247 (or (integerp (cdr (split-char ?a)))
 248     (defun split-char (char)
 249       "Return list of charset and one or two position-codes of CHAR."
 250       (let ((charset (char-charset char)))
 251         (if (eq charset 'ascii)
 252             (list charset (char-int char))
 253           (let ((i 0)
 254                 (len (charset-dimension charset))
 255                 (code (if (integerp char)
 256                           char
 257                         (char-int char)))
 258                 dest)
 259             (while (< i len)
 260               (setq dest (cons (logand code 127) dest)
 261                     code (lsh code -7)
 262                     i (1+ i)))
 263             (cons charset dest)
 264             ))))
 265     )
 266
 267 (defmacro char-next-index (char index)
 268   "Return index of character succeeding CHAR whose index is INDEX."
 269   `(1+ ,index))
 270
 271 ;;; @@ Mule emulating aliases
 272 ;;;
 273 ;;; You should not use them.
 274
 275 ;;(defalias 'char-leading-char 'char-charset)
 276
 277 (defun char-category (character)
 278   "Return string of category mnemonics for CHAR in TABLE.
 279 CHAR can be any multilingual character
 280 TABLE defaults to the current buffer's category table."
 281   (mapconcat (lambda (chr)
 282                (char-to-string (int-char chr))
 283                )
 284              (char-category-list character)
 285              ""))
 286
 287
 288 ;;; @ string
 289 ;;;
 290
 291 (defun string-to-int-list (str)
 292   (mapcar #'char-int str)
 293   )
 294
 295 (defalias 'looking-at-as-unibyte 'looking-at)
 296
 297
 298 ;;; @ end
 299 ;;;
 300
 301 (provide 'emu-x20)
 302
 303 ;;; emu-x20.el ends here