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 (or (find-coding-system 'iso-2022-jp-2-dos)
  53     (make-coding-system
  54      'iso-2022-jp-2 'iso2022
  55      "ISO-2022 coding system using SS2 for 96-charset in 7-bit code."
  56      '(charset-g0 ascii
  57        charset-g2 t ;; unspecified but can be used later.
  58        seven t
  59        short t
  60        mnemonic "ISO7/SS2"
  61        eol-type nil)))
  62
  63
  64 ;;; @ without code-conversion
  65 ;;;
  66
  67 (define-obsolete-function-alias 'insert-binary-file-contents
  68   'insert-file-contents-as-binary)
  69
  70 (defun insert-binary-file-contents-literally (filename
  71                                               &optional visit beg end replace)
  72   "Like `insert-file-contents-literally', q.v., but don't code conversion.
  73 A buffer may be modified in several ways after reading into the buffer due
  74 to advanced Emacs features, such as file-name-handlers, format decoding,
  75 find-file-hooks, etc.
  76   This function ensures that none of these modifications will take place."
  77   (let ((coding-system-for-read 'binary))
  78     (insert-file-contents-literally filename visit beg end replace)
  79     ))
  80
  81
  82 ;;; @ MIME charset
  83 ;;;
  84
  85 (defun encode-mime-charset-region (start end charset)
  86   "Encode the text between START and END as MIME CHARSET."
  87   (let ((cs (mime-charset-to-coding-system charset)))
  88     (if cs
  89         (encode-coding-region start end cs)
  90       )))
  91
  92 (defcustom mime-charset-decoder-alist
  93   '((iso-2022-jp . decode-mime-charset-region-with-iso646-unification)
  94     (iso-2022-jp-2 . decode-mime-charset-region-with-iso646-unification)
  95     (x-ctext . decode-mime-charset-region-with-iso646-unification)
  96     (hz-gb-2312 . decode-mime-charset-region-for-hz)
  97     (t . decode-mime-charset-region-default))
  98   "Alist MIME-charset vs. decoder function."
  99   :group 'i18n
 100   :type '(repeat (cons mime-charset function)))
 101
 102 (defsubst decode-mime-charset-region-default (start end charset lbt)
 103   (let ((cs (mime-charset-to-coding-system charset lbt)))
 104     (if cs
 105         (decode-coding-region start end cs)
 106       )))
 107
 108 (defcustom mime-iso646-character-unification-alist
 109   `,(let (dest
 110           (i 33))
 111       (while (< i 92)
 112         (setq dest
 113               (cons (cons (char-to-string (make-char 'latin-jisx0201 i))
 114                           (format "%c" i))
 115                     dest))
 116         (setq i (1+ i)))
 117       (setq i 93)
 118       (while (< i 126)
 119         (setq dest
 120               (cons (cons (char-to-string (make-char 'latin-jisx0201 i))
 121                           (format "%c" i))
 122                     dest))
 123         (setq i (1+ i)))
 124       (nreverse dest))
 125   "Alist unified string vs. canonical string."
 126   :group 'i18n
 127   :type '(repeat (cons string string)))
 128
 129 (defcustom mime-unified-character-face nil
 130   "*Face of unified character."
 131   :group 'i18n
 132   :type 'face)
 133
 134 (defcustom mime-character-unification-limit-size 2048
 135   "*Limit size to unify characters."
 136   :group 'i18n
 137   :type 'integer)
 138
 139 (defun decode-mime-charset-region-with-iso646-unification (start end charset
 140                                                                  lbt)
 141   (decode-mime-charset-region-default start end charset lbt)
 142   (if (<= (- end start) mime-character-unification-limit-size)
 143       (save-excursion
 144         (let ((rest mime-iso646-character-unification-alist))
 145           (while rest
 146             (let ((pair (car rest)))
 147               (goto-char (point-min))
 148               (while (search-forward (car pair) nil t)
 149                 (let ((str (cdr pair)))
 150                   (put-text-property 0 (length str)
 151                                      'face mime-unified-character-face str)
 152                   (replace-match str 'fixed-case 'literal)
 153                   )
 154                 ))
 155             (setq rest (cdr rest)))))
 156     ))
 157
 158 (defun decode-mime-charset-region-for-hz (start end charset lbt)
 159   (if lbt
 160       (save-restriction
 161         (narrow-to-region start end)
 162         (decode-coding-region (point-min)(point-max)
 163                               (mime-charset-to-coding-system 'raw-text lbt))
 164         (decode-hz-region (point-min)(point-max))
 165         )
 166     (decode-hz-region start end)
 167     ))
 168
 169 (defun decode-mime-charset-region (start end charset &optional lbt)
 170   "Decode the text between START and END as MIME CHARSET."
 171   (if (stringp charset)
 172       (setq charset (intern (downcase charset)))
 173     )
 174   (let ((func (cdr (or (assq charset mime-charset-decoder-alist)
 175                        (assq t mime-charset-decoder-alist)))))
 176     (funcall func start end charset lbt)
 177     ))
 178
 179 (defsubst encode-mime-charset-string (string charset)
 180   "Encode the STRING as MIME CHARSET."
 181   (let ((cs (mime-charset-to-coding-system charset)))
 182     (if cs
 183         (encode-coding-string string cs)
 184       string)))
 185
 186 ;; (defsubst decode-mime-charset-string (string charset)
 187 ;;   "Decode the STRING as MIME CHARSET."
 188 ;;   (let ((cs (mime-charset-to-coding-system charset)))
 189 ;;     (if cs
 190 ;;         (decode-coding-string string cs)
 191 ;;       string)))
 192 (defun decode-mime-charset-string (string charset &optional lbt)
 193   "Decode the STRING as MIME CHARSET."
 194   (with-temp-buffer
 195     (insert string)
 196     (decode-mime-charset-region (point-min)(point-max) charset lbt)
 197     (buffer-string)
 198     ))
 199
 200
 201 (defvar charsets-mime-charset-alist
 202   '(((ascii)                                            . us-ascii)
 203     ((ascii latin-iso8859-1)                            . iso-8859-1)
 204     ((ascii latin-iso8859-2)                            . iso-8859-2)
 205     ((ascii latin-iso8859-3)                            . iso-8859-3)
 206     ((ascii latin-iso8859-4)                            . iso-8859-4)
 207     ((ascii cyrillic-iso8859-5)                         . iso-8859-5)
 208 ;;; ((ascii cyrillic-iso8859-5)                         . koi8-r)
 209     ((ascii arabic-iso8859-6)                           . iso-8859-6)
 210     ((ascii greek-iso8859-7)                            . iso-8859-7)
 211     ((ascii hebrew-iso8859-8)                           . iso-8859-8)
 212     ((ascii latin-iso8859-9)                            . iso-8859-9)
 213     ((ascii latin-jisx0201
 214             japanese-jisx0208-1978 japanese-jisx0208)   . iso-2022-jp)
 215     ((ascii latin-jisx0201
 216             katakana-jisx0201 japanese-jisx0208)        . shift_jis)
 217     ((ascii korean-ksc5601)                             . euc-kr)
 218     ((ascii chinese-gb2312)                             . cn-gb-2312)
 219     ((ascii chinese-big5-1 chinese-big5-2)              . cn-big5)
 220     ((ascii latin-iso8859-1 greek-iso8859-7
 221             latin-jisx0201 japanese-jisx0208-1978
 222             chinese-gb2312 japanese-jisx0208
 223             korean-ksc5601 japanese-jisx0212)           . iso-2022-jp-2)
 224     ((ascii latin-iso8859-1 greek-iso8859-7
 225             latin-jisx0201 japanese-jisx0208-1978
 226             chinese-gb2312 japanese-jisx0208
 227             korean-ksc5601 japanese-jisx0212
 228             chinese-cns11643-1 chinese-cns11643-2)      . iso-2022-int-1)
 229     ((ascii latin-iso8859-1 latin-iso8859-2
 230             cyrillic-iso8859-5 greek-iso8859-7
 231             latin-jisx0201 japanese-jisx0208-1978
 232             chinese-gb2312 japanese-jisx0208
 233             korean-ksc5601 japanese-jisx0212
 234             chinese-cns11643-1 chinese-cns11643-2
 235             chinese-cns11643-3 chinese-cns11643-4
 236             chinese-cns11643-5 chinese-cns11643-6
 237             chinese-cns11643-7)                         . iso-2022-int-1)
 238     ))
 239
 240
 241 ;;; @ buffer representation
 242 ;;;
 243
 244 (defsubst-maybe set-buffer-multibyte (flag)
 245   "Set the multibyte flag of the current buffer to FLAG.
 246 If FLAG is t, this makes the buffer a multibyte buffer.
 247 If FLAG is nil, this makes the buffer a single-byte buffer.
 248 The buffer contents remain unchanged as a sequence of bytes
 249 but the contents viewed as characters do change.
 250 \[Emacs 20.3 emulating function]"
 251   flag)
 252
 253
 254 ;;; @ character
 255 ;;;
 256
 257 ;; avoid bug of XEmacs
 258 (or (integerp (cdr (split-char ?a)))
 259     (defun split-char (char)
 260       "Return list of charset and one or two position-codes of CHAR."
 261       (let ((charset (char-charset char)))
 262         (if (eq charset 'ascii)
 263             (list charset (char-int char))
 264           (let ((i 0)
 265                 (len (charset-dimension charset))
 266                 (code (if (integerp char)
 267                           char
 268                         (char-int char)))
 269                 dest)
 270             (while (< i len)
 271               (setq dest (cons (logand code 127) dest)
 272                     code (lsh code -7)
 273                     i (1+ i)))
 274             (cons charset dest)
 275             ))))
 276     )
 277
 278 (defmacro char-next-index (char index)
 279   "Return index of character succeeding CHAR whose index is INDEX."
 280   `(1+ ,index))
 281
 282 ;;; @@ Mule emulating aliases
 283 ;;;
 284 ;;; You should not use them.
 285
 286 ;;(defalias 'char-leading-char 'char-charset)
 287
 288 (defun char-category (character)
 289   "Return string of category mnemonics for CHAR in TABLE.
 290 CHAR can be any multilingual character
 291 TABLE defaults to the current buffer's category table."
 292   (mapconcat (lambda (chr)
 293                (char-to-string (int-char chr))
 294                )
 295              (char-category-list character)
 296              ""))
 297
 298
 299 ;;; @ string
 300 ;;;
 301
 302 (defun string-to-int-list (str)
 303   (mapcar #'char-int str)
 304   )
 305
 306 (defalias 'looking-at-as-unibyte 'looking-at)
 307
 308
 309 ;;; @ end
 310 ;;;
 311
 312 (provide 'emu-x20)
 313
 314 ;;; emu-x20.el ends here