Commit | Line | Data |
---|---|---|
78edd3b7 | 1 | ;;; mule-util.el --- utility functions for multilingual environment (mule) |
4ed46869 | 2 | |
acaf905b | 3 | ;; Copyright (C) 1997-1998, 2000-2012 Free Software Foundation, Inc. |
7976eda0 | 4 | ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, |
5df4f04c | 5 | ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 |
2fd125a3 KH |
6 | ;; National Institute of Advanced Industrial Science and Technology (AIST) |
7 | ;; Registration Number H14PRO021 | |
8f924df7 KH |
8 | ;; Copyright (C) 2003 |
9 | ;; National Institute of Advanced Industrial Science and Technology (AIST) | |
10 | ;; Registration Number H13PRO009 | |
11 | ||
4ed46869 KH |
12 | ;; Keywords: mule, multilingual |
13 | ||
14 | ;; This file is part of GNU Emacs. | |
15 | ||
4936186e | 16 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
4ed46869 | 17 | ;; it under the terms of the GNU General Public License as published by |
4936186e GM |
18 | ;; the Free Software Foundation, either version 3 of the License, or |
19 | ;; (at your option) any later version. | |
4ed46869 KH |
20 | |
21 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
22 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
23 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
24 | ;; GNU General Public License for more details. | |
25 | ||
26 | ;; You should have received a copy of the GNU General Public License | |
4936186e | 27 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
4ed46869 | 28 | |
60370d40 PJ |
29 | ;;; Commentary: |
30 | ||
4ed46869 KH |
31 | ;;; Code: |
32 | ||
33 | ;;; String manipulations while paying attention to multibyte | |
34 | ;;; characters. | |
35 | ||
4ed46869 KH |
36 | ;;;###autoload |
37 | (defsubst string-to-list (string) | |
38 | "Return a list of characters in STRING." | |
48e3f3d7 | 39 | (append string nil)) |
4ed46869 KH |
40 | |
41 | ;;;###autoload | |
42 | (defsubst string-to-vector (string) | |
43 | "Return a vector of characters in STRING." | |
48e3f3d7 | 44 | (vconcat string)) |
4ed46869 KH |
45 | |
46 | ;;;###autoload | |
47 | (defun store-substring (string idx obj) | |
48 | "Embed OBJ (string or character) at index IDX of STRING." | |
dbea6766 KH |
49 | (if (integerp obj) |
50 | (aset string idx obj) | |
51 | (let ((len1 (length obj)) | |
52 | (len2 (length string)) | |
53 | (i 0)) | |
54 | (while (< i len1) | |
55 | (aset string (+ idx i) (aref obj i)) | |
56 | (setq i (1+ i))))) | |
57 | string) | |
4ed46869 KH |
58 | |
59 | ;;;###autoload | |
171a7d5d CW |
60 | (defun truncate-string-to-width (str end-column |
61 | &optional start-column padding ellipsis) | |
be9778f8 | 62 | "Truncate string STR to end at column END-COLUMN. |
171a7d5d CW |
63 | The optional 3rd arg START-COLUMN, if non-nil, specifies the starting |
64 | column; that means to return the characters occupying columns | |
65 | START-COLUMN ... END-COLUMN of STR. Both END-COLUMN and START-COLUMN | |
66 | are specified in terms of character display width in the current | |
67 | buffer; see also `char-width'. | |
68 | ||
69 | The optional 4th arg PADDING, if non-nil, specifies a padding | |
70 | character (which should have a display width of 1) to add at the end | |
71 | of the result if STR doesn't reach column END-COLUMN, or if END-COLUMN | |
72 | comes in the middle of a character in STR. PADDING is also added at | |
73 | the beginning of the result if column START-COLUMN appears in the | |
74 | middle of a character in STR. | |
be9778f8 RS |
75 | |
76 | If PADDING is nil, no padding is added in these cases, so | |
171a7d5d CW |
77 | the resulting string may be narrower than END-COLUMN. |
78 | ||
79 | If ELLIPSIS is non-nil, it should be a string which will replace the | |
80 | end of STR (including any padding) if it extends beyond END-COLUMN, | |
81 | unless the display width of STR is equal to or less than the display | |
82 | width of ELLIPSIS. If it is non-nil and not a string, then ELLIPSIS | |
83 | defaults to \"...\"." | |
4ed46869 KH |
84 | (or start-column |
85 | (setq start-column 0)) | |
171a7d5d CW |
86 | (when (and ellipsis (not (stringp ellipsis))) |
87 | (setq ellipsis "...")) | |
88 | (let ((str-len (length str)) | |
89 | (str-width (string-width str)) | |
90 | (ellipsis-len (if ellipsis (length ellipsis) 0)) | |
91 | (ellipsis-width (if ellipsis (string-width ellipsis) 0)) | |
4ed46869 KH |
92 | (idx 0) |
93 | (column 0) | |
94 | (head-padding "") (tail-padding "") | |
95 | ch last-column last-idx from-idx) | |
96 | (condition-case nil | |
97 | (while (< column start-column) | |
dbea6766 | 98 | (setq ch (aref str idx) |
4ed46869 | 99 | column (+ column (char-width ch)) |
dbea6766 | 100 | idx (1+ idx))) |
171a7d5d | 101 | (args-out-of-range (setq idx str-len))) |
4ed46869 | 102 | (if (< column start-column) |
be9778f8 | 103 | (if padding (make-string end-column padding) "") |
171a7d5d CW |
104 | (when (and padding (> column start-column)) |
105 | (setq head-padding (make-string (- column start-column) padding))) | |
4ed46869 | 106 | (setq from-idx idx) |
171a7d5d CW |
107 | (when (>= end-column column) |
108 | (if (and (< end-column str-width) | |
109 | (> str-width ellipsis-width)) | |
110 | (setq end-column (- end-column ellipsis-width)) | |
111 | (setq ellipsis "")) | |
be9778f8 RS |
112 | (condition-case nil |
113 | (while (< column end-column) | |
114 | (setq last-column column | |
115 | last-idx idx | |
dbea6766 | 116 | ch (aref str idx) |
be9778f8 | 117 | column (+ column (char-width ch)) |
dbea6766 | 118 | idx (1+ idx))) |
171a7d5d CW |
119 | (args-out-of-range (setq idx str-len))) |
120 | (when (> column end-column) | |
121 | (setq column last-column | |
122 | idx last-idx)) | |
123 | (when (and padding (< column end-column)) | |
124 | (setq tail-padding (make-string (- end-column column) padding)))) | |
125 | (concat head-padding (substring str from-idx idx) | |
126 | tail-padding ellipsis)))) | |
127 | ||
128 | ;;; Test suite for truncate-string-to-width | |
129 | ;; (dolist (test '((("" 0) . "") | |
130 | ;; (("x" 1) . "x") | |
131 | ;; (("xy" 1) . "x") | |
132 | ;; (("xy" 2 1) . "y") | |
133 | ;; (("xy" 0) . "") | |
134 | ;; (("xy" 3) . "xy") | |
135 | ;; (("\e$AVP\e(B" 0) . "") | |
136 | ;; (("\e$AVP\e(B" 1) . "") | |
137 | ;; (("\e$AVP\e(B" 2) . "\e$AVP\e(B") | |
138 | ;; (("\e$AVP\e(B" 1 nil ? ) . " ") | |
139 | ;; (("\e$AVPND\e(B" 3 1 ? ) . " ") | |
140 | ;; (("x\e$AVP\e(Bx" 2) . "x") | |
141 | ;; (("x\e$AVP\e(Bx" 3) . "x\e$AVP\e(B") | |
142 | ;; (("x\e$AVP\e(Bx" 3) . "x\e$AVP\e(B") | |
143 | ;; (("x\e$AVP\e(Bx" 4 1) . "\e$AVP\e(Bx") | |
144 | ;; (("kor\e$(CGQ\e(Be\e$(C1[\e(Ban" 8 1 ? ) . "or\e$(CGQ\e(Be\e$(C1[\e(B") | |
145 | ;; (("kor\e$(CGQ\e(Be\e$(C1[\e(Ban" 7 2 ? ) . "r\e$(CGQ\e(Be ") | |
146 | ;; (("" 0 nil nil "...") . "") | |
147 | ;; (("x" 3 nil nil "...") . "x") | |
148 | ;; (("\e$AVP\e(B" 3 nil nil "...") . "\e$AVP\e(B") | |
149 | ;; (("foo" 3 nil nil "...") . "foo") | |
150 | ;; (("foo" 2 nil nil "...") . "fo") ;; XEmacs failure? | |
151 | ;; (("foobar" 6 0 nil "...") . "foobar") | |
152 | ;; (("foobarbaz" 6 nil nil "...") . "foo...") | |
153 | ;; (("foobarbaz" 7 2 nil "...") . "ob...") | |
154 | ;; (("foobarbaz" 9 3 nil "...") . "barbaz") | |
6b61353c KH |
155 | ;; (("\e$A$3\e(Bh\e$A$s\e(Be\e$A$K\e(Bl\e$A$A\e(Bl\e$A$O\e(Bo" 15 1 ? t) . " h\e$A$s\e(Be\e$A$K\e(Bl\e$A$A\e(Bl\e$A$O\e(Bo") |
156 | ;; (("\e$A$3\e(Bh\e$A$s\e(Be\e$A$K\e(Bl\e$A$A\e(Bl\e$A$O\e(Bo" 14 1 ? t) . " h\e$A$s\e(Be\e$A$K\e(Bl\e$A$A\e(B...") | |
157 | ;; (("x" 3 nil nil "\e$(Gemk#\e(B") . "x") | |
158 | ;; (("\e$AVP\e(B" 2 nil nil "\e$(Gemk#\e(B") . "\e$AVP\e(B") | |
159 | ;; (("\e$AVP\e(B" 1 nil ?x "\e$(Gemk#\e(B") . "x") ;; XEmacs error | |
160 | ;; (("\e$AVPND\e(B" 3 nil ? "\e$(Gemk#\e(B") . "\e$AVP\e(B ") ;; XEmacs error | |
161 | ;; (("foobarbaz" 4 nil nil "\e$(Gemk#\e(B") . "\e$(Gemk#\e(B") | |
162 | ;; (("foobarbaz" 5 nil nil "\e$(Gemk#\e(B") . "f\e$(Gemk#\e(B") | |
163 | ;; (("foobarbaz" 6 nil nil "\e$(Gemk#\e(B") . "fo\e$(Gemk#\e(B") | |
164 | ;; (("foobarbaz" 8 3 nil "\e$(Gemk#\e(B") . "b\e$(Gemk#\e(B") | |
165 | ;; (("\e$A$3\e(Bh\e$A$s\e(Be\e$A$K\e(Bl\e$A$A\e(Bl\e$A$O\e(Bo" 14 4 ?x "\e$AHU1>\e$(Gk#\e(B") . "xe\e$A$KHU1>\e$(Gk#\e(B") | |
166 | ;; (("\e$A$3\e(Bh\e$A$s\e(Be\e$A$K\e(Bl\e$A$A\e(Bl\e$A$O\e(Bo" 13 4 ?x "\e$AHU1>\e$(Gk#\e(B") . "xex\e$AHU1>\e$(Gk#\e(B") | |
171a7d5d CW |
167 | ;; )) |
168 | ;; (let (ret) | |
2fb49346 | 169 | ;; (condition-case e |
171a7d5d CW |
170 | ;; (setq ret (apply #'truncate-string-to-width (car test))) |
171 | ;; (error (setq ret e))) | |
172 | ;; (unless (equal ret (cdr test)) | |
173 | ;; (error "%s: expected %s, got %s" | |
174 | ;; (prin1-to-string (cons 'truncate-string-to-width (car test))) | |
175 | ;; (prin1-to-string (cdr test)) | |
176 | ;; (if (consp ret) | |
177 | ;; (format "error: %s: %s" (car ret) | |
178 | ;; (prin1-to-string (cdr ret))) | |
179 | ;; (prin1-to-string ret)))))) | |
4ed46869 | 180 | |
4ed46869 KH |
181 | \f |
182 | ;;; Nested alist handler. Nested alist is alist whose elements are | |
183 | ;;; also nested alist. | |
184 | ||
185 | ;;;###autoload | |
186 | (defsubst nested-alist-p (obj) | |
e8dd0160 | 187 | "Return t if OBJ is a nested alist. |
4ed46869 KH |
188 | |
189 | Nested alist is a list of the form (ENTRY . BRANCHES), where ENTRY is | |
190 | any Lisp object, and BRANCHES is a list of cons cells of the form | |
4a30e92e | 191 | \(KEY-ELEMENT . NESTED-ALIST). |
4ed46869 KH |
192 | |
193 | You can use a nested alist to store any Lisp object (ENTRY) for a key | |
194 | sequence KEYSEQ, where KEYSEQ is a sequence of KEY-ELEMENT. KEYSEQ | |
195 | can be a string, a vector, or a list." | |
196 | (and obj (listp obj) (listp (cdr obj)))) | |
197 | ||
198 | ;;;###autoload | |
199 | (defun set-nested-alist (keyseq entry alist &optional len branches) | |
200 | "Set ENTRY for KEYSEQ in a nested alist ALIST. | |
e8dd0160 | 201 | Optional 4th arg LEN non-nil means the first LEN elements in KEYSEQ |
11eac3ea JB |
202 | are considered. |
203 | Optional 5th argument BRANCHES if non-nil is branches for a keyseq | |
4ed46869 KH |
204 | longer than KEYSEQ. |
205 | See the documentation of `nested-alist-p' for more detail." | |
206 | (or (nested-alist-p alist) | |
e8dd0160 | 207 | (error "Invalid argument %s" alist)) |
4ed46869 KH |
208 | (let ((islist (listp keyseq)) |
209 | (len (or len (length keyseq))) | |
210 | (i 0) | |
211 | key-elt slot) | |
212 | (while (< i len) | |
213 | (if (null (nested-alist-p alist)) | |
214 | (error "Keyseq %s is too long for this nested alist" keyseq)) | |
215 | (setq key-elt (if islist (nth i keyseq) (aref keyseq i))) | |
216 | (setq slot (assoc key-elt (cdr alist))) | |
11eac3ea JB |
217 | (unless slot |
218 | (setq slot (cons key-elt (list t))) | |
219 | (setcdr alist (cons slot (cdr alist)))) | |
4ed46869 KH |
220 | (setq alist (cdr slot)) |
221 | (setq i (1+ i))) | |
222 | (setcar alist entry) | |
223 | (if branches | |
72594565 | 224 | (setcdr (last alist) branches)))) |
4ed46869 KH |
225 | |
226 | ;;;###autoload | |
227 | (defun lookup-nested-alist (keyseq alist &optional len start nil-for-too-long) | |
228 | "Look up key sequence KEYSEQ in nested alist ALIST. Return the definition. | |
11eac3ea JB |
229 | Optional 3rd argument LEN specifies the length of KEYSEQ. |
230 | Optional 4th argument START specifies index of the starting key. | |
4ed46869 KH |
231 | The returned value is normally a nested alist of which |
232 | car part is the entry for KEYSEQ. | |
233 | If ALIST is not deep enough for KEYSEQ, return number which is | |
234 | how many key elements at the front of KEYSEQ it takes | |
235 | to reach a leaf in ALIST. | |
11eac3ea | 236 | Optional 5th argument NIL-FOR-TOO-LONG non-nil means return nil |
4ed46869 KH |
237 | even if ALIST is not deep enough." |
238 | (or (nested-alist-p alist) | |
f6afe80c | 239 | (error "Invalid argument %s" alist)) |
4ed46869 KH |
240 | (or len |
241 | (setq len (length keyseq))) | |
242 | (let ((i (or start 0))) | |
243 | (if (catch 'lookup-nested-alist-tag | |
244 | (if (listp keyseq) | |
245 | (while (< i len) | |
246 | (if (setq alist (cdr (assoc (nth i keyseq) (cdr alist)))) | |
247 | (setq i (1+ i)) | |
248 | (throw 'lookup-nested-alist-tag t)))) | |
249 | (while (< i len) | |
250 | (if (setq alist (cdr (assoc (aref keyseq i) (cdr alist)))) | |
251 | (setq i (1+ i)) | |
252 | (throw 'lookup-nested-alist-tag t)))) | |
253 | ;; KEYSEQ is too long. | |
254 | (if nil-for-too-long nil i) | |
255 | alist))) | |
256 | ||
be1d31dc | 257 | \f |
4ed46869 KH |
258 | ;; Coding system related functions. |
259 | ||
be1d31dc KH |
260 | ;;;###autoload |
261 | (defun coding-system-post-read-conversion (coding-system) | |
bc9254e2 | 262 | "Return the value of CODING-SYSTEM's `post-read-conversion' property." |
2b7d6c1a | 263 | (coding-system-get coding-system :post-read-conversion)) |
be1d31dc KH |
264 | |
265 | ;;;###autoload | |
266 | (defun coding-system-pre-write-conversion (coding-system) | |
bc9254e2 | 267 | "Return the value of CODING-SYSTEM's `pre-write-conversion' property." |
2b7d6c1a | 268 | (coding-system-get coding-system :pre-write-conversion)) |
be1d31dc KH |
269 | |
270 | ;;;###autoload | |
d2a1ee18 | 271 | (defun coding-system-translation-table-for-decode (coding-system) |
8f924df7 | 272 | "Return the value of CODING-SYSTEM's `decode-translation-table' property." |
2b7d6c1a | 273 | (coding-system-get coding-system :decode-translation-table)) |
34761746 KH |
274 | |
275 | ;;;###autoload | |
d2a1ee18 | 276 | (defun coding-system-translation-table-for-encode (coding-system) |
8f924df7 | 277 | "Return the value of CODING-SYSTEM's `encode-translation-table' property." |
2b7d6c1a | 278 | (coding-system-get coding-system :encode-translation-table)) |
be1d31dc | 279 | |
8f924df7 KH |
280 | ;;;###autoload |
281 | (defmacro with-coding-priority (coding-systems &rest body) | |
282 | "Execute BODY like `progn' with CODING-SYSTEMS at the front of priority list. | |
d93c111e | 283 | CODING-SYSTEMS is a list of coding systems. See `set-coding-system-priority'. |
333f9019 | 284 | This affects the implicit sorting of lists of coding systems returned by |
11eac3ea | 285 | operations such as `find-coding-systems-region'." |
8f924df7 KH |
286 | (let ((current (make-symbol "current"))) |
287 | `(let ((,current (coding-system-priority-list))) | |
288 | (apply #'set-coding-system-priority ,coding-systems) | |
289 | (unwind-protect | |
290 | (progn ,@body) | |
291 | (apply #'set-coding-system-priority ,current))))) | |
7fad1447 | 292 | ;;;###autoload(put 'with-coding-priority 'lisp-indent-function 1) |
8f924df7 KH |
293 | (put 'with-coding-priority 'edebug-form-spec t) |
294 | ||
e481690d | 295 | ;;;###autoload |
dbea6766 KH |
296 | (defmacro detect-coding-with-priority (from to priority-list) |
297 | "Detect a coding system of the text between FROM and TO with PRIORITY-LIST. | |
298 | PRIORITY-LIST is an alist of coding categories vs the corresponding | |
299 | coding systems ordered by priority." | |
59f7af81 | 300 | (declare (obsolete with-coding-priority "23.1")) |
3aad8045 | 301 | `(with-coding-priority (mapcar #'cdr ,priority-list) |
2f97406e | 302 | (detect-coding-region ,from ,to))) |
dbea6766 KH |
303 | |
304 | ;;;###autoload | |
305 | (defun detect-coding-with-language-environment (from to lang-env) | |
a40f1cb4 | 306 | "Detect a coding system for the text between FROM and TO with LANG-ENV. |
e8dd0160 | 307 | The detection takes into account the coding system priorities for the |
dbea6766 KH |
308 | language environment LANG-ENV." |
309 | (let ((coding-priority (get-language-info lang-env 'coding-priority))) | |
310 | (if coding-priority | |
2b7d6c1a DL |
311 | (with-coding-priority coding-priority |
312 | (detect-coding-region from to))))) | |
e481690d | 313 | |
aa360da1 GM |
314 | (declare-function internal-char-font "fontset.c" (position &optional ch)) |
315 | ||
6b61353c KH |
316 | ;;;###autoload |
317 | (defun char-displayable-p (char) | |
318 | "Return non-nil if we should be able to display CHAR. | |
319 | On a multi-font display, the test is only whether there is an | |
11eac3ea JB |
320 | appropriate font from the selected frame's fontset to display |
321 | CHAR's charset in general. Since fonts may be specified on a | |
322 | per-character basis, this may not be accurate." | |
ed98afe1 KH |
323 | (cond ((< char 128) |
324 | ;; ASCII characters are always displayable. | |
6b61353c | 325 | t) |
e7a4820c SM |
326 | ((not enable-multibyte-characters) |
327 | ;; Maybe there's a font for it, but we can't put it in the buffer. | |
328 | nil) | |
6b61353c KH |
329 | ((display-multi-font-p) |
330 | ;; On a window system, a character is displayable if we have | |
331 | ;; a font for that character in the default face of the | |
332 | ;; currently selected frame. | |
44416f23 | 333 | (car (internal-char-font nil char))) |
6b61353c | 334 | (t |
ed98afe1 KH |
335 | ;; On a terminal, a character is displayable if the coding |
336 | ;; system for the terminal can encode it. | |
337 | (let ((coding (terminal-coding-system))) | |
11eac3ea JB |
338 | (when coding |
339 | (let ((cs-list (coding-system-get coding :charset-list))) | |
340 | (cond | |
341 | ((listp cs-list) | |
342 | (catch 'tag | |
343 | (mapc #'(lambda (charset) | |
344 | (if (encode-char char charset) | |
345 | (throw 'tag charset))) | |
346 | cs-list) | |
347 | nil)) | |
348 | ((eq cs-list 'iso-2022) | |
349 | (catch 'tag2 | |
350 | (mapc #'(lambda (charset) | |
351 | (if (and (plist-get (charset-plist charset) | |
352 | :iso-final-char) | |
353 | (encode-char char charset)) | |
354 | (throw 'tag2 charset))) | |
355 | charset-list) | |
356 | nil)) | |
357 | ((eq cs-list 'emacs-mule) | |
358 | (catch 'tag3 | |
359 | (mapc #'(lambda (charset) | |
360 | (if (and (plist-get (charset-plist charset) | |
361 | :emacs-mule-id) | |
362 | (encode-char char charset)) | |
363 | (throw 'tag3 charset))) | |
364 | charset-list) | |
365 | nil))))))))) | |
4ed46869 | 366 | \f |
f6afe80c | 367 | (provide 'mule-util) |
72594565 | 368 | |
171a7d5d CW |
369 | ;; Local Variables: |
370 | ;; coding: iso-2022-7bit | |
371 | ;; End: | |
372 | ||
f6afe80c | 373 | ;;; mule-util.el ends here |