emu-nemacs.el

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