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