1997-02-20 07:02:49 +00:00
|
|
|
|
;;; mule-util.el --- Utility functions for mulitilingual environment (mule)
|
|
|
|
|
|
|
|
|
|
;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
|
1997-06-22 08:57:18 +00:00
|
|
|
|
;; Licensed to the Free Software Foundation.
|
1997-02-20 07:02:49 +00:00
|
|
|
|
|
|
|
|
|
;; Keywords: mule, multilingual
|
|
|
|
|
|
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
|
|
|
|
|
|
;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
|
|
|
;; it under the terms of the GNU General Public License as published by
|
|
|
|
|
;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
|
|
;; any later version.
|
|
|
|
|
|
|
|
|
|
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
|
;; GNU General Public License for more details.
|
|
|
|
|
|
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
1997-02-23 09:20:52 +00:00
|
|
|
|
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
|
|
|
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
|
|
;; Boston, MA 02111-1307, USA.
|
1997-02-20 07:02:49 +00:00
|
|
|
|
|
|
|
|
|
;;; Code:
|
|
|
|
|
|
|
|
|
|
;;; String manipulations while paying attention to multibyte
|
|
|
|
|
;;; characters.
|
|
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun string-to-sequence (string type)
|
|
|
|
|
"Convert STRING to a sequence of TYPE which contains characters in STRING.
|
1997-06-10 00:56:20 +00:00
|
|
|
|
TYPE should be `list' or `vector'."
|
2000-04-01 12:03:57 +00:00
|
|
|
|
;;; (let ((len (length string))
|
|
|
|
|
;;; (i 0)
|
|
|
|
|
;;; val)
|
1998-01-22 01:42:20 +00:00
|
|
|
|
(cond ((eq type 'list)
|
2000-04-01 12:03:57 +00:00
|
|
|
|
;; Applicable post-Emacs 20.2 and asymptotically ~10 times
|
|
|
|
|
;; faster than the code below:
|
|
|
|
|
(append string nil))
|
|
|
|
|
;;; (setq val (make-list len 0))
|
|
|
|
|
;;; (let ((l val))
|
|
|
|
|
;;; (while (< i len)
|
|
|
|
|
;;; (setcar l (aref string i))
|
|
|
|
|
;;; (setq l (cdr l) i (1+ i))))))
|
1998-01-22 01:42:20 +00:00
|
|
|
|
((eq type 'vector)
|
2000-04-01 12:03:57 +00:00
|
|
|
|
;; As above.
|
|
|
|
|
(vconcat string))
|
|
|
|
|
;;; (setq val (make-vector len 0))
|
|
|
|
|
;;; (while (< i len)
|
|
|
|
|
;;; (aset val i (aref string i))
|
|
|
|
|
;;; (setq i (1+ i))))
|
1998-01-22 01:42:20 +00:00
|
|
|
|
(t
|
|
|
|
|
(error "Invalid type: %s" type)))
|
2000-04-01 12:03:57 +00:00
|
|
|
|
;;; val)
|
|
|
|
|
)
|
1997-02-20 07:02:49 +00:00
|
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
|
(defsubst string-to-list (string)
|
|
|
|
|
"Return a list of characters in STRING."
|
|
|
|
|
(string-to-sequence string 'list))
|
|
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
|
(defsubst string-to-vector (string)
|
|
|
|
|
"Return a vector of characters in STRING."
|
|
|
|
|
(string-to-sequence string 'vector))
|
|
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun store-substring (string idx obj)
|
|
|
|
|
"Embed OBJ (string or character) at index IDX of STRING."
|
1998-01-22 01:42:20 +00:00
|
|
|
|
(if (integerp obj)
|
|
|
|
|
(aset string idx obj)
|
|
|
|
|
(let ((len1 (length obj))
|
|
|
|
|
(len2 (length string))
|
|
|
|
|
(i 0))
|
|
|
|
|
(while (< i len1)
|
|
|
|
|
(aset string (+ idx i) (aref obj i))
|
|
|
|
|
(setq i (1+ i)))))
|
|
|
|
|
string)
|
1997-02-20 07:02:49 +00:00
|
|
|
|
|
|
|
|
|
;;;###autoload
|
1997-09-13 08:44:55 +00:00
|
|
|
|
(defun truncate-string-to-width (str end-column &optional start-column padding)
|
|
|
|
|
"Truncate string STR to end at column END-COLUMN.
|
1999-12-03 10:31:28 +00:00
|
|
|
|
The optional 3rd arg START-COLUMN, if non-nil, specifies
|
1997-09-13 08:44:55 +00:00
|
|
|
|
the starting column; that means to return the characters occupying
|
|
|
|
|
columns START-COLUMN ... END-COLUMN of STR.
|
|
|
|
|
|
1999-12-03 10:31:28 +00:00
|
|
|
|
The optional 4th arg PADDING, if non-nil, specifies a padding character
|
1997-09-13 08:44:55 +00:00
|
|
|
|
to add at the end of the result if STR doesn't reach column END-COLUMN,
|
|
|
|
|
or if END-COLUMN comes in the middle of a character in STR.
|
|
|
|
|
PADDING is also added at the beginning of the result
|
1997-09-14 18:18:39 +00:00
|
|
|
|
if column START-COLUMN appears in the middle of a character in STR.
|
1997-09-13 08:44:55 +00:00
|
|
|
|
|
|
|
|
|
If PADDING is nil, no padding is added in these cases, so
|
|
|
|
|
the resulting string may be narrower than END-COLUMN."
|
1997-02-20 07:02:49 +00:00
|
|
|
|
(or start-column
|
|
|
|
|
(setq start-column 0))
|
|
|
|
|
(let ((len (length str))
|
|
|
|
|
(idx 0)
|
|
|
|
|
(column 0)
|
|
|
|
|
(head-padding "") (tail-padding "")
|
|
|
|
|
ch last-column last-idx from-idx)
|
|
|
|
|
(condition-case nil
|
|
|
|
|
(while (< column start-column)
|
1998-01-22 01:42:20 +00:00
|
|
|
|
(setq ch (aref str idx)
|
1997-02-20 07:02:49 +00:00
|
|
|
|
column (+ column (char-width ch))
|
1998-01-22 01:42:20 +00:00
|
|
|
|
idx (1+ idx)))
|
1997-02-20 07:02:49 +00:00
|
|
|
|
(args-out-of-range (setq idx len)))
|
|
|
|
|
(if (< column start-column)
|
1997-09-13 08:44:55 +00:00
|
|
|
|
(if padding (make-string end-column padding) "")
|
1997-02-20 07:02:49 +00:00
|
|
|
|
(if (and padding (> column start-column))
|
1998-01-22 01:42:20 +00:00
|
|
|
|
(setq head-padding (make-string (- column start-column) padding)))
|
1997-02-20 07:02:49 +00:00
|
|
|
|
(setq from-idx idx)
|
1997-09-13 08:44:55 +00:00
|
|
|
|
(if (< end-column column)
|
|
|
|
|
(setq idx from-idx)
|
|
|
|
|
(condition-case nil
|
|
|
|
|
(while (< column end-column)
|
|
|
|
|
(setq last-column column
|
|
|
|
|
last-idx idx
|
1998-01-22 01:42:20 +00:00
|
|
|
|
ch (aref str idx)
|
1997-09-13 08:44:55 +00:00
|
|
|
|
column (+ column (char-width ch))
|
1998-01-22 01:42:20 +00:00
|
|
|
|
idx (1+ idx)))
|
1997-09-13 08:44:55 +00:00
|
|
|
|
(args-out-of-range (setq idx len)))
|
|
|
|
|
(if (> column end-column)
|
|
|
|
|
(setq column last-column idx last-idx))
|
|
|
|
|
(if (and padding (< column end-column))
|
|
|
|
|
(setq tail-padding (make-string (- end-column column) padding))))
|
1997-02-20 07:02:49 +00:00
|
|
|
|
(setq str (substring str from-idx idx))
|
|
|
|
|
(if padding
|
|
|
|
|
(concat head-padding str tail-padding)
|
|
|
|
|
str))))
|
|
|
|
|
|
1998-09-06 14:31:49 +00:00
|
|
|
|
;;; For backward compatibility ...
|
1997-02-20 07:02:49 +00:00
|
|
|
|
;;;###autoload
|
|
|
|
|
(defalias 'truncate-string 'truncate-string-to-width)
|
2000-06-01 05:07:32 +00:00
|
|
|
|
(make-obsolete 'truncate-string 'truncate-string-to-width "20.1")
|
1997-02-20 07:02:49 +00:00
|
|
|
|
|
|
|
|
|
;;; Nested alist handler. Nested alist is alist whose elements are
|
|
|
|
|
;;; also nested alist.
|
|
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
|
(defsubst nested-alist-p (obj)
|
1998-09-06 14:31:49 +00:00
|
|
|
|
"Return t if OBJ is a nested alist.
|
1997-02-20 07:02:49 +00:00
|
|
|
|
|
|
|
|
|
Nested alist is a list of the form (ENTRY . BRANCHES), where ENTRY is
|
|
|
|
|
any Lisp object, and BRANCHES is a list of cons cells of the form
|
|
|
|
|
(KEY-ELEMENT . NESTED-ALIST).
|
|
|
|
|
|
|
|
|
|
You can use a nested alist to store any Lisp object (ENTRY) for a key
|
|
|
|
|
sequence KEYSEQ, where KEYSEQ is a sequence of KEY-ELEMENT. KEYSEQ
|
|
|
|
|
can be a string, a vector, or a list."
|
|
|
|
|
(and obj (listp obj) (listp (cdr obj))))
|
|
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun set-nested-alist (keyseq entry alist &optional len branches)
|
|
|
|
|
"Set ENTRY for KEYSEQ in a nested alist ALIST.
|
1998-09-06 14:31:49 +00:00
|
|
|
|
Optional 4th arg LEN non-nil means the first LEN elements in KEYSEQ
|
1997-02-20 07:02:49 +00:00
|
|
|
|
is considered.
|
|
|
|
|
Optional argument BRANCHES if non-nil is branches for a keyseq
|
|
|
|
|
longer than KEYSEQ.
|
|
|
|
|
See the documentation of `nested-alist-p' for more detail."
|
|
|
|
|
(or (nested-alist-p alist)
|
1998-09-06 14:31:49 +00:00
|
|
|
|
(error "Invalid argument %s" alist))
|
1997-02-20 07:02:49 +00:00
|
|
|
|
(let ((islist (listp keyseq))
|
|
|
|
|
(len (or len (length keyseq)))
|
|
|
|
|
(i 0)
|
|
|
|
|
key-elt slot)
|
|
|
|
|
(while (< i len)
|
|
|
|
|
(if (null (nested-alist-p alist))
|
|
|
|
|
(error "Keyseq %s is too long for this nested alist" keyseq))
|
|
|
|
|
(setq key-elt (if islist (nth i keyseq) (aref keyseq i)))
|
|
|
|
|
(setq slot (assoc key-elt (cdr alist)))
|
|
|
|
|
(if (null slot)
|
|
|
|
|
(progn
|
|
|
|
|
(setq slot (cons key-elt (list t)))
|
|
|
|
|
(setcdr alist (cons slot (cdr alist)))))
|
|
|
|
|
(setq alist (cdr slot))
|
|
|
|
|
(setq i (1+ i)))
|
|
|
|
|
(setcar alist entry)
|
|
|
|
|
(if branches
|
1999-12-15 00:42:14 +00:00
|
|
|
|
(setcdr (last alist) branches))))
|
1997-02-20 07:02:49 +00:00
|
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun lookup-nested-alist (keyseq alist &optional len start nil-for-too-long)
|
|
|
|
|
"Look up key sequence KEYSEQ in nested alist ALIST. Return the definition.
|
|
|
|
|
Optional 1st argument LEN specifies the length of KEYSEQ.
|
|
|
|
|
Optional 2nd argument START specifies index of the starting key.
|
|
|
|
|
The returned value is normally a nested alist of which
|
|
|
|
|
car part is the entry for KEYSEQ.
|
|
|
|
|
If ALIST is not deep enough for KEYSEQ, return number which is
|
|
|
|
|
how many key elements at the front of KEYSEQ it takes
|
|
|
|
|
to reach a leaf in ALIST.
|
|
|
|
|
Optional 3rd argument NIL-FOR-TOO-LONG non-nil means return nil
|
|
|
|
|
even if ALIST is not deep enough."
|
|
|
|
|
(or (nested-alist-p alist)
|
2000-04-01 12:03:57 +00:00
|
|
|
|
(error "Invalid argument %s" alist))
|
1997-02-20 07:02:49 +00:00
|
|
|
|
(or len
|
|
|
|
|
(setq len (length keyseq)))
|
|
|
|
|
(let ((i (or start 0)))
|
|
|
|
|
(if (catch 'lookup-nested-alist-tag
|
|
|
|
|
(if (listp keyseq)
|
|
|
|
|
(while (< i len)
|
|
|
|
|
(if (setq alist (cdr (assoc (nth i keyseq) (cdr alist))))
|
|
|
|
|
(setq i (1+ i))
|
|
|
|
|
(throw 'lookup-nested-alist-tag t))))
|
|
|
|
|
(while (< i len)
|
|
|
|
|
(if (setq alist (cdr (assoc (aref keyseq i) (cdr alist))))
|
|
|
|
|
(setq i (1+ i))
|
|
|
|
|
(throw 'lookup-nested-alist-tag t))))
|
|
|
|
|
;; KEYSEQ is too long.
|
|
|
|
|
(if nil-for-too-long nil i)
|
|
|
|
|
alist)))
|
|
|
|
|
|
1997-06-18 12:55:11 +00:00
|
|
|
|
|
1997-02-20 07:02:49 +00:00
|
|
|
|
;; Coding system related functions.
|
|
|
|
|
|
1997-06-18 12:55:11 +00:00
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun coding-system-eol-type-mnemonic (coding-system)
|
1999-06-17 12:12:47 +00:00
|
|
|
|
"Return the string indicating end-of-line format of CODING-SYSTEM."
|
|
|
|
|
(let* ((eol-type (coding-system-eol-type coding-system))
|
|
|
|
|
(val (cond ((vectorp eol-type) eol-mnemonic-undecided)
|
|
|
|
|
((eq eol-type 0) eol-mnemonic-unix)
|
|
|
|
|
((eq eol-type 1) eol-mnemonic-dos)
|
|
|
|
|
((eq eol-type 2) eol-mnemonic-mac)
|
|
|
|
|
(t "-"))))
|
|
|
|
|
(if (stringp val)
|
|
|
|
|
val
|
|
|
|
|
(char-to-string val))))
|
1997-06-18 12:55:11 +00:00
|
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun coding-system-post-read-conversion (coding-system)
|
1997-10-21 10:47:35 +00:00
|
|
|
|
"Return the value of CODING-SYSTEM's post-read-conversion property."
|
|
|
|
|
(coding-system-get coding-system 'post-read-conversion))
|
1997-06-18 12:55:11 +00:00
|
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun coding-system-pre-write-conversion (coding-system)
|
1997-10-21 10:47:35 +00:00
|
|
|
|
"Return the value of CODING-SYSTEM's pre-write-conversion property."
|
|
|
|
|
(coding-system-get coding-system 'pre-write-conversion))
|
1997-06-18 12:55:11 +00:00
|
|
|
|
|
|
|
|
|
;;;###autoload
|
1998-05-18 01:01:00 +00:00
|
|
|
|
(defun coding-system-translation-table-for-decode (coding-system)
|
|
|
|
|
"Return the value of CODING-SYSTEM's translation-table-for-decode property."
|
1998-05-22 09:45:34 +00:00
|
|
|
|
(coding-system-get coding-system 'translation-table-for-decode))
|
1997-08-22 01:22:49 +00:00
|
|
|
|
|
|
|
|
|
;;;###autoload
|
1998-05-18 01:01:00 +00:00
|
|
|
|
(defun coding-system-translation-table-for-encode (coding-system)
|
|
|
|
|
"Return the value of CODING-SYSTEM's translation-table-for-encode property."
|
1998-05-22 09:45:34 +00:00
|
|
|
|
(coding-system-get coding-system 'translation-table-for-encode))
|
1997-06-18 12:55:11 +00:00
|
|
|
|
|
1997-06-10 00:56:20 +00:00
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun coding-system-equal (coding-system-1 coding-system-2)
|
1997-06-18 12:55:11 +00:00
|
|
|
|
"Return t if and only if CODING-SYSTEM-1 and CODING-SYSTEM-2 are identical.
|
1997-06-10 00:56:20 +00:00
|
|
|
|
Two coding systems are identical if two symbols are equal
|
|
|
|
|
or one is an alias of the other."
|
1997-06-18 12:55:11 +00:00
|
|
|
|
(or (eq coding-system-1 coding-system-2)
|
1997-10-21 10:47:35 +00:00
|
|
|
|
(and (equal (coding-system-spec coding-system-1)
|
|
|
|
|
(coding-system-spec coding-system-2))
|
|
|
|
|
(let ((eol-type-1 (coding-system-eol-type coding-system-1))
|
|
|
|
|
(eol-type-2 (coding-system-eol-type coding-system-2)))
|
|
|
|
|
(or (eq eol-type-1 eol-type-2)
|
|
|
|
|
(and (vectorp eol-type-1) (vectorp eol-type-2)))))))
|
1997-06-10 00:56:20 +00:00
|
|
|
|
|
1997-10-23 12:05:45 +00:00
|
|
|
|
;;;###autoload
|
1998-01-22 01:42:20 +00:00
|
|
|
|
(defmacro detect-coding-with-priority (from to priority-list)
|
|
|
|
|
"Detect a coding system of the text between FROM and TO with PRIORITY-LIST.
|
|
|
|
|
PRIORITY-LIST is an alist of coding categories vs the corresponding
|
|
|
|
|
coding systems ordered by priority."
|
1999-03-15 00:51:20 +00:00
|
|
|
|
`(unwind-protect
|
|
|
|
|
(let* ((prio-list ,priority-list)
|
|
|
|
|
(coding-category-list coding-category-list)
|
|
|
|
|
,@(mapcar (function (lambda (x) (list x x)))
|
|
|
|
|
coding-category-list))
|
2000-05-21 17:48:48 +00:00
|
|
|
|
(mapc (function (lambda (x) (set (car x) (cdr x))))
|
|
|
|
|
prio-list)
|
|
|
|
|
(set-coding-priority (mapcar #'car prio-list))
|
1999-03-15 00:51:20 +00:00
|
|
|
|
(detect-coding-region ,from ,to))
|
|
|
|
|
;; We must restore the internal database.
|
|
|
|
|
(set-coding-priority coding-category-list)
|
|
|
|
|
(update-coding-systems-internal)))
|
1998-01-22 01:42:20 +00:00
|
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun detect-coding-with-language-environment (from to lang-env)
|
|
|
|
|
"Detect a coding system of the text between FROM and TO with LANG-ENV.
|
1998-09-06 14:31:49 +00:00
|
|
|
|
The detection takes into account the coding system priorities for the
|
1998-01-22 01:42:20 +00:00
|
|
|
|
language environment LANG-ENV."
|
|
|
|
|
(let ((coding-priority (get-language-info lang-env 'coding-priority)))
|
|
|
|
|
(if coding-priority
|
|
|
|
|
(detect-coding-with-priority
|
|
|
|
|
from to
|
|
|
|
|
(mapcar (function (lambda (x)
|
|
|
|
|
(cons (coding-system-get x 'coding-category) x)))
|
|
|
|
|
coding-priority))
|
|
|
|
|
(detect-coding-region from to))))
|
1997-10-23 12:05:45 +00:00
|
|
|
|
|
1997-02-20 07:02:49 +00:00
|
|
|
|
|
2000-04-01 12:03:57 +00:00
|
|
|
|
(provide 'mule-util)
|
1999-12-15 00:42:14 +00:00
|
|
|
|
|
2000-04-01 12:03:57 +00:00
|
|
|
|
;;; mule-util.el ends here
|