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