;;; Code:
-(require 'emu-18)
+(require 'poem)
-;;; @ character set
+;;; @ coding system
;;;
-(put 'ascii
- 'charset-description "Character set of ASCII")
-(put 'ascii
- 'charset-registry "ASCII")
-
-(put 'japanese-jisx0208
- 'charset-description "Character set of JIS X0208-1983")
-(put 'japanese-jisx0208
- 'charset-registry "JISX0208.1983")
-
-(defun charset-description (charset)
- "Return description of CHARSET. [emu-nemacs.el]"
- (get charset 'charset-description)
- )
-
-(defun charset-registry (charset)
- "Return registry name of CHARSET. [emu-nemacs.el]"
- (get charset 'charset-registry)
- )
-
-(defun charset-width (charset)
- "Return number of columns a CHARSET occupies when displayed.
-\[emu-nemacs.el]"
- (if (eq charset 'ascii)
- 1
- 2))
-
-(defun charset-direction (charset)
- "Return the direction of a character of CHARSET by
- 0 (left-to-right) or 1 (right-to-left). [emu-nemacs.el]"
- 0)
-
-(defun find-charset-string (str)
- "Return a list of charsets in the string.
-\[emu-nemacs.el; Mule emulating function]"
- (if (string-match "[\200-\377]" str)
- '(japanese-jisx0208)
- ))
-
-(defalias 'find-non-ascii-charset-string 'find-charset-string)
-
-(defun find-charset-region (start end)
- "Return a list of charsets in the region between START and END.
-\[emu-nemacs.el; Mule emulating function]"
- (if (save-excursion
- (save-restriction
- (narrow-to-region start end)
- (goto-char start)
- (re-search-forward "[\200-\377]" nil t)
- ))
- '(japanese-jisx0208)
- ))
-
-(defalias 'find-non-ascii-charset-region 'find-charset-region)
-
-(defun check-ASCII-string (str)
- (let ((i 0)
- len)
- (setq len (length str))
- (catch 'label
- (while (< i len)
- (if (>= (elt str i) 128)
- (throw 'label nil))
- (setq i (+ i 1))
- )
- str)))
-
;;; @@ for old MULE emulation
;;;
-;;(defconst lc-ascii 0)
-;;(defconst lc-jp 146)
-
-
-;;; @ coding system
-;;;
-
(defconst *noconv* 0)
(defconst *sjis* 1)
(defconst *junet* 2)
(defconst *internal* 3)
(defconst *euc-japan* 3)
-(defun decode-coding-string (string coding-system)
- "Decode the STRING which is encoded in CODING-SYSTEM.
-\[emu-nemacs.el; EMACS 20 emulating function]"
- (if (eq coding-system 3)
- string
- (convert-string-kanji-code string coding-system 3)
- ))
-
-(defun encode-coding-string (string coding-system)
- "Encode the STRING to CODING-SYSTEM.
-\[emu-nemacs.el; EMACS 20 emulating function]"
- (if (eq coding-system 3)
- string
- (convert-string-kanji-code string 3 coding-system)
- ))
-
-(defun decode-coding-region (start end coding-system)
- "Decode the text between START and END which is encoded in CODING-SYSTEM.
-\[emu-nemacs.el; EMACS 20 emulating function]"
- (if (/= ic oc)
- (save-excursion
- (save-restriction
- (narrow-to-region start end)
- (convert-region-kanji-code start end coding-system 3)
- ))))
-
-(defun encode-coding-region (start end coding-system)
- "Encode the text between START and END to CODING-SYSTEM.
-\[emu-nemacs.el; EMACS 20 emulating function]"
- (if (/= ic oc)
- (save-excursion
- (save-restriction
- (narrow-to-region start end)
- (convert-region-kanji-code start end 3 coding-system)
- ))))
-
-(defun detect-coding-region (start end)
- "Detect coding-system of the text in the region between START and END.
-\[emu-nemacs.el; Emacs 20 emulating function]"
- (if (save-excursion
- (save-restriction
- (narrow-to-region start end)
- (goto-char start)
- (re-search-forward "[\200-\377]" nil t)
- ))
- *euc-japan*
- ))
-
-(defalias 'set-buffer-file-coding-system 'set-kanji-fileio-code)
-
-
-;;; @@ for old MULE emulation
-;;;
-
(defun code-convert-string (str ic oc)
"Convert code in STRING from SOURCE code to TARGET code,
On successful converion, returns the result string,
(save-excursion
(save-restriction
(narrow-to-region beg end)
- (convert-region-kanji-code beg end ic oc)
- ))))
+ (convert-region-kanji-code beg end ic oc)))
+ ))
;;; @ without code-conversion
;;;
-(defmacro as-binary-process (&rest body)
- (` (let (selective-display ; Disable ^M to nl translation.
- ;; NEmacs
- kanji-flag
- (default-kanji-process-code 0)
- program-kanji-code-alist)
- (,@ body)
- )))
-
-(defmacro as-binary-input-file (&rest body)
- (` (let (kanji-flag)
- (,@ body)
- )))
-
-(defmacro as-binary-output-file (&rest body)
- (` (let (kanji-flag)
- (,@ body)
- )))
-
-(defun write-region-as-binary (start end filename
- &optional append visit lockname)
- "Like `write-region', q.v., but don't code conversion. [emu-nemacs.el]"
- (let (kanji-flag)
- (write-region start end filename append visit)
- ))
-
-(defun insert-file-contents-as-binary (filename
- &optional visit beg end replace)
- "Like `insert-file-contents', q.v., but don't character code conversion.
-\[emu-nemacs.el]"
- (let (kanji-flag)
- (insert-file-contents filename visit beg end replace)
- ))
-
(fset 'insert-binary-file-contents 'insert-file-contents-as-binary)
(defun insert-binary-file-contents-literally (filename
find-file-hooks, etc.
This function ensures that none of these modifications will take place.
\[emu-nemacs.el]"
- (let (kanji-flag)
- (insert-file-contents-literally filename visit beg end replace)
- ))
-
-(defun insert-file-contents-as-raw-text (filename
- &optional visit beg end replace)
- "Like `insert-file-contents', q.v., but don't character code conversion.
-\[emu-nemacs.el]"
- (let (kanji-flag)
- (insert-file-contents filename visit beg end replace)
- ))
-
-(defun write-region-as-raw-text-CRLF (start end filename
- &optional append visit lockname)
- "Like `write-region', q.v., but don't code conversion. [emu-nemacs.el]"
- (let ((the-buf (current-buffer)))
- (with-temp-buffer
- (insert-buffer-substring the-buf start end)
- (goto-char (point-min))
- (while (re-search-forward "\\(\\=\\|[^\r]\\)\n" nil t)
- (replace-match "\\1\r\n")
- )
- (let (kanji-flag)
- (write-region (point-min)(point-max) filename append visit)
- ))))
-
-
-;;; @ MIME charset
-;;;
-
-(defvar charsets-mime-charset-alist
- '(((ascii) . us-ascii)))
-
-(defvar default-mime-charset 'iso-2022-jp)
-
-(defvar mime-charset-coding-system-alist
- '((iso-2022-jp . 2)
- (shift_jis . 1)
- ))
-
-(defun mime-charset-to-coding-system (charset)
- (if (stringp charset)
- (setq charset (intern (downcase charset)))
- )
- (cdr (assq charset mime-charset-coding-system-alist))
- )
-
-(defun detect-mime-charset-region (start end)
- "Return MIME charset for region between START and END.
-\[emu-nemacs.el]"
- (if (save-excursion
- (save-restriction
- (narrow-to-region start end)
- (goto-char start)
- (re-search-forward "[\200-\377]" nil t)
- ))
- default-mime-charset
- 'us-ascii))
-
-(defun encode-mime-charset-region (start end charset)
- "Encode the text between START and END as MIME CHARSET.
-\[emu-nemacs.el]"
- (let ((cs (mime-charset-to-coding-system charset)))
- (and (numberp cs)
- (or (= cs 3)
- (save-excursion
- (save-restriction
- (narrow-to-region start end)
- (convert-region-kanji-code start end 3 cs)
- ))
- ))))
-
-(defun decode-mime-charset-region (start end charset &optional lbt)
- "Decode the text between START and END as MIME CHARSET.
-\[emu-nemacs.el]"
- (let ((cs (mime-charset-to-coding-system charset))
- (nl (cdr (assq lbt '((CRLF . "\r\n") (CR . "\r")
- (dos . "\r\n") (mac . "\r"))))))
- (and (numberp cs)
- (or (= cs 3)
- (save-excursion
- (save-restriction
- (narrow-to-region start end)
- (convert-region-kanji-code start end cs 3)
- (if nl
- (progn
- (goto-char (point-min))
- (while (search-forward nl nil t)
- (replace-match "\n"))))
- ))
- ))))
-
-(defun encode-mime-charset-string (string charset)
- "Encode the STRING as MIME CHARSET. [emu-nemacs.el]"
- (let ((cs (mime-charset-to-coding-system charset)))
- (if cs
- (convert-string-kanji-code string 3 cs)
- string)))
-
-(defun decode-mime-charset-string (string charset &optional lbt)
- "Decode the STRING as MIME CHARSET. [emu-nemacs.el]"
- (with-temp-buffer
- (insert string)
- (decode-mime-charset-region (point-min)(point-max) charset lbt)
- (buffer-string)))
-
-(defun write-region-as-mime-charset (charset start end filename)
- "Like `write-region', q.v., but code-convert by MIME CHARSET.
-\[emu-nemacs.el]"
- (let ((kanji-fileio-code
- (or (mime-charset-to-coding-system charset)
- *noconv*)))
- (write-region start end filename)
- ))
-
-
-;;; @ buffer representation
-;;;
-
-(defsubst-maybe set-buffer-multibyte (flag)
- "Set the multibyte flag of the current buffer to FLAG.
-If FLAG is t, this makes the buffer a multibyte buffer.
-If FLAG is nil, this makes the buffer a single-byte buffer.
-The buffer contents remain unchanged as a sequence of bytes
-but the contents viewed as characters do change.
-\[Emacs 20.3 emulating function]"
- (setq kanji-flag flag)
- )
-
-
-;;; @ character
-;;;
-
-(defun char-charset (chr)
- "Return the character set of char CHR.
-\[emu-nemacs.el; MULE emulating function]"
- (if (< chr 128)
- 'ascii
- 'japanese-jisx0208))
-
-(defun char-bytes (chr)
- "Return number of bytes CHAR will occupy in a buffer.
-\[emu-nemacs.el; Mule emulating function]"
- (if (< chr 128) 1 2))
-
-(defun char-width (char)
- "Return number of columns a CHAR occupies when displayed.
-\[emu-nemacs.el]"
- (if (< char 128)
- 1
- 2))
-
-(defalias 'char-length 'char-bytes)
-
-(defmacro char-next-index (char index)
- "Return index of character succeeding CHAR whose index is INDEX."
- (` (+ (, index) (char-bytes (, char)))))
-
-
-;;; @ string
-;;;
-
-(defalias 'string-width 'length)
-
-(defun sref (str idx)
- "Return the character in STR at index IDX.
-\[emu-nemacs.el; Mule emulating function]"
- (let ((chr (aref str idx)))
- (if (< chr 128)
- chr
- (logior (lsh (aref str (1+ idx)) 8) chr)
- )))
-
-(defun string-to-char-list (str)
- (let ((i 0)(len (length str)) dest chr)
- (while (< i len)
- (setq chr (aref str i))
- (if (>= chr 128)
- (setq i (1+ i)
- chr (+ (lsh chr 8) (aref str i))
- ))
- (setq dest (cons chr dest))
- (setq i (1+ i))
- )
- (reverse dest)
- ))
-
-(fset 'string-to-int-list (symbol-function 'string-to-char-list))
-
-;;; Imported from Mule-2.3
-(defun truncate-string (str width &optional start-column)
- "Truncate STR to fit in WIDTH columns.
-Optional non-nil arg START-COLUMN specifies the starting column.
-\[emu-mule.el; Mule 2.3 emulating function]"
- (or start-column
- (setq start-column 0))
- (let ((max-width (string-width str))
- (len (length str))
- (from 0)
- (column 0)
- to-prev to ch)
- (if (>= width max-width)
- (setq width max-width))
- (if (>= start-column width)
- ""
- (while (< column start-column)
- (setq ch (aref str from)
- column (+ column (char-columns ch))
- from (+ from (char-bytes ch))))
- (if (< width max-width)
- (progn
- (setq to from)
- (while (<= column width)
- (setq ch (aref str to)
- column (+ column (char-columns ch))
- to-prev to
- to (+ to (char-bytes ch))))
- (setq to to-prev)))
- (substring str from to))))
-
-(defalias 'looking-at-as-unibyte 'looking-at)
-
-;;; @@ obsoleted aliases
-;;;
-;;; You should not use them.
-
-(defalias 'string-columns 'length)
-
-
-;;; @ text property emulation
-;;;
-
-(defvar emu:available-face-attribute-alist
- '(
- ;;(bold . inversed-region)
- (italic . underlined-region)
- (underline . underlined-region)
- ))
-
-;; by YAMATE Keiichirou 1994/10/28
-(defun attribute-add-narrow-attribute (attr from to)
- (or (consp (symbol-value attr))
- (set attr (list 1)))
- (let* ((attr-value (symbol-value attr))
- (len (car attr-value))
- (posfrom 1)
- posto)
- (while (and (< posfrom len)
- (> from (nth posfrom attr-value)))
- (setq posfrom (1+ posfrom)))
- (setq posto posfrom)
- (while (and (< posto len)
- (> to (nth posto attr-value)))
- (setq posto (1+ posto)))
- (if (= posto posfrom)
- (if (= (% posto 2) 1)
- (if (and (< to len)
- (= to (nth posto attr-value)))
- (set-marker (nth posto attr-value) from)
- (setcdr (nthcdr (1- posfrom) attr-value)
- (cons (set-marker-type (set-marker (make-marker)
- from)
- 'point-type)
- (cons (set-marker-type (set-marker (make-marker)
- to)
- nil)
- (nthcdr posto attr-value))))
- (setcar attr-value (+ len 2))))
- (if (= (% posfrom 2) 0)
- (setq posfrom (1- posfrom))
- (set-marker (nth posfrom attr-value) from))
- (if (= (% posto 2) 0)
- nil
- (setq posto (1- posto))
- (set-marker (nth posto attr-value) to))
- (setcdr (nthcdr posfrom attr-value)
- (nthcdr posto attr-value)))))
-
-(defalias 'make-overlay 'cons)
-
-(defun overlay-put (overlay prop value)
- (let ((ret (and (eq prop 'face)
- (assq value emu:available-face-attribute-alist)
- )))
- (if ret
- (attribute-add-narrow-attribute (cdr ret)
- (car overlay)(cdr overlay))
- )))
+ (as-binary-input-file
+ ;; Returns list absolute file name and length of data inserted.
+ (insert-file-contents-literally filename visit beg end replace)))
;;; @ end