Add some intro text in node Deletion.
[bpt/emacs.git] / lisp / international / mule-util.el
CommitLineData
4ed46869
KH
1;;; mule-util.el --- Utility functions for mulitilingual environment (mule)
2
4ed46869 3;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
fa526c4a 4;; Licensed to the Free Software Foundation.
4ed46869
KH
5
6;; Keywords: mule, multilingual
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 2, or (at your option)
13;; any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
369314dc
KH
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.
4ed46869
KH
24
25;;; Code:
26
27;;; String manipulations while paying attention to multibyte
28;;; characters.
29
30;;;###autoload
31(defun string-to-sequence (string type)
32 "Convert STRING to a sequence of TYPE which contains characters in STRING.
88d9cc1e 33TYPE should be `list' or `vector'."
f6afe80c
DL
34;;; (let ((len (length string))
35;;; (i 0)
36;;; val)
dbea6766 37 (cond ((eq type 'list)
f6afe80c
DL
38 ;; Applicable post-Emacs 20.2 and asymptotically ~10 times
39 ;; faster than the code below:
40 (append string nil))
41;;; (setq val (make-list len 0))
42;;; (let ((l val))
43;;; (while (< i len)
44;;; (setcar l (aref string i))
45;;; (setq l (cdr l) i (1+ i))))))
dbea6766 46 ((eq type 'vector)
f6afe80c
DL
47 ;; As above.
48 (vconcat string))
49;;; (setq val (make-vector len 0))
50;;; (while (< i len)
51;;; (aset val i (aref string i))
52;;; (setq i (1+ i))))
dbea6766
KH
53 (t
54 (error "Invalid type: %s" type)))
f6afe80c
DL
55;;; val)
56)
4ed46869
KH
57
58;;;###autoload
59(defsubst string-to-list (string)
60 "Return a list of characters in STRING."
61 (string-to-sequence string 'list))
62
63;;;###autoload
64(defsubst string-to-vector (string)
65 "Return a vector of characters in STRING."
66 (string-to-sequence string 'vector))
67
68;;;###autoload
69(defun store-substring (string idx obj)
70 "Embed OBJ (string or character) at index IDX of STRING."
dbea6766
KH
71 (if (integerp obj)
72 (aset string idx obj)
73 (let ((len1 (length obj))
74 (len2 (length string))
75 (i 0))
76 (while (< i len1)
77 (aset string (+ idx i) (aref obj i))
78 (setq i (1+ i)))))
79 string)
4ed46869
KH
80
81;;;###autoload
be9778f8
RS
82(defun truncate-string-to-width (str end-column &optional start-column padding)
83 "Truncate string STR to end at column END-COLUMN.
9ac06837 84The optional 3rd arg START-COLUMN, if non-nil, specifies
be9778f8
RS
85the starting column; that means to return the characters occupying
86columns START-COLUMN ... END-COLUMN of STR.
87
9ac06837 88The optional 4th arg PADDING, if non-nil, specifies a padding character
be9778f8
RS
89to add at the end of the result if STR doesn't reach column END-COLUMN,
90or if END-COLUMN comes in the middle of a character in STR.
91PADDING is also added at the beginning of the result
e6f8e6f4 92if column START-COLUMN appears in the middle of a character in STR.
be9778f8
RS
93
94If PADDING is nil, no padding is added in these cases, so
95the resulting string may be narrower than END-COLUMN."
4ed46869
KH
96 (or start-column
97 (setq start-column 0))
98 (let ((len (length str))
99 (idx 0)
100 (column 0)
101 (head-padding "") (tail-padding "")
102 ch last-column last-idx from-idx)
103 (condition-case nil
104 (while (< column start-column)
dbea6766 105 (setq ch (aref str idx)
4ed46869 106 column (+ column (char-width ch))
dbea6766 107 idx (1+ idx)))
4ed46869
KH
108 (args-out-of-range (setq idx len)))
109 (if (< column start-column)
be9778f8 110 (if padding (make-string end-column padding) "")
4ed46869 111 (if (and padding (> column start-column))
dbea6766 112 (setq head-padding (make-string (- column start-column) padding)))
4ed46869 113 (setq from-idx idx)
be9778f8
RS
114 (if (< end-column column)
115 (setq idx from-idx)
116 (condition-case nil
117 (while (< column end-column)
118 (setq last-column column
119 last-idx idx
dbea6766 120 ch (aref str idx)
be9778f8 121 column (+ column (char-width ch))
dbea6766 122 idx (1+ idx)))
be9778f8
RS
123 (args-out-of-range (setq idx len)))
124 (if (> column end-column)
125 (setq column last-column idx last-idx))
126 (if (and padding (< column end-column))
127 (setq tail-padding (make-string (- end-column column) padding))))
4ed46869
KH
128 (setq str (substring str from-idx idx))
129 (if padding
130 (concat head-padding str tail-padding)
131 str))))
132
e8dd0160 133;;; For backward compatibility ...
4ed46869
KH
134;;;###autoload
135(defalias 'truncate-string 'truncate-string-to-width)
2598a293 136(make-obsolete 'truncate-string 'truncate-string-to-width "20.1")
4ed46869
KH
137\f
138;;; Nested alist handler. Nested alist is alist whose elements are
139;;; also nested alist.
140
141;;;###autoload
142(defsubst nested-alist-p (obj)
e8dd0160 143 "Return t if OBJ is a nested alist.
4ed46869
KH
144
145Nested alist is a list of the form (ENTRY . BRANCHES), where ENTRY is
146any Lisp object, and BRANCHES is a list of cons cells of the form
147(KEY-ELEMENT . NESTED-ALIST).
148
149You can use a nested alist to store any Lisp object (ENTRY) for a key
150sequence KEYSEQ, where KEYSEQ is a sequence of KEY-ELEMENT. KEYSEQ
151can be a string, a vector, or a list."
152 (and obj (listp obj) (listp (cdr obj))))
153
154;;;###autoload
155(defun set-nested-alist (keyseq entry alist &optional len branches)
156 "Set ENTRY for KEYSEQ in a nested alist ALIST.
e8dd0160 157Optional 4th arg LEN non-nil means the first LEN elements in KEYSEQ
4ed46869
KH
158 is considered.
159Optional argument BRANCHES if non-nil is branches for a keyseq
160longer than KEYSEQ.
161See the documentation of `nested-alist-p' for more detail."
162 (or (nested-alist-p alist)
e8dd0160 163 (error "Invalid argument %s" alist))
4ed46869
KH
164 (let ((islist (listp keyseq))
165 (len (or len (length keyseq)))
166 (i 0)
167 key-elt slot)
168 (while (< i len)
169 (if (null (nested-alist-p alist))
170 (error "Keyseq %s is too long for this nested alist" keyseq))
171 (setq key-elt (if islist (nth i keyseq) (aref keyseq i)))
172 (setq slot (assoc key-elt (cdr alist)))
173 (if (null slot)
174 (progn
175 (setq slot (cons key-elt (list t)))
176 (setcdr alist (cons slot (cdr alist)))))
177 (setq alist (cdr slot))
178 (setq i (1+ i)))
179 (setcar alist entry)
180 (if branches
72594565 181 (setcdr (last alist) branches))))
4ed46869
KH
182
183;;;###autoload
184(defun lookup-nested-alist (keyseq alist &optional len start nil-for-too-long)
185 "Look up key sequence KEYSEQ in nested alist ALIST. Return the definition.
186Optional 1st argument LEN specifies the length of KEYSEQ.
187Optional 2nd argument START specifies index of the starting key.
188The returned value is normally a nested alist of which
189car part is the entry for KEYSEQ.
190If ALIST is not deep enough for KEYSEQ, return number which is
191 how many key elements at the front of KEYSEQ it takes
192 to reach a leaf in ALIST.
193Optional 3rd argument NIL-FOR-TOO-LONG non-nil means return nil
194 even if ALIST is not deep enough."
195 (or (nested-alist-p alist)
f6afe80c 196 (error "Invalid argument %s" alist))
4ed46869
KH
197 (or len
198 (setq len (length keyseq)))
199 (let ((i (or start 0)))
200 (if (catch 'lookup-nested-alist-tag
201 (if (listp keyseq)
202 (while (< i len)
203 (if (setq alist (cdr (assoc (nth i keyseq) (cdr alist))))
204 (setq i (1+ i))
205 (throw 'lookup-nested-alist-tag t))))
206 (while (< i len)
207 (if (setq alist (cdr (assoc (aref keyseq i) (cdr alist))))
208 (setq i (1+ i))
209 (throw 'lookup-nested-alist-tag t))))
210 ;; KEYSEQ is too long.
211 (if nil-for-too-long nil i)
212 alist)))
213
be1d31dc 214\f
4ed46869
KH
215;; Coding system related functions.
216
be1d31dc
KH
217;;;###autoload
218(defun coding-system-eol-type-mnemonic (coding-system)
935f6bf5
KH
219 "Return the string indicating end-of-line format of CODING-SYSTEM."
220 (let* ((eol-type (coding-system-eol-type coding-system))
221 (val (cond ((vectorp eol-type) eol-mnemonic-undecided)
222 ((eq eol-type 0) eol-mnemonic-unix)
223 ((eq eol-type 1) eol-mnemonic-dos)
224 ((eq eol-type 2) eol-mnemonic-mac)
225 (t "-"))))
226 (if (stringp val)
227 val
228 (char-to-string val))))
be1d31dc
KH
229
230;;;###autoload
231(defun coding-system-post-read-conversion (coding-system)
f1fd88c6
KH
232 "Return the value of CODING-SYSTEM's post-read-conversion property."
233 (coding-system-get coding-system 'post-read-conversion))
be1d31dc
KH
234
235;;;###autoload
236(defun coding-system-pre-write-conversion (coding-system)
f1fd88c6
KH
237 "Return the value of CODING-SYSTEM's pre-write-conversion property."
238 (coding-system-get coding-system 'pre-write-conversion))
be1d31dc
KH
239
240;;;###autoload
d2a1ee18
KH
241(defun coding-system-translation-table-for-decode (coding-system)
242 "Return the value of CODING-SYSTEM's translation-table-for-decode property."
f967223b 243 (coding-system-get coding-system 'translation-table-for-decode))
34761746
KH
244
245;;;###autoload
d2a1ee18
KH
246(defun coding-system-translation-table-for-encode (coding-system)
247 "Return the value of CODING-SYSTEM's translation-table-for-encode property."
f967223b 248 (coding-system-get coding-system 'translation-table-for-encode))
be1d31dc 249
88d9cc1e
KH
250;;;###autoload
251(defun coding-system-equal (coding-system-1 coding-system-2)
be1d31dc 252 "Return t if and only if CODING-SYSTEM-1 and CODING-SYSTEM-2 are identical.
88d9cc1e
KH
253Two coding systems are identical if two symbols are equal
254or one is an alias of the other."
be1d31dc 255 (or (eq coding-system-1 coding-system-2)
f1fd88c6
KH
256 (and (equal (coding-system-spec coding-system-1)
257 (coding-system-spec coding-system-2))
258 (let ((eol-type-1 (coding-system-eol-type coding-system-1))
259 (eol-type-2 (coding-system-eol-type coding-system-2)))
260 (or (eq eol-type-1 eol-type-2)
261 (and (vectorp eol-type-1) (vectorp eol-type-2)))))))
88d9cc1e 262
e481690d 263;;;###autoload
dbea6766
KH
264(defmacro detect-coding-with-priority (from to priority-list)
265 "Detect a coding system of the text between FROM and TO with PRIORITY-LIST.
266PRIORITY-LIST is an alist of coding categories vs the corresponding
267coding systems ordered by priority."
e74d7926
KH
268 `(unwind-protect
269 (let* ((prio-list ,priority-list)
270 (coding-category-list coding-category-list)
271 ,@(mapcar (function (lambda (x) (list x x)))
272 coding-category-list))
cb7216a7
DL
273 (mapc (function (lambda (x) (set (car x) (cdr x))))
274 prio-list)
275 (set-coding-priority (mapcar #'car prio-list))
e74d7926
KH
276 (detect-coding-region ,from ,to))
277 ;; We must restore the internal database.
278 (set-coding-priority coding-category-list)
279 (update-coding-systems-internal)))
dbea6766
KH
280
281;;;###autoload
282(defun detect-coding-with-language-environment (from to lang-env)
283 "Detect a coding system of the text between FROM and TO with LANG-ENV.
e8dd0160 284The detection takes into account the coding system priorities for the
dbea6766
KH
285language environment LANG-ENV."
286 (let ((coding-priority (get-language-info lang-env 'coding-priority)))
287 (if coding-priority
288 (detect-coding-with-priority
289 from to
290 (mapcar (function (lambda (x)
291 (cons (coding-system-get x 'coding-category) x)))
292 coding-priority))
293 (detect-coding-region from to))))
e481690d 294
4ed46869 295\f
f6afe80c 296(provide 'mule-util)
72594565 297
f6afe80c 298;;; mule-util.el ends here