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
 168 ;;; @@ for old MULE emulation
 169 ;;;
 170
 171 (defun code-convert-string (str ic oc)
 172   "Convert code in STRING from SOURCE code to TARGET code,
 173 On successful converion, returns the result string,
 174 else returns nil. [emu-nemacs.el; Mule emulating function]"
 175   (if (not (eq ic oc))
 176       (convert-string-kanji-code str ic oc)
 177     str))
 178
 179 (defun code-convert-region (beg end ic oc)
 180   "Convert code of the text between BEGIN and END from SOURCE
 181 to TARGET. On successful conversion returns t,
 182 else returns nil. [emu-nemacs.el; Mule emulating function]"
 183   (if (/= ic oc)
 184       (save-excursion
 185         (save-restriction
 186           (narrow-to-region beg end)
 187           (convert-region-kanji-code beg end ic oc)
 188           ))))
 189
 190
 191 ;;; @ without code-conversion
 192 ;;;
 193
 194 (defmacro as-binary-process (&rest body)
 195   (` (let (selective-display    ; Disable ^M to nl translation.
 196            ;; NEmacs
 197            kanji-flag
 198            (default-kanji-process-code 0)
 199            program-kanji-code-alist)
 200        (,@ body)
 201        )))
 202
 203 (defmacro as-binary-input-file (&rest body)
 204   (` (let (kanji-flag)
 205        (,@ body)
 206        )))
 207
 208 (defmacro as-binary-output-file (&rest body)
 209   (` (let (kanji-flag)
 210        (,@ body)
 211        )))
 212
 213 (defun write-region-as-binary (start end filename
 214                                      &optional append visit lockname)
 215   "Like `write-region', q.v., but don't code conversion. [emu-nemacs.el]"
 216   (let (kanji-flag)
 217     (write-region start end filename append visit)
 218     ))
 219
 220 (defun insert-file-contents-as-binary (filename
 221                                        &optional visit beg end replace)
 222   "Like `insert-file-contents', q.v., but don't character code conversion.
 223 \[emu-nemacs.el]"
 224   (let (kanji-flag)
 225     (insert-file-contents filename visit beg end replace)
 226     ))
 227
 228 (fset 'insert-binary-file-contents 'insert-file-contents-as-binary)
 229
 230 (defun insert-binary-file-contents-literally (filename
 231                                               &optional visit beg end replace)
 232   "Like `insert-file-contents-literally', q.v., but don't code conversion.
 233 A buffer may be modified in several ways after reading into the buffer due
 234 to advanced Emacs features, such as file-name-handlers, format decoding,
 235 find-file-hooks, etc.
 236   This function ensures that none of these modifications will take place.
 237 \[emu-nemacs.el]"
 238   (let (kanji-flag)
 239     (insert-file-contents-literally filename visit beg end replace)
 240     ))
 241
 242 (defun insert-file-contents-as-raw-text (filename
 243                                          &optional visit beg end replace)
 244   "Like `insert-file-contents', q.v., but don't character code conversion.
 245 \[emu-nemacs.el]"
 246   (let (kanji-flag)
 247     (insert-file-contents filename visit beg end replace)
 248     ))
 249
 250 (defun write-region-as-raw-text-CRLF (start end filename
 251                                             &optional append visit lockname)
 252   "Like `write-region', q.v., but don't code conversion. [emu-nemacs.el]"
 253   (let ((the-buf (current-buffer)))
 254     (with-temp-buffer
 255       (insert-buffer-substring the-buf start end)
 256       (goto-char (point-min))
 257       (while (re-search-forward "\\([^\r]\\)\n" nil t)
 258         (replace-match "\\1\r\n")
 259         )
 260       (let (kanji-flag)
 261         (write-region (point-min)(point-max) filename append visit)
 262         ))))
 263
 264
 265 ;;; @ MIME charset
 266 ;;;
 267
 268 (defvar charsets-mime-charset-alist
 269   '(((ascii) . us-ascii)))
 270
 271 (defvar default-mime-charset 'iso-2022-jp)
 272
 273 (defvar mime-charset-coding-system-alist
 274   '((iso-2022-jp     . 2)
 275     (shift_jis       . 1)
 276     ))
 277
 278 (defun mime-charset-to-coding-system (charset)
 279   (if (stringp charset)
 280       (setq charset (intern (downcase charset)))
 281     )
 282   (cdr (assq charset mime-charset-coding-system-alist))
 283   )
 284
 285 (defun detect-mime-charset-region (start end)
 286   "Return MIME charset for region between START and END.
 287 \[emu-nemacs.el]"
 288   (if (save-excursion
 289         (save-restriction
 290           (narrow-to-region start end)
 291           (goto-char start)
 292           (re-search-forward "[\200-\377]" nil t)
 293           ))
 294       default-mime-charset
 295     'us-ascii))
 296
 297 (defun encode-mime-charset-region (start end charset)
 298   "Encode the text between START and END as MIME CHARSET.
 299 \[emu-nemacs.el]"
 300   (let ((cs (mime-charset-to-coding-system charset)))
 301     (and (numberp cs)
 302          (or (= cs 3)
 303              (save-excursion
 304                (save-restriction
 305                  (narrow-to-region start end)
 306                  (convert-region-kanji-code start end 3 cs)
 307                  ))
 308              ))))
 309
 310 (defun decode-mime-charset-region (start end charset)
 311   "Decode the text between START and END as MIME CHARSET.
 312 \[emu-nemacs.el]"
 313   (let ((cs (mime-charset-to-coding-system charset)))
 314     (and (numberp cs)
 315          (or (= cs 3)
 316              (save-excursion
 317                (save-restriction
 318                  (narrow-to-region start end)
 319                  (convert-region-kanji-code start end cs 3)
 320                  ))
 321              ))))
 322
 323 (defun encode-mime-charset-string (string charset)
 324   "Encode the STRING as MIME CHARSET. [emu-nemacs.el]"
 325   (let ((cs (mime-charset-to-coding-system charset)))
 326     (if cs
 327         (convert-string-kanji-code string 3 cs)
 328       string)))
 329
 330 (defun decode-mime-charset-string (string charset)
 331   "Decode the STRING as MIME CHARSET. [emu-nemacs.el]"
 332   (let ((cs (mime-charset-to-coding-system charset)))
 333     (if cs
 334         (convert-string-kanji-code string cs 3)
 335       string)))
 336
 337 (defun write-region-as-mime-charset (charset start end filename)
 338   "Like `write-region', q.v., but code-convert by MIME CHARSET.
 339 \[emu-nemacs.el]"
 340   (let ((kanji-fileio-code
 341          (or (mime-charset-to-coding-system charset)
 342              *noconv*)))
 343     (write-region start end filename)
 344     ))
 345
 346
 347 ;;; @ buffer representation
 348 ;;;
 349
 350 (defsubst-maybe set-buffer-multibyte (flag)
 351   "Set the multibyte flag of the current buffer to FLAG.
 352 If FLAG is t, this makes the buffer a multibyte buffer.
 353 If FLAG is nil, this makes the buffer a single-byte buffer.
 354 The buffer contents remain unchanged as a sequence of bytes
 355 but the contents viewed as characters do change.
 356 \[Emacs 20.3 emulating function]"
 357   (setq kanji-flag flag)
 358   )
 359
 360
 361 ;;; @ character
 362 ;;;
 363
 364 (defun char-charset (chr)
 365   "Return the character set of char CHR.
 366 \[emu-nemacs.el; MULE emulating function]"
 367   (if (< chr 128)
 368       'ascii
 369     'japanese-jisx0208))
 370
 371 (defun char-bytes (chr)
 372   "Return number of bytes CHAR will occupy in a buffer.
 373 \[emu-nemacs.el; Mule emulating function]"
 374   (if (< chr 128) 1 2))
 375
 376 (defun char-width (char)
 377   "Return number of columns a CHAR occupies when displayed.
 378 \[emu-nemacs.el]"
 379   (if (< char 128)
 380       1
 381     2))
 382
 383 (defalias 'char-length 'char-bytes)
 384
 385 (defmacro char-next-index (char index)
 386   "Return index of character succeeding CHAR whose index is INDEX."
 387   (` (+ (, index) (char-bytes (, char)))))
 388
 389
 390 ;;; @ string
 391 ;;;
 392
 393 (defalias 'string-width 'length)
 394
 395 (defun sref (str idx)
 396   "Return the character in STR at index IDX.
 397 \[emu-nemacs.el; Mule emulating function]"
 398   (let ((chr (aref str idx)))
 399     (if (< chr 128)
 400         chr
 401       (logior (lsh (aref str (1+ idx)) 8) chr)
 402       )))
 403
 404 (defun string-to-char-list (str)
 405   (let ((i 0)(len (length str)) dest chr)
 406     (while (< i len)
 407       (setq chr (aref str i))
 408       (if (>= chr 128)
 409           (setq i (1+ i)
 410                 chr (+ (lsh chr 8) (aref str i))
 411                 ))
 412       (setq dest (cons chr dest))
 413       (setq i (1+ i))
 414       )
 415     (reverse dest)
 416     ))
 417
 418 (fset 'string-to-int-list (symbol-function 'string-to-char-list))
 419
 420 ;;; Imported from Mule-2.3
 421 (defun truncate-string (str width &optional start-column)
 422   "Truncate STR to fit in WIDTH columns.
 423 Optional non-nil arg START-COLUMN specifies the starting column.
 424 \[emu-mule.el; Mule 2.3 emulating function]"
 425   (or start-column
 426       (setq start-column 0))
 427   (let ((max-width (string-width str))
 428         (len (length str))
 429         (from 0)
 430         (column 0)
 431         to-prev to ch)
 432     (if (>= width max-width)
 433         (setq width max-width))
 434     (if (>= start-column width)
 435         ""
 436       (while (< column start-column)
 437         (setq ch (aref str from)
 438               column (+ column (char-columns ch))
 439               from (+ from (char-bytes ch))))
 440       (if (< width max-width)
 441           (progn
 442             (setq to from)
 443             (while (<= column width)
 444               (setq ch (aref str to)
 445                     column (+ column (char-columns ch))
 446                     to-prev to
 447                     to (+ to (char-bytes ch))))
 448             (setq to to-prev)))
 449       (substring str from to))))
 450
 451 (defalias 'looking-at-as-unibyte 'looking-at)
 452
 453 ;;; @@ obsoleted aliases
 454 ;;;
 455 ;;; You should not use them.
 456
 457 (defalias 'string-columns 'length)
 458
 459
 460 ;;; @ text property emulation
 461 ;;;
 462
 463 (defvar emu:available-face-attribute-alist
 464   '(
 465     ;;(bold      . inversed-region)
 466     (italic    . underlined-region)
 467     (underline . underlined-region)
 468     ))
 469
 470 ;; by YAMATE Keiichirou 1994/10/28
 471 (defun attribute-add-narrow-attribute (attr from to)
 472   (or (consp (symbol-value attr))
 473       (set attr (list 1)))
 474   (let* ((attr-value (symbol-value attr))
 475          (len (car attr-value))
 476          (posfrom 1)
 477          posto)
 478     (while (and (< posfrom len)
 479                 (> from (nth posfrom attr-value)))
 480       (setq posfrom (1+ posfrom)))
 481     (setq posto posfrom)
 482     (while (and (< posto len)
 483                 (> to (nth posto attr-value)))
 484       (setq posto (1+ posto)))
 485     (if  (= posto posfrom)
 486         (if (= (% posto 2) 1)
 487             (if (and (< to len)
 488                      (= to (nth posto attr-value)))
 489                 (set-marker (nth posto attr-value) from)
 490               (setcdr (nthcdr (1- posfrom) attr-value)
 491                       (cons (set-marker-type (set-marker (make-marker)
 492                                                          from)
 493                                              'point-type)
 494                             (cons (set-marker-type (set-marker (make-marker)
 495                                                                to)
 496                                                    nil)
 497                                   (nthcdr posto attr-value))))
 498               (setcar attr-value (+ len 2))))
 499       (if (= (% posfrom 2) 0)
 500           (setq posfrom (1- posfrom))
 501         (set-marker (nth posfrom attr-value) from))
 502       (if (= (% posto 2) 0)
 503           nil
 504         (setq posto (1- posto))
 505         (set-marker (nth posto attr-value) to))
 506       (setcdr (nthcdr posfrom attr-value)
 507               (nthcdr posto attr-value)))))
 508
 509 (defalias 'make-overlay 'cons)
 510
 511 (defun overlay-put (overlay prop value)
 512   (let ((ret (and (eq prop 'face)
 513                   (assq value emu:available-face-attribute-alist)
 514                   )))
 515     (if ret
 516         (attribute-add-narrow-attribute (cdr ret)
 517                                         (car overlay)(cdr overlay))
 518       )))
 519
 520
 521 ;;; @ end
 522 ;;;
 523
 524 (provide 'emu-nemacs)
 525
 526 ;;; emu-nemacs.el ends here