emu-nemacs.el

   1 ;;; emu-nemacs.el --- Mule 2 emulation module for NEmacs
   2
   3 ;; Copyright (C) 1995,1996 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Version: $Id: emu-nemacs.el,v 7.48 1996/09/23 20:31:12 morioka Exp $
   7 ;; Keywords: emulation, compatibility, NEmacs, 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 (require 'emu-18)
  29
  30
  31 ;;; @ character set
  32 ;;;
  33
  34 (defconst charset-ascii 0 "Character set of ASCII")
  35 (defconst charset-jisx0208 146 "Character set of JIS X0208-1983")
  36
  37 (defun charset-description (charset)
  38   "Return description of CHARSET. [emu-nemacs.el]"
  39   (if (< charset 128)
  40       (documentation-property 'charset-ascii 'variable-documentation)
  41     (documentation-property 'charset-jisx0208 'variable-documentation)
  42     ))
  43
  44 (defun charset-registry (charset)
  45   "Return registry name of CHARSET. [emu-nemacs.el]"
  46   (if (< charset 128)
  47       "ASCII"
  48     "JISX0208.1983"))
  49
  50 (defun charset-columns (charset)
  51   "Return number of columns a CHARSET occupies when displayed.
  52 \[emu-nemacs.el]"
  53   (if (< charset 128)
  54       1
  55     2))
  56
  57 (defun charset-direction (charset)
  58   "Return the direction of a character of CHARSET by
  59   0 (left-to-right) or 1 (right-to-left). [emu-nemacs.el]"
  60   0)
  61
  62 (defun find-charset-string (str)
  63   "Return a list of charsets in the string.
  64 \[emu-nemacs.el; Mule emulating function]"
  65   (if (string-match "[\200-\377]" str)
  66       (list lc-jp)
  67     ))
  68
  69 (defun find-charset-region (start end)
  70   "Return a list of charsets in the region between START and END.
  71 \[emu-nemacs.el; Mule emulating function]"
  72   (if (save-excursion
  73         (save-restriction
  74           (narrow-to-region start end)
  75           (goto-char start)
  76           (re-search-forward "[\200-\377]" nil t)
  77           ))
  78       (list lc-jp)
  79     ))
  80
  81 (defun check-ASCII-string (str)
  82   (let ((i 0)
  83         len)
  84     (setq len (length str))
  85     (catch 'label
  86       (while (< i len)
  87         (if (>= (elt str i) 128)
  88             (throw 'label nil))
  89         (setq i (+ i 1))
  90         )
  91       str)))
  92
  93 ;;; @@ for old MULE emulation
  94 ;;;
  95
  96 (defconst lc-ascii 0)
  97 (defconst lc-jp  146)
  98
  99
 100 ;;; @ coding system
 101 ;;;
 102
 103 (defconst *noconv*    0)
 104 (defconst *sjis*      1)
 105 (defconst *junet*     2)
 106 (defconst *ctext*     2)
 107 (defconst *internal*  3)
 108 (defconst *euc-japan* 3)
 109
 110 (defun decode-coding-string (string coding-system)
 111   "Decode the STRING which is encoded in CODING-SYSTEM.
 112 \[emu-nemacs.el; EMACS 20 emulating function]"
 113   (if (eq coding-system 3)
 114       string
 115     (convert-string-kanji-code string coding-system 3)
 116     ))
 117
 118 (defun encode-coding-string (string coding-system)
 119   "Encode the STRING to CODING-SYSTEM.
 120 \[emu-nemacs.el; EMACS 20 emulating function]"
 121   (if (eq coding-system 3)
 122       string
 123     (convert-string-kanji-code string 3 coding-system)
 124     ))
 125
 126 (defun decode-coding-region (start end coding-system)
 127   "Decode the text between START and END which is encoded in CODING-SYSTEM.
 128 \[emu-nemacs.el; EMACS 20 emulating function]"
 129   (if (/= ic oc)
 130       (save-excursion
 131         (save-restriction
 132           (narrow-to-region start end)
 133           (convert-region-kanji-code start end coding-system 3)
 134           ))))
 135
 136 (defun encode-coding-region (start end coding-system)
 137   "Encode the text between START and END to CODING-SYSTEM.
 138 \[emu-nemacs.el; EMACS 20 emulating function]"
 139   (if (/= ic oc)
 140       (save-excursion
 141         (save-restriction
 142           (narrow-to-region start end)
 143           (convert-region-kanji-code start end 3 coding-system)
 144           ))))
 145
 146 (defun detect-coding-region (start end)
 147   "Detect coding-system of the text in the region between START and END.
 148 \[emu-nemacs.el; Emacs 20 emulating function]"
 149   (if (save-excursion
 150         (save-restriction
 151           (narrow-to-region start end)
 152           (goto-char start)
 153           (re-search-forward "[\200-\377]" nil t)
 154           ))
 155       *euc-japan*
 156     ))
 157
 158 (defalias 'set-buffer-file-coding-system 'set-kanji-fileio-code)
 159
 160 (defmacro as-binary-process (&rest body)
 161   (` (let (selective-display    ; Disable ^M to nl translation.
 162            ;; NEmacs
 163            kanji-flag
 164            (default-kanji-process-code 0)
 165            program-kanji-code-alist)
 166        (,@ body)
 167        )))
 168
 169 (defmacro as-binary-input-file (&rest body)
 170   (` (let (kanji-flag)
 171        (,@ body)
 172        )))
 173
 174
 175 ;;; @@ for old MULE emulation
 176 ;;;
 177
 178 (defun code-convert-string (str ic oc)
 179   "Convert code in STRING from SOURCE code to TARGET code,
 180 On successful converion, returns the result string,
 181 else returns nil. [emu-nemacs.el; Mule emulating function]"
 182   (if (not (eq ic oc))
 183       (convert-string-kanji-code str ic oc)
 184     str))
 185
 186 (defun code-convert-region (beg end ic oc)
 187   "Convert code of the text between BEGIN and END from SOURCE
 188 to TARGET. On successful conversion returns t,
 189 else returns nil. [emu-nemacs.el; Mule emulating function]"
 190   (if (/= ic oc)
 191       (save-excursion
 192         (save-restriction
 193           (narrow-to-region beg end)
 194           (convert-region-kanji-code beg end ic oc)
 195           ))))
 196
 197
 198 ;;; @ MIME charset
 199 ;;;
 200
 201 (defvar charsets-mime-charset-alist
 202   (list (cons (list charset-ascii) 'us-ascii)))
 203
 204 (defvar default-mime-charset 'iso-2022-jp)
 205
 206 (defvar mime-charset-coding-system-alist
 207   '((iso-2022-jp     . 2)
 208     (shift_jis       . 1)
 209     ))
 210
 211 (defun mime-charset-to-coding-system (charset)
 212   (if (stringp charset)
 213       (setq charset (intern (downcase charset)))
 214     )
 215   (cdr (assq charset mime-charset-coding-system-alist))
 216   )
 217
 218 (defun detect-mime-charset-region (start end)
 219   "Return MIME charset for region between START and END.
 220 \[emu-nemacs.el]"
 221   (if (save-excursion
 222         (save-restriction
 223           (narrow-to-region start end)
 224           (goto-char start)
 225           (re-search-forward "[\200-\377]" nil t)
 226           ))
 227       default-mime-charset
 228     'us-ascii))
 229
 230 (defun encode-mime-charset-region (start end charset)
 231   "Encode the text between START and END as MIME CHARSET.
 232 \[emu-nemacs.el]"
 233   (let ((cs (mime-charset-to-coding-system charset)))
 234     (and (numberp cs)
 235          (or (= cs 3)
 236              (save-excursion
 237                (save-restriction
 238                  (narrow-to-region start end)
 239                  (convert-region-kanji-code start end 3 cs)
 240                  ))
 241              ))))
 242
 243 (defun decode-mime-charset-region (start end charset)
 244   "Decode the text between START and END as MIME CHARSET.
 245 \[emu-nemacs.el]"
 246   (let ((cs (mime-charset-to-coding-system charset)))
 247     (and (numberp cs)
 248          (or (= cs 3)
 249              (save-excursion
 250                (save-restriction
 251                  (narrow-to-region start end)
 252                  (convert-region-kanji-code start end cs 3)
 253                  ))
 254              ))))
 255
 256 (defun encode-mime-charset-string (string charset)
 257   "Encode the STRING as MIME CHARSET. [emu-nemacs.el]"
 258   (let ((cs (mime-charset-to-coding-system charset)))
 259     (if cs
 260         (convert-string-kanji-code string 3 cs)
 261       string)))
 262
 263 (defun decode-mime-charset-string (string charset)
 264   "Decode the STRING as MIME CHARSET. [emu-nemacs.el]"
 265   (let ((cs (mime-charset-to-coding-system charset)))
 266     (if cs
 267         (convert-string-kanji-code string cs 3)
 268       string)))
 269
 270
 271 ;;; @ character
 272 ;;;
 273
 274 (defun char-charset (chr)
 275   "Return the character set of char CHR.
 276 \[emu-nemacs.el; XEmacs 20 emulating function]"
 277   (if (< chr 128)
 278       charset-ascii
 279     charset-jisx0208))
 280
 281 (defun char-bytes (chr)
 282   "Return number of bytes CHAR will occupy in a buffer.
 283 \[emu-nemacs.el; Mule emulating function]"
 284   (if (< chr 128) 1 2))
 285
 286 (defalias 'char-length 'char-bytes)
 287
 288 (defun char-columns (character)
 289   "Return number of columns a CHARACTER occupies when displayed.
 290 \[emu-nemacs.el]"
 291   (if (< character 128)
 292       1
 293     2))
 294
 295 ;;; @@ for Mule emulation
 296 ;;;
 297
 298 (defalias 'char-leading-char 'char-charset)
 299
 300 (defalias 'char-width 'char-columns)
 301
 302
 303 ;;; @ string
 304 ;;;
 305
 306 (defalias 'string-columns 'length)
 307
 308 (defun sref (str idx)
 309   "Return the character in STR at index IDX.
 310 \[emu-nemacs.el; Mule emulating function]"
 311   (let ((chr (aref str idx)))
 312     (if (< chr 128)
 313         chr
 314       (logior (lsh (aref str (1+ idx)) 8) chr)
 315       )))
 316
 317 (defun string-to-char-list (str)
 318   (let ((i 0)(len (length str)) dest chr)
 319     (while (< i len)
 320       (setq chr (aref str i))
 321       (if (>= chr 128)
 322           (setq i (1+ i)
 323                 chr (+ (lsh chr 8) (aref str i))
 324                 ))
 325       (setq dest (cons chr dest))
 326       (setq i (1+ i))
 327       )
 328     (reverse dest)
 329     ))
 330
 331 (fset 'string-to-int-list (symbol-function 'string-to-char-list))
 332
 333 ;;; Imported from Mule-2.3
 334 (defun truncate-string (str width &optional start-column)
 335   "Truncate STR to fit in WIDTH columns.
 336 Optional non-nil arg START-COLUMN specifies the starting column.
 337 \[emu-mule.el; Mule 2.3 emulating function]"
 338   (or start-column
 339       (setq start-column 0))
 340   (let ((max-width (string-width str))
 341         (len (length str))
 342         (from 0)
 343         (column 0)
 344         to-prev to ch)
 345     (if (>= width max-width)
 346         (setq width max-width))
 347     (if (>= start-column width)
 348         ""
 349       (while (< column start-column)
 350         (setq ch (aref str from)
 351               column (+ column (char-columns ch))
 352               from (+ from (char-bytes ch))))
 353       (if (< width max-width)
 354           (progn
 355             (setq to from)
 356             (while (<= column width)
 357               (setq ch (aref str to)
 358                     column (+ column (char-columns ch))
 359                     to-prev to
 360                     to (+ to (char-bytes ch))))
 361             (setq to to-prev)))
 362       (substring str from to))))
 363
 364 ;;; @@ for Mule emulation
 365 ;;;
 366
 367 (defalias 'string-width 'length)
 368
 369
 370 ;;; @ text property emulation
 371 ;;;
 372
 373 (setq tl:available-face-attribute-alist
 374       '(
 375         ;;(bold      . inversed-region)
 376         (italic    . underlined-region)
 377         (underline . underlined-region)
 378         ))
 379
 380 ;; by YAMATE Keiichirou 1994/10/28
 381 (defun attribute-add-narrow-attribute (attr from to)
 382   (or (consp (symbol-value attr))
 383       (set attr (list 1)))
 384   (let* ((attr-value (symbol-value attr))
 385          (len (car attr-value))
 386          (posfrom 1)
 387          posto)
 388     (while (and (< posfrom len)
 389                 (> from (nth posfrom attr-value)))
 390       (setq posfrom (1+ posfrom)))
 391     (setq posto posfrom)
 392     (while (and (< posto len)
 393                 (> to (nth posto attr-value)))
 394       (setq posto (1+ posto)))
 395     (if  (= posto posfrom)
 396         (if (= (% posto 2) 1)
 397             (if (and (< to len)
 398                      (= to (nth posto attr-value)))
 399                 (set-marker (nth posto attr-value) from)
 400               (setcdr (nthcdr (1- posfrom) attr-value)
 401                       (cons (set-marker-type (set-marker (make-marker)
 402                                                          from)
 403                                              'point-type)
 404                             (cons (set-marker-type (set-marker (make-marker)
 405                                                                to)
 406                                                    nil)
 407                                   (nthcdr posto attr-value))))
 408               (setcar attr-value (+ len 2))))
 409       (if (= (% posfrom 2) 0)
 410           (setq posfrom (1- posfrom))
 411         (set-marker (nth posfrom attr-value) from))
 412       (if (= (% posto 2) 0)
 413           nil
 414         (setq posto (1- posto))
 415         (set-marker (nth posto attr-value) to))
 416       (setcdr (nthcdr posfrom attr-value)
 417               (nthcdr posto attr-value)))))
 418
 419 (defalias 'tl:make-overlay 'cons)
 420
 421 (defun tl:overlay-put (overlay prop value)
 422   (let ((ret (and (eq prop 'face)
 423                   (assq value tl:available-face-attribute-alist)
 424                   )))
 425     (if ret
 426         (attribute-add-narrow-attribute (cdr ret)
 427                                         (car overlay)(cdr overlay))
 428       )))
 429
 430
 431 ;;; @ end
 432 ;;;
 433
 434 (provide 'emu-nemacs)
 435
 436 ;;; emu-nemacs.el ends here