emu-nemacs.el

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