emu-nemacs.el

   1 ;;; emu-nemacs.el --- Mule 2 emulation module for NEmacs
   2
   3 ;; Copyright (C) 1995,1996 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Version:
   7 ;;      $Id: emu-nemacs.el,v 7.43 1996/09/05 13:28:51 morioka Exp $
   8 ;; Keywords: emulation, compatibility, NEmacs, mule
   9
  10 ;; This file is part of tl (Tiny Library).
  11
  12 ;; This program is free software; you can redistribute it and/or
  13 ;; modify it under the terms of the GNU General Public License as
  14 ;; published by the Free Software Foundation; either version 2, or (at
  15 ;; your option) any later version.
  16
  17 ;; This program is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with this program; see the file COPYING.  If not, write to
  24 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Code:
  28
  29 (require 'emu-18)
  30
  31
  32 ;;; @ character set
  33 ;;;
  34
  35 (defconst charset-ascii 0 "Character set of ASCII")
  36 (defconst charset-jisx0208 146 "Character set of JIS X0208-1983")
  37
  38 (defun charset-description (charset)
  39   "Return description of CHARSET. [emu-nemacs.el]"
  40   (if (< charset 128)
  41       (documentation-property 'charset-ascii 'variable-documentation)
  42     (documentation-property 'charset-jisx0208 'variable-documentation)
  43     ))
  44
  45 (defun charset-registry (charset)
  46   "Return registry name of CHARSET. [emu-nemacs.el]"
  47   (if (< charset 128)
  48       "ASCII"
  49     "JISX0208.1983"))
  50
  51 (defun charset-columns (charset)
  52   "Return number of columns a CHARSET occupies when displayed.
  53 \[emu-nemacs.el]"
  54   (if (< charset 128)
  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       (list lc-jp)
  68     ))
  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 (defun check-ASCII-string (str)
  83   (let ((i 0)
  84         len)
  85     (setq len (length str))
  86     (catch 'label
  87       (while (< i len)
  88         (if (>= (elt str i) 128)
  89             (throw 'label nil))
  90         (setq i (+ i 1))
  91         )
  92       str)))
  93
  94 ;;; @@ for old MULE emulation
  95 ;;;
  96
  97 (defconst lc-ascii 0)
  98 (defconst lc-jp  146)
  99
 100
 101 ;;; @ coding system
 102 ;;;
 103
 104 (defconst *noconv*    0)
 105 (defconst *sjis*      1)
 106 (defconst *junet*     2)
 107 (defconst *ctext*     2)
 108 (defconst *internal*  3)
 109 (defconst *euc-japan* 3)
 110
 111 (defun decode-coding-string (string coding-system)
 112   "Decode the STRING which is encoded in CODING-SYSTEM.
 113 \[emu-nemacs.el; EMACS 20 emulating function]"
 114   (if (eq coding-system 3)
 115       string
 116     (convert-string-kanji-code string coding-system 3)
 117     ))
 118
 119 (defun encode-coding-string (string coding-system)
 120   "Encode the STRING to CODING-SYSTEM.
 121 \[emu-nemacs.el; EMACS 20 emulating function]"
 122   (if (eq coding-system 3)
 123       string
 124     (convert-string-kanji-code string 3 coding-system)
 125     ))
 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 code-detect-region (start end)
 148   "Detect coding-system of the text in the region between START and END.
 149 \[emu-nemacs.el; Mule 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           ))
 156       *euc-japan*
 157     ))
 158
 159 (defun set-file-coding-system (coding-system &optional force)
 160   (set-kanji-fileio-code coding-system)
 161   )
 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 ;;; @@ for old MULE emulation
 173 ;;;
 174
 175 (defun code-convert-string (str ic oc)
 176   "Convert code in STRING from SOURCE code to TARGET code,
 177 On successful converion, returns the result string,
 178 else returns nil. [emu-nemacs.el; Mule emulating function]"
 179   (if (not (eq ic oc))
 180       (convert-string-kanji-code str ic oc)
 181     str))
 182
 183 (defun code-convert-region (beg end ic oc)
 184   "Convert code of the text between BEGIN and END from SOURCE
 185 to TARGET. On successful conversion returns t,
 186 else returns nil. [emu-nemacs.el; Mule emulating function]"
 187   (if (/= ic oc)
 188       (save-excursion
 189         (save-restriction
 190           (narrow-to-region beg end)
 191           (convert-region-kanji-code beg end ic oc)
 192           ))))
 193
 194
 195 ;;; @ MIME charset
 196 ;;;
 197
 198 (defvar charsets-mime-charset-alist
 199   (list (cons (list charset-ascii) 'us-ascii)))
 200
 201 (defvar default-mime-charset 'iso-2022-jp)
 202
 203 (defvar mime-charset-coding-system-alist
 204   '((iso-2022-jp     . 2)
 205     (shift_jis       . 1)
 206     ))
 207
 208 (defun mime-charset-to-coding-system (charset)
 209   (if (stringp charset)
 210       (setq charset (intern (downcase charset)))
 211     )
 212   (cdr (assq charset mime-charset-coding-system-alist))
 213   )
 214
 215 (defun detect-mime-charset-region (start end)
 216   "Return MIME charset for region between START and END.
 217 \[emu-nemacs.el]"
 218   (if (save-excursion
 219         (save-restriction
 220           (narrow-to-region start end)
 221           (goto-char start)
 222           (re-search-forward "[\200-\377]" nil t)
 223           ))
 224       default-mime-charset
 225     'us-ascii))
 226
 227 (defun encode-mime-charset-region (start end charset)
 228   "Encode the text between START and END as MIME CHARSET.
 229 \[emu-nemacs.el]"
 230   (let ((cs (mime-charset-to-coding-system charset)))
 231     (and (numberp cs)
 232          (or (= cs 3)
 233              (save-excursion
 234                (save-restriction
 235                  (narrow-to-region start end)
 236                  (convert-region-kanji-code start end 3 cs)
 237                  ))
 238              ))))
 239
 240 (defun decode-mime-charset-region (start end charset)
 241   "Decode the text between START and END as MIME CHARSET.
 242 \[emu-nemacs.el]"
 243   (let ((cs (mime-charset-to-coding-system charset)))
 244     (and (numberp cs)
 245          (or (= cs 3)
 246              (save-excursion
 247                (save-restriction
 248                  (narrow-to-region start end)
 249                  (convert-region-kanji-code start end cs 3)
 250                  ))
 251              ))))
 252
 253 (defun encode-mime-charset-string (string charset)
 254   "Encode the STRING as MIME CHARSET. [emu-nemacs.el]"
 255   (let ((cs (mime-charset-to-coding-system charset)))
 256     (if cs
 257         (convert-string-kanji-code string 3 cs)
 258       string)))
 259
 260 (defun decode-mime-charset-string (string charset)
 261   "Decode the STRING as MIME CHARSET. [emu-nemacs.el]"
 262   (let ((cs (mime-charset-to-coding-system charset)))
 263     (if cs
 264         (convert-string-kanji-code string cs 3)
 265       string)))
 266
 267
 268 ;;; @ character
 269 ;;;
 270
 271 (defun char-charset (chr)
 272   "Return the character set of char CHR.
 273 \[emu-nemacs.el; XEmacs 20 emulating function]"
 274   (if (< chr 128)
 275       charset-ascii
 276     charset-jisx0208))
 277
 278 (defun char-bytes (chr)
 279   "Return number of bytes CHAR will occupy in a buffer.
 280 \[emu-nemacs.el; Mule emulating function]"
 281   (if (< chr 128) 1 2))
 282
 283 (defalias 'char-length 'char-bytes)
 284
 285 (defun char-columns (character)
 286   "Return number of columns a CHARACTER occupies when displayed.
 287 \[emu-nemacs.el]"
 288   (if (< character 128)
 289       1
 290     2))
 291
 292 ;;; @@ for Mule emulation
 293 ;;;
 294
 295 (defalias 'char-leading-char 'char-charset)
 296
 297 (defalias 'char-width 'char-columns)
 298
 299
 300 ;;; @ string
 301 ;;;
 302
 303 (defalias 'string-columns 'length)
 304
 305 (defun sref (str idx)
 306   "Return the character in STR at index IDX.
 307 \[emu-nemacs.el; Mule emulating function]"
 308   (let ((chr (aref str idx)))
 309     (if (< chr 128)
 310         chr
 311       (logior (lsh (aref str (1+ idx)) 8) chr)
 312       )))
 313
 314 (defun string-to-char-list (str)
 315   (let ((i 0)(len (length str)) dest chr)
 316     (while (< i len)
 317       (setq chr (aref str i))
 318       (if (>= chr 128)
 319           (setq i (1+ i)
 320                 chr (+ (lsh chr 8) (aref str i))
 321                 ))
 322       (setq dest (cons chr dest))
 323       (setq i (1+ i))
 324       )
 325     (reverse dest)
 326     ))
 327
 328 (fset 'string-to-int-list (symbol-function 'string-to-char-list))
 329
 330 ;;; Imported from Mule-2.3
 331 (defun truncate-string (str width &optional start-column)
 332   "Truncate STR to fit in WIDTH columns.
 333 Optional non-nil arg START-COLUMN specifies the starting column.
 334 \[emu-mule.el; Mule 2.3 emulating function]"
 335   (or start-column
 336       (setq start-column 0))
 337   (let ((max-width (string-width str))
 338         (len (length str))
 339         (from 0)
 340         (column 0)
 341         to-prev to ch)
 342     (if (>= width max-width)
 343         (setq width max-width))
 344     (if (>= start-column width)
 345         ""
 346       (while (< column start-column)
 347         (setq ch (aref str from)
 348               column (+ column (char-columns ch))
 349               from (+ from (char-bytes ch))))
 350       (if (< width max-width)
 351           (progn
 352             (setq to from)
 353             (while (<= column width)
 354               (setq ch (aref str to)
 355                     column (+ column (char-columns ch))
 356                     to-prev to
 357                     to (+ to (char-bytes ch))))
 358             (setq to to-prev)))
 359       (substring str from to))))
 360
 361 ;;; @@ for Mule emulation
 362 ;;;
 363
 364 (defalias 'string-width 'length)
 365
 366
 367 ;;; @ text property emulation
 368 ;;;
 369
 370 (setq tl:available-face-attribute-alist
 371       '(
 372         ;;(bold      . inversed-region)
 373         (italic    . underlined-region)
 374         (underline . underlined-region)
 375         ))
 376
 377 ;; by YAMATE Keiichirou 1994/10/28
 378 (defun attribute-add-narrow-attribute (attr from to)
 379   (or (consp (symbol-value attr))
 380       (set attr (list 1)))
 381   (let* ((attr-value (symbol-value attr))
 382          (len (car attr-value))
 383          (posfrom 1)
 384          posto)
 385     (while (and (< posfrom len)
 386                 (> from (nth posfrom attr-value)))
 387       (setq posfrom (1+ posfrom)))
 388     (setq posto posfrom)
 389     (while (and (< posto len)
 390                 (> to (nth posto attr-value)))
 391       (setq posto (1+ posto)))
 392     (if  (= posto posfrom)
 393         (if (= (% posto 2) 1)
 394             (if (and (< to len)
 395                      (= to (nth posto attr-value)))
 396                 (set-marker (nth posto attr-value) from)
 397               (setcdr (nthcdr (1- posfrom) attr-value)
 398                       (cons (set-marker-type (set-marker (make-marker)
 399                                                          from)
 400                                              'point-type)
 401                             (cons (set-marker-type (set-marker (make-marker)
 402                                                                to)
 403                                                    nil)
 404                                   (nthcdr posto attr-value))))
 405               (setcar attr-value (+ len 2))))
 406       (if (= (% posfrom 2) 0)
 407           (setq posfrom (1- posfrom))
 408         (set-marker (nth posfrom attr-value) from))
 409       (if (= (% posto 2) 0)
 410           nil
 411         (setq posto (1- posto))
 412         (set-marker (nth posto attr-value) to))
 413       (setcdr (nthcdr posfrom attr-value)
 414               (nthcdr posto attr-value)))))
 415
 416 (defalias 'tl:make-overlay 'cons)
 417
 418 (defun tl:overlay-put (overlay prop value)
 419   (let ((ret (and (eq prop 'face)
 420                   (assq value tl:available-face-attribute-alist)
 421                   )))
 422     (if ret
 423         (attribute-add-narrow-attribute (cdr ret)
 424                                         (car overlay)(cdr overlay))
 425       )))
 426
 427
 428 ;;; @ end
 429 ;;;
 430
 431 (provide 'emu-nemacs)
 432
 433 ;;; emu-nemacs.el ends here