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