emu-e20.el

   1 ;;; emu-e20.el --- emu API implementation for mule merged Emacs
   2
   3 ;; Copyright (C) 1996 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Version: $Id: emu-e20.el,v 4.1 1996/10/01 13:18:34 morioka Exp $
   7 ;; Keywords: emulation, compatibility, Mule
   8
   9 ;; This file is part of tl (Tiny Library).
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program 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 GNU Emacs; 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 ;;; Code:
  27
  28 ;;; @ version specific features
  29 ;;;
  30
  31 (require 'emu-19)
  32
  33 (defun fontset-height (fontset)
  34   (let* ((info (fontset-info fontset))
  35          (height (aref info 1))
  36          )
  37     (if (> height 0)
  38         height
  39       (let ((str
  40              (car (aref (aref info 2) 0))
  41              ))
  42         (if (string-match "--\\([0-9]+\\)-\\*-\\*-\\*-\\*-\\*-ISO8859-1" str)
  43             (string-to-number
  44              (substring str (match-beginning 1)(match-end 1))
  45              )
  46           0)))))
  47
  48
  49 ;;; @ character set
  50 ;;;
  51
  52 (defalias 'charset-columns 'charset-width)
  53
  54 (defun find-non-ascii-charset-string (string)
  55   "Return a list of charsets in the STRING except ascii.
  56 \[emu-e20.el; Mule emulating function]"
  57   (delq charset-ascii (find-charset-string string))
  58   )
  59
  60 (defun find-non-ascii-charset-region (start end)
  61   "Return a list of charsets except ascii
  62 in the region between START and END.
  63 \[emu-e20.el; Mule emulating function]"
  64   (delq charset-ascii (find-charset-string (buffer-substring start end)))
  65   )
  66
  67
  68 ;;; @ coding system
  69 ;;;
  70
  71 (defconst *noconv* 'no-conversion)
  72
  73 (defmacro as-binary-process (&rest body)
  74   `(let (selective-display      ; Disable ^M to nl translation.
  75          ;; for mule merged Emacs
  76          (default-process-coding-system 'no-conversion)
  77          )
  78      ,@ body))
  79
  80 (defmacro as-binary-input-file (&rest body)
  81   `(let ((coding-system-for-read 'no-conversion))
  82      ,@body))
  83
  84 (defalias 'set-process-input-coding-system 'set-process-coding-system)
  85
  86
  87 ;;; @ MIME charset
  88 ;;;
  89
  90 (defvar charsets-mime-charset-alist
  91   (list
  92    (cons (list charset-ascii)                           'us-ascii)
  93    (cons (list charset-ascii charset-latin-1)           'iso-8859-1)
  94    (cons (list charset-ascii charset-latin-2)           'iso-8859-2)
  95    (cons (list charset-ascii charset-latin-3)           'iso-8859-3)
  96    (cons (list charset-ascii charset-latin-4)           'iso-8859-4)
  97 ;;;(cons (list charset-ascii charset-cyrillic)          'iso-8859-5)
  98    (cons (list charset-ascii charset-cyrillic)          'koi8-r)
  99    (cons (list charset-ascii charset-arabic)            'iso-8859-6)
 100    (cons (list charset-ascii charset-greek)             'iso-8859-7)
 101    (cons (list charset-ascii charset-hebrew)            'iso-8859-8)
 102    (cons (list charset-ascii charset-latin-5)           'iso-8859-9)
 103    (cons (list charset-ascii
 104                charset-japanese-jisx0201-roman
 105                charset-japanese-jisx0208-1978
 106                charset-japanese-jisx0208)               'iso-2022-jp)
 107    (cons (list charset-ascii charset-korean-ksc5601)    'euc-kr)
 108    (cons (list charset-ascii charset-chinese-gb2312)    'gb2312)
 109    (cons (list charset-ascii
 110                charset-chinese-big5-1
 111                charset-chinese-big5-2)                  'big5)
 112    (cons (list charset-ascii
 113                charset-latin-1 charset-greek
 114                charset-japanese-jisx0201-roman
 115                charset-japanese-jisx0208-1978
 116                charset-chinese-gb2312
 117                charset-japanese-jisx0208
 118                charset-korean-ksc5601
 119                charset-japanese-jisx0212)               'iso-2022-jp-2)
 120    (cons (list charset-ascii
 121                charset-latin-1 charset-greek
 122                charset-japanese-jisx0201-roman
 123                charset-japanese-jisx0208-1978
 124                charset-chinese-gb2312
 125                charset-japanese-jisx0208
 126                charset-korean-ksc5601
 127                charset-japanese-jisx0212
 128                charset-chinese-cns11643-1
 129                charset-chinese-cns11643-2)              'iso-2022-int-1)
 130    (cons (list charset-ascii
 131                charset-latin-1 charset-latin-2
 132                charset-cyrillic charset-greek
 133                charset-japanese-jisx0201-roman
 134                charset-japanese-jisx0208-1978
 135                charset-chinese-gb2312
 136                charset-japanese-jisx0208
 137                charset-korean-ksc5601
 138                charset-japanese-jisx0212
 139                charset-chinese-cns11643-1
 140                charset-chinese-cns11643-2
 141                charset-chinese-cns11643-3
 142                charset-chinese-cns11643-4
 143                charset-chinese-cns11643-5
 144                charset-chinese-cns11643-6
 145                charset-chinese-cns11643-7)              'iso-2022-int-1)
 146    ))
 147
 148 (defvar default-mime-charset 'x-ctext)
 149
 150 (defvar mime-charset-coding-system-alist
 151   '((x-ctext            . coding-system-ctext)
 152     (hz-gb-2312         . coding-system-hz)
 153     (cn-gb-2312         . coding-system-euc-china)
 154     (gb2312             . coding-system-euc-china)
 155     (cn-big5            . coding-system-big5)
 156     (iso-2022-jp-2      . coding-system-iso-2022-ss2-7)
 157     (iso-2022-int-1     . coding-system-iso-2022-int)
 158     (shift_jis          . coding-system-sjis)
 159     ))
 160
 161 (defun mime-charset-to-coding-system (charset)
 162   (if (stringp charset)
 163       (setq charset (intern (downcase charset)))
 164     )
 165   (or (cdr (assq charset mime-charset-coding-system-alist))
 166       (let ((cs (intern (concat "coding-system-" (symbol-name charset)))))
 167         (and (coding-system-p cs) cs)
 168         )))
 169
 170 (defun detect-mime-charset-region (start end)
 171   "Return MIME charset for region between START and END. [emu-e20.el]"
 172   (charsets-to-mime-charset
 173    (find-charset-string (buffer-substring start end))
 174    ))
 175
 176 (defun encode-mime-charset-region (start end charset)
 177   "Encode the text between START and END as MIME CHARSET. [emu-e20.el]"
 178   (let ((cs (mime-charset-to-coding-system charset)))
 179     (if cs
 180         (encode-coding-region start end cs)
 181       )))
 182
 183 (defun decode-mime-charset-region (start end charset)
 184   "Decode the text between START and END as MIME CHARSET. [emu-e20.el]"
 185   (let ((cs (mime-charset-to-coding-system charset)))
 186     (if cs
 187         (decode-coding-region start end cs)
 188       )))
 189
 190 (defun encode-mime-charset-string (string charset)
 191   "Encode the STRING as MIME CHARSET. [emu-e20.el]"
 192   (let ((cs (mime-charset-to-coding-system charset)))
 193     (if cs
 194         (encode-coding-string string cs)
 195       string)))
 196
 197 (defun decode-mime-charset-string (string charset)
 198   "Decode the STRING as MIME CHARSET. [emu-e20.el]"
 199   (let ((cs (mime-charset-to-coding-system charset)))
 200     (if cs
 201         (decode-coding-string string cs)
 202       string)))
 203
 204
 205 ;;; @ character
 206 ;;;
 207
 208 (defalias 'char-length 'char-bytes)
 209
 210 (defalias 'char-columns 'char-width)
 211
 212
 213 ;;; @@ Mule emulating aliases
 214 ;;;
 215 ;;; You should not use them.
 216
 217 (defalias 'make-character 'make-char)
 218
 219 (defun char-category (character)
 220   "Return string of category mnemonics for CHAR in TABLE.
 221 CHAR can be any multilingual character
 222 TABLE defaults to the current buffer's category table.
 223 \[emu-e20.el; Mule emulating function]"
 224   (category-set-mnemonics (char-category-set character))
 225   )
 226
 227
 228 ;;; @ string
 229 ;;;
 230
 231 (defalias 'string-columns 'string-width)
 232
 233 (defalias 'sset 'string-embed-string)
 234
 235 (defun string-to-char-list (string)
 236   "Return a list of which elements are characters in the STRING.
 237 \[emu-e20.el; Mule 2.3 emulating function]"
 238   (let* ((len (length string))
 239          (i 0)
 240          l chr)
 241     (while (< i len)
 242       (setq chr (sref string i))
 243       (setq l (cons chr l))
 244       (setq i (+ i (char-bytes chr)))
 245       )
 246     (nreverse l)
 247     ))
 248
 249 (defalias 'string-to-int-list 'string-to-char-list)
 250
 251 (or (fboundp 'truncate-string)
 252 (defun truncate-string (string width &optional start-column)
 253   "Truncate STRING to fit in WIDTH columns.
 254 Optional non-nil arg START-COLUMN specifies the starting column.
 255 \[emu-e20.el; MULE 2.3 emulating function]"
 256   (or start-column
 257       (setq start-column 0))
 258   (let ((max-width (string-width string))
 259         (len (length string))
 260         (from 0)
 261         (column 0)
 262         to-prev to ch b)
 263     (if (>= width max-width)
 264         (setq width max-width))
 265     (if (>= start-column width)
 266         ""
 267       (while (< column start-column)
 268         (setq ch (aref string from)
 269               column (+ column (char-width ch))
 270               from (if (= (setq b (charset-bytes ch)) 0)
 271                        (1+ from)
 272                      (+ from b)
 273                      ))
 274         )
 275       (if (< width max-width)
 276           (progn
 277             (setq to from)
 278             (while (and (<= column width)
 279                         (< to len))
 280               (setq ch (aref string to)
 281                     column (+ column (char-width ch))
 282                     to-prev to
 283                     to (if (= (setq b (charset-bytes ch)) 0)
 284                            (1+ to)
 285                          (+ to b)
 286                          ))
 287               )
 288             (setq to to-prev)))
 289       (substring string from to))))
 290 ;;;
 291   )
 292
 293
 294 ;;; @ regulation
 295 ;;;
 296
 297 (defun regulate-latin-char (chr)
 298   (cond ((and (<= ?\e$B#A\e(B chr)(<= chr ?\e$B#Z\e(B))
 299          (+ (- chr ?\e$B#A\e(B) ?A)
 300          )
 301         ((and (<= ?\e$B#a\e(B chr)(<= chr ?\e$B#z\e(B))
 302          (+ (- chr ?\e$B#a\e(B) ?a)
 303          )
 304         ((eq chr ?\e$B!%\e(B) ?.)
 305         ((eq chr ?\e$B!$\e(B) ?,)
 306         (t chr)
 307         ))
 308
 309 (defun regulate-latin-string (str)
 310   (let ((len (length str))
 311         (i 0)
 312         chr (dest ""))
 313     (while (< i len)
 314       (setq chr (sref str i))
 315       (setq dest (concat dest
 316                          (char-to-string (regulate-latin-char chr))))
 317       (setq i (+ i (char-bytes chr)))
 318       )
 319     dest))
 320
 321
 322 ;;; @ end
 323 ;;;
 324
 325 (provide 'emu-e20)
 326
 327 ;;; emu-e20.el ends here