emu-e20.el

   1 ;;; emu-e20.el --- emu API implementation for Emacs 20.1 and 20.2
   2
   3 ;; Copyright (C) 1996,1997,1998 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Keywords: emulation, compatibility, Mule
   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 Emacs 20.1 and 20.2.
  28
  29 ;;; Code:
  30
  31 (require 'emu-e19)
  32
  33 (defun fontset-pixel-size (fontset)
  34   (let* ((info (fontset-info fontset))
  35          (height (aref info 1))
  36          )
  37     (cond ((> height 0) height)
  38           ((string-match "-\\([0-9]+\\)-" fontset)
  39            (string-to-number
  40             (substring fontset (match-beginning 1)(match-end 1))
  41             )
  42            )
  43           (t 0)
  44           )))
  45
  46
  47 ;;; @ character set
  48 ;;;
  49
  50 ;; (defalias 'charset-columns 'charset-width)
  51
  52 (defun find-non-ascii-charset-string (string)
  53   "Return a list of charsets in the STRING except ascii."
  54   (delq 'ascii (find-charset-string string))
  55   )
  56
  57 (defun find-non-ascii-charset-region (start end)
  58   "Return a list of charsets except ascii
  59 in the region between START and END."
  60   (delq 'ascii (find-charset-string (buffer-substring start end)))
  61   )
  62
  63
  64 ;;; @ coding system
  65 ;;;
  66
  67 (defsubst-maybe find-coding-system (obj)
  68   "Return OBJ if it is a coding-system."
  69   (if (coding-system-p obj)
  70       obj))
  71
  72 (defalias 'set-process-input-coding-system 'set-process-coding-system)
  73
  74
  75 ;;; @ MIME charset
  76 ;;;
  77
  78 (defsubst encode-mime-charset-region (start end charset)
  79   "Encode the text between START and END as MIME CHARSET."
  80   (let (cs)
  81     (if (and enable-multibyte-characters
  82              (setq cs (mime-charset-to-coding-system charset)))
  83         (encode-coding-region start end cs)
  84       )))
  85
  86 (defsubst decode-mime-charset-region (start end charset &optional lbt)
  87   "Decode the text between START and END as MIME CHARSET."
  88   (let (cs)
  89     (if (and enable-multibyte-characters
  90              (setq cs (mime-charset-to-coding-system charset lbt)))
  91         (decode-coding-region start end cs)
  92       )))
  93
  94 (defsubst encode-mime-charset-string (string charset)
  95   "Encode the STRING as MIME CHARSET."
  96   (let (cs)
  97     (if (and enable-multibyte-characters
  98              (setq cs (mime-charset-to-coding-system charset)))
  99         (encode-coding-string string cs)
 100       string)))
 101
 102 (defsubst decode-mime-charset-string (string charset &optional lbt)
 103   "Decode the STRING as MIME CHARSET."
 104   (let (cs)
 105     (if (and enable-multibyte-characters
 106              (setq cs (mime-charset-to-coding-system charset lbt)))
 107         (decode-coding-string string cs)
 108       string)))
 109
 110
 111 (defvar charsets-mime-charset-alist
 112   '(((ascii)                                            . us-ascii)
 113     ((ascii latin-iso8859-1)                            . iso-8859-1)
 114     ((ascii latin-iso8859-2)                            . iso-8859-2)
 115     ((ascii latin-iso8859-3)                            . iso-8859-3)
 116     ((ascii latin-iso8859-4)                            . iso-8859-4)
 117 ;;; ((ascii cyrillic-iso8859-5)                         . iso-8859-5)
 118     ((ascii cyrillic-iso8859-5)                         . koi8-r)
 119     ((ascii arabic-iso8859-6)                           . iso-8859-6)
 120     ((ascii greek-iso8859-7)                            . iso-8859-7)
 121     ((ascii hebrew-iso8859-8)                           . iso-8859-8)
 122     ((ascii latin-iso8859-9)                            . iso-8859-9)
 123     ((ascii latin-jisx0201
 124             japanese-jisx0208-1978 japanese-jisx0208)   . iso-2022-jp)
 125     ((ascii latin-jisx0201
 126             katakana-jisx0201 japanese-jisx0208)        . shift_jis)
 127     ((ascii korean-ksc5601)                             . euc-kr)
 128     ((ascii chinese-gb2312)                             . cn-gb-2312)
 129     ((ascii chinese-big5-1 chinese-big5-2)              . cn-big5)
 130     ((ascii latin-iso8859-1 greek-iso8859-7
 131             latin-jisx0201 japanese-jisx0208-1978
 132             chinese-gb2312 japanese-jisx0208
 133             korean-ksc5601 japanese-jisx0212)           . iso-2022-jp-2)
 134     ((ascii latin-iso8859-1 greek-iso8859-7
 135             latin-jisx0201 japanese-jisx0208-1978
 136             chinese-gb2312 japanese-jisx0208
 137             korean-ksc5601 japanese-jisx0212
 138             chinese-cns11643-1 chinese-cns11643-2)      . iso-2022-int-1)
 139     ((ascii latin-iso8859-1 latin-iso8859-2
 140             cyrillic-iso8859-5 greek-iso8859-7
 141             latin-jisx0201 japanese-jisx0208-1978
 142             chinese-gb2312 japanese-jisx0208
 143             korean-ksc5601 japanese-jisx0212
 144             chinese-cns11643-1 chinese-cns11643-2
 145             chinese-cns11643-3 chinese-cns11643-4
 146             chinese-cns11643-5 chinese-cns11643-6
 147             chinese-cns11643-7)                         . iso-2022-int-1)
 148     ))
 149
 150
 151 ;;; @ character
 152 ;;;
 153
 154 ;;; @@ Mule emulating aliases
 155 ;;;
 156 ;;; You should not use them.
 157
 158 (defun char-category (character)
 159   "Return string of category mnemonics for CHAR in TABLE.
 160 CHAR can be any multilingual character
 161 TABLE defaults to the current buffer's category table."
 162   (category-set-mnemonics (char-category-set character))
 163   )
 164
 165
 166 ;;; @ CCL
 167 ;;;
 168 (require 'ccl)
 169
 170 (eval-when-compile
 171 (defconst ccl-use-symbol-as-program
 172   (progn
 173     (define-ccl-program ew-ccl-identity-program
 174       '(1 ((read r0) (loop (write-read-repeat r0)))))
 175     (condition-case nil
 176         (progn
 177           (funcall
 178            (if (fboundp 'ccl-vector-program-execute-on-string)
 179                'ccl-vector-program-execute-on-string
 180              'ccl-execute-on-string)
 181            'ew-ccl-identity-program
 182            (make-vector 9 nil)
 183            "")
 184           t)
 185       (error nil)))
 186   "t if CCL related builtins accept symbol as CCL
 187 program. (20.2 with ExCCL, 20.3 or later)
 188 Otherwise nil (20.2 without ExCCL or former).
 189
 190 Because emu provides functions accepting symbol as CCL program,
 191 user programs should not refer this variable.")
 192 )
 193
 194 (eval-and-compile
 195 (defconst ccl-use-symbol-as-program
 196   (eval-when-compile ccl-use-symbol-as-program))
 197
 198 (defun make-ccl-coding-system
 199   (coding-system mnemonic doc-string decoder encoder)
 200   "Define a new CODING-SYSTEM (symbol) by CCL programs
 201 DECODER (symbol) and ENCODER (symbol)."
 202   (unless ccl-use-symbol-as-program
 203     (setq decoder (symbol-value decoder))
 204     (setq encoder (symbol-value encoder)))
 205   (make-coding-system coding-system 4 mnemonic doc-string
 206                       (cons decoder encoder)))
 207 )
 208
 209 (eval-when-compile
 210 (define-ccl-program test-ccl-eof-block
 211   '(1
 212     (read r0)
 213     (write "[EOF]")))
 214
 215 (make-ccl-coding-system
 216  'test-ccl-eof-block-cs ?T "CCL_EOF_BLOCK tester"
 217  'test-ccl-eof-block 'test-ccl-eof-block)
 218 )
 219
 220 (defconst ccl-encoder-eof-block-is-broken
 221   (eval-when-compile
 222     (not (equal (encode-coding-string "" 'test-ccl-eof-block-cs)
 223                 "[EOF]")))
 224   "t if CCL_EOF_BLOCK is not executed when coding system encounts EOF on
 225 encoding.")
 226
 227 (defconst ccl-decoder-eof-block-is-broken
 228   (eval-when-compile
 229     (not (equal (decode-coding-string "" 'test-ccl-eof-block-cs)
 230                 "[EOF]")))
 231   "t if CCL_EOF_BLOCK is not executed when coding system encounts EOF on
 232 decoding.")
 233
 234 (defconst ccl-eof-block-is-broken
 235   (or ccl-encoder-eof-block-is-broken
 236       ccl-decoder-eof-block-is-broken))
 237
 238 (unless ccl-use-symbol-as-program
 239
 240 (when (subrp (symbol-function 'ccl-execute))
 241   (fset 'ccl-vector-program-execute
 242         (symbol-function 'ccl-execute))
 243   (defun ccl-execute (ccl-prog reg)
 244     "Execute CCL-PROG `ccl-vector-program-execute'.
 245 If CCL-PROG is symbol, it is dereferenced.
 246 \[Emacs 20.3 emulating function]"
 247     (ccl-vector-program-execute
 248      (if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog)
 249      reg)))
 250
 251 (when (subrp (symbol-function 'ccl-execute-on-string))
 252   (fset 'ccl-vector-program-execute-on-string
 253         (symbol-function 'ccl-execute-on-string))
 254   (defun ccl-execute-on-string (ccl-prog status &optional contin)
 255     "Execute CCL-PROG `ccl-vector-program-execute-on-string'.
 256 If CCL-PROG is symbol, it is dereferenced.
 257 \[Emacs 20.3 emulating function]"
 258     (ccl-vector-program-execute-on-string
 259      (if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog)
 260      status
 261      contin)))
 262
 263 )
 264
 265
 266 ;;; @ end
 267 ;;;
 268
 269 (require 'emu-20)
 270
 271 (defalias 'insert-binary-file-contents 'insert-file-contents-as-binary)
 272 (make-obsolete 'insert-binary-file-contents 'insert-file-contents-as-binary)
 273
 274 (defalias 'insert-binary-file-contents-literally
 275   'insert-file-contents-literally)
 276
 277 (if (and (fboundp 'set-buffer-multibyte)
 278          (subrp (symbol-function 'set-buffer-multibyte)))
 279     (require 'emu-e20_3) ; for Emacs 20.3
 280   (require 'emu-e20_2) ; for Emacs 20.1 and 20.2
 281   )
 282
 283
 284 (provide 'emu-e20)
 285
 286 ;;; emu-e20.el ends here