Commit | Line | Data |
---|---|---|
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 | 35 | TYPE 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 | 86 | The optional 3rd arg START-COLUMN, if non-nil, specifies |
be9778f8 RS |
87 | the starting column; that means to return the characters occupying |
88 | columns START-COLUMN ... END-COLUMN of STR. | |
89 | ||
9ac06837 | 90 | The optional 4th arg PADDING, if non-nil, specifies a padding character |
be9778f8 RS |
91 | to add at the end of the result if STR doesn't reach column END-COLUMN, |
92 | or if END-COLUMN comes in the middle of a character in STR. | |
93 | PADDING is also added at the beginning of the result | |
e6f8e6f4 | 94 | if column START-COLUMN appears in the middle of a character in STR. |
be9778f8 RS |
95 | |
96 | If PADDING is nil, no padding is added in these cases, so | |
97 | the 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 | |
147 | Nested alist is a list of the form (ENTRY . BRANCHES), where ENTRY is | |
148 | any Lisp object, and BRANCHES is a list of cons cells of the form | |
149 | (KEY-ELEMENT . NESTED-ALIST). | |
150 | ||
151 | You can use a nested alist to store any Lisp object (ENTRY) for a key | |
152 | sequence KEYSEQ, where KEYSEQ is a sequence of KEY-ELEMENT. KEYSEQ | |
153 | can 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 | 159 | Optional 4th arg LEN non-nil means the first LEN elements in KEYSEQ |
4ed46869 KH |
160 | is considered. |
161 | Optional argument BRANCHES if non-nil is branches for a keyseq | |
162 | longer than KEYSEQ. | |
163 | See 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. | |
188 | Optional 1st argument LEN specifies the length of KEYSEQ. | |
189 | Optional 2nd argument START specifies index of the starting key. | |
190 | The returned value is normally a nested alist of which | |
191 | car part is the entry for KEYSEQ. | |
192 | If 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. | |
195 | Optional 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 |
255 | Two coding systems are identical if two symbols are equal |
256 | or 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. | |
268 | PRIORITY-LIST is an alist of coding categories vs the corresponding | |
269 | coding 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 | 286 | The detection takes into account the coding system priorities for the |
dbea6766 KH |
287 | language 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 |