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