emu-nemacs.el

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