1 ;;; mule-util.el --- utility functions for multilingual environment (mule) -*- lexical-binding:t -*-
3 ;; Copyright (C) 1997-1998, 2000-2019 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
5 ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
6 ;; National Institute of Advanced Industrial Science and Technology (AIST)
7 ;; Registration Number H14PRO021
9 ;; National Institute of Advanced Industrial Science and Technology (AIST)
10 ;; Registration Number H13PRO009
12 ;; Keywords: mule, multilingual
14 ;; This file is part of GNU Emacs.
16 ;; GNU Emacs is free software: you can redistribute it and/or modify
17 ;; it under the terms of the GNU General Public License as published by
18 ;; the Free Software Foundation, either version 3 of the License, or
19 ;; (at your option) any later version.
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.
26 ;; You should have received a copy of the GNU General Public License
27 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
33 ;;; String manipulations while paying attention to multibyte characters.
36 (defun store-substring (string idx obj
)
37 "Embed OBJ (string or character) at index IDX of STRING."
40 (let ((len1 (length obj
))
43 (aset string
(+ idx i
) (aref obj i
))
47 (defvar truncate-string-ellipsis
"..." ;"…"
48 "String to use to indicate truncation.
49 Serves as default value of ELLIPSIS argument to `truncate-string-to-width'.")
52 (defun truncate-string-to-width (str end-column
53 &optional start-column padding ellipsis
)
54 "Truncate string STR to end at column END-COLUMN.
55 The optional 3rd arg START-COLUMN, if non-nil, specifies the starting
56 column; that means to return the characters occupying columns
57 START-COLUMN ... END-COLUMN of STR. Both END-COLUMN and START-COLUMN
58 are specified in terms of character display width in the current
59 buffer; see also `char-width'.
61 The optional 4th arg PADDING, if non-nil, specifies a padding
62 character (which should have a display width of 1) to add at the end
63 of the result if STR doesn't reach column END-COLUMN, or if END-COLUMN
64 comes in the middle of a character in STR. PADDING is also added at
65 the beginning of the result if column START-COLUMN appears in the
66 middle of a character in STR.
68 If PADDING is nil, no padding is added in these cases, so
69 the resulting string may be narrower than END-COLUMN.
71 If ELLIPSIS is non-nil, it should be a string which will replace the
72 end of STR (including any padding) if it extends beyond END-COLUMN,
73 unless the display width of STR is equal to or less than the display
74 width of ELLIPSIS. If it is non-nil and not a string, then ELLIPSIS
75 defaults to `truncate-string-ellipsis'."
77 (setq start-column
0))
78 (when (and ellipsis
(not (stringp ellipsis
)))
79 (setq ellipsis truncate-string-ellipsis
))
80 (let ((str-len (length str
))
81 (str-width (string-width str
))
82 (ellipsis-width (if ellipsis
(string-width ellipsis
) 0))
85 (head-padding "") (tail-padding "")
86 ch last-column last-idx from-idx
)
88 (while (< column start-column
)
89 (setq ch
(aref str idx
)
90 column
(+ column
(char-width ch
))
92 (args-out-of-range (setq idx str-len
)))
93 (if (< column start-column
)
94 (if padding
(make-string end-column padding
) "")
95 (when (and padding
(> column start-column
))
96 (setq head-padding
(make-string (- column start-column
) padding
)))
98 (when (>= end-column column
)
99 (if (and (< end-column str-width
)
100 (> str-width ellipsis-width
))
101 (setq end-column
(- end-column ellipsis-width
))
104 (while (< column end-column
)
105 (setq last-column column
108 column
(+ column
(char-width ch
))
110 (args-out-of-range (setq idx str-len
)))
111 (when (> column end-column
)
112 (setq column last-column
114 (when (and padding
(< column end-column
))
115 (setq tail-padding
(make-string (- end-column column
) padding
))))
116 (concat head-padding
(substring str from-idx idx
)
117 tail-padding ellipsis
))))
120 ;;; Nested alist handler.
121 ;; Nested alist is alist whose elements are also nested alist.
124 (defsubst nested-alist-p
(obj)
125 "Return t if OBJ is a nested alist.
127 Nested alist is a list of the form (ENTRY . BRANCHES), where ENTRY is
128 any Lisp object, and BRANCHES is a list of cons cells of the form
129 \(KEY-ELEMENT . NESTED-ALIST).
131 You can use a nested alist to store any Lisp object (ENTRY) for a key
132 sequence KEYSEQ, where KEYSEQ is a sequence of KEY-ELEMENT. KEYSEQ
133 can be a string, a vector, or a list."
134 (and obj
(listp obj
) (listp (cdr obj
))))
137 (defun set-nested-alist (keyseq entry alist
&optional len branches
)
138 "Set ENTRY for KEYSEQ in a nested alist ALIST.
139 Optional 4th arg LEN non-nil means the first LEN elements in KEYSEQ
141 Optional 5th argument BRANCHES if non-nil is branches for a keyseq
143 See the documentation of `nested-alist-p' for more detail."
144 (or (nested-alist-p alist
)
145 (error "Invalid argument %s" alist
))
146 (let ((len (or len
(length keyseq
)))
149 ((stringp keyseq
) ; We can use `assq' for characters.
151 (if (null (nested-alist-p alist
))
152 (error "Keyseq %s is too long for this nested alist" keyseq
))
153 (let* ((key-elt (aref keyseq i
))
154 (slot (assq key-elt
(cdr alist
))))
156 (setq slot
(list key-elt t
))
157 (push slot
(cdr alist
)))
158 (setq alist
(cdr slot
)))
162 (if (null (nested-alist-p alist
))
163 (error "Keyseq %s is too long for this nested alist" keyseq
))
164 (let* ((key-elt (aref keyseq i
))
165 (slot (assoc key-elt
(cdr alist
))))
167 (setq slot
(list key-elt t
))
168 (push slot
(cdr alist
)))
169 (setq alist
(cdr slot
)))
173 (if (null (nested-alist-p alist
))
174 (error "Keyseq %s is too long for this nested alist" keyseq
))
175 (let* ((key-elt (pop keyseq
))
176 (slot (assoc key-elt
(cdr alist
))))
178 (setq slot
(list key-elt t
))
179 (push slot
(cdr alist
)))
180 (setq alist
(cdr slot
)))
182 (t (signal 'wrong-type-argument
(list keyseq
))))
185 (setcdr (last alist
) branches
))))
188 (defun lookup-nested-alist (keyseq alist
&optional len start nil-for-too-long
)
189 "Look up key sequence KEYSEQ in nested alist ALIST. Return the definition.
190 Optional 3rd argument LEN specifies the length of KEYSEQ.
191 Optional 4th argument START specifies index of the starting key.
192 The returned value is normally a nested alist of which
193 car part is the entry for KEYSEQ.
194 If ALIST is not deep enough for KEYSEQ, return number which is
195 how many key elements at the front of KEYSEQ it takes
196 to reach a leaf in ALIST.
197 Optional 5th argument NIL-FOR-TOO-LONG non-nil means return nil
198 even if ALIST is not deep enough."
199 (or (nested-alist-p alist
)
200 (error "Invalid argument %s" alist
))
202 (setq len
(length keyseq
)))
203 (let ((i (or start
0)))
204 (if (catch 'lookup-nested-alist-tag
205 (cond ((stringp keyseq
) ; We can use `assq' for characters.
207 (if (setq alist
(cdr (assq (aref keyseq i
) (cdr alist
))))
209 (throw 'lookup-nested-alist-tag t
))))
212 (if (setq alist
(cdr (assoc (aref keyseq i
) (cdr alist
))))
214 (throw 'lookup-nested-alist-tag t
))))
216 (setq keyseq
(nthcdr i keyseq
))
218 (if (setq alist
(cdr (assoc (pop keyseq
) (cdr alist
))))
220 (throw 'lookup-nested-alist-tag t
))))
221 (t (signal 'wrong-type-argument
(list keyseq
)))))
222 ;; KEYSEQ is too long.
223 (if nil-for-too-long nil i
)
227 ;; Coding system related functions.
230 (defun coding-system-post-read-conversion (coding-system)
231 "Return the value of CODING-SYSTEM's `post-read-conversion' property."
232 (coding-system-get coding-system
:post-read-conversion
))
235 (defun coding-system-pre-write-conversion (coding-system)
236 "Return the value of CODING-SYSTEM's `pre-write-conversion' property."
237 (coding-system-get coding-system
:pre-write-conversion
))
240 (defun coding-system-translation-table-for-decode (coding-system)
241 "Return the value of CODING-SYSTEM's `decode-translation-table' property."
242 (coding-system-get coding-system
:decode-translation-table
))
245 (defun coding-system-translation-table-for-encode (coding-system)
246 "Return the value of CODING-SYSTEM's `encode-translation-table' property."
247 (coding-system-get coding-system
:encode-translation-table
))
250 (defmacro with-coding-priority
(coding-systems &rest body
)
251 "Execute BODY like `progn' with CODING-SYSTEMS at the front of priority list.
252 CODING-SYSTEMS is a list of coding systems. See `set-coding-system-priority'.
253 This affects the implicit sorting of lists of coding systems returned by
254 operations such as `find-coding-systems-region'."
255 (let ((current (make-symbol "current")))
256 `(let ((,current
(coding-system-priority-list)))
257 (apply #'set-coding-system-priority
,coding-systems
)
260 (apply #'set-coding-system-priority
,current
)))))
261 ;;;###autoload(put 'with-coding-priority 'lisp-indent-function 1)
262 (put 'with-coding-priority
'edebug-form-spec t
)
265 (defmacro detect-coding-with-priority
(from to priority-list
)
266 "Detect a coding system of the text between FROM and TO with PRIORITY-LIST.
267 PRIORITY-LIST is an alist of coding categories vs the corresponding
268 coding systems ordered by priority."
269 (declare (obsolete with-coding-priority
"23.1"))
270 `(with-coding-priority (mapcar #'cdr
,priority-list
)
271 (detect-coding-region ,from
,to
)))
274 (defun detect-coding-with-language-environment (from to lang-env
)
275 "Detect a coding system for the text between FROM and TO with LANG-ENV.
276 The detection takes into account the coding system priorities for the
277 language environment LANG-ENV."
278 (let ((coding-priority (get-language-info lang-env
'coding-priority
)))
280 (with-coding-priority coding-priority
281 (detect-coding-region from to
)))))
283 (declare-function internal-char-font
"font.c" (position &optional ch
))
285 (defun filepos-to-bufferpos--dos (byte f
)
287 ;; Make sure we terminate, even if BYTE falls right in the middle
288 ;; of a CRLF or some other weird corner case.
293 (setq pos
(funcall f
(- byte eol-offset
)))
294 ;; Protect against accidental values of BYTE outside of the
297 (if (<= byte eol-offset
)
298 (setq pos
(point-min))
299 (setq pos
(point-max))))
300 ;; Adjust POS for DOS EOL format.
301 (setq lines
(1- (line-number-at-pos pos
)))
302 (and (not (= lines eol-offset
)) (or (not omax
) (> omax omin
))))
303 (if (> lines eol-offset
)
304 (setq omax
(if omax
(min (1- omax
) lines
) lines
)
306 (setq omin
(max (1+ omin
) lines
)
311 (defun filepos-to-bufferpos (byte &optional quality coding-system
)
312 "Try to return the buffer position corresponding to a particular file position.
313 The file position is given as a (0-based) BYTE count.
314 The function presumes the file is encoded with CODING-SYSTEM, which defaults
315 to `buffer-file-coding-system'.
317 `approximate', in which case we may cut some corners to avoid
319 `exact', in which case we may end up re-(en/de)coding a large
320 part of the file/buffer, this can be expensive and slow.
321 nil, in which case we may return nil rather than an approximation."
322 (unless coding-system
(setq coding-system buffer-file-coding-system
))
323 (let ((eol (coding-system-eol-type coding-system
))
324 (type (coding-system-type coding-system
))
325 (base (coding-system-base coding-system
))
326 (pm (save-restriction (widen) (point-min))))
327 (and (eq type
'utf-8
)
328 ;; Any post-read/pre-write conversions mean it's not really UTF-8.
329 (not (null (coding-system-get coding-system
:post-read-conversion
)))
330 (setq type
'not-utf-8
))
331 (and (memq type
'(charset raw-text undecided
))
332 ;; The following are all of type 'charset', but they are
333 ;; actually variable-width encodings.
334 (not (memq base
'(chinese-gbk chinese-gb18030 euc-tw euc-jis-2004
335 korean-iso-8bit chinese-iso-8bit
336 japanese-iso-8bit chinese-big5-hkscs
337 japanese-cp932 korean-cp949
)))
338 (setq type
'single-byte
))
341 (when (coding-system-get coding-system
:bom
)
342 (setq byte
(max 0 (- byte
3))))
344 (filepos-to-bufferpos--dos (+ pm byte
) #'byte-to-position
)
345 (byte-to-position (+ pm byte
))))
348 (filepos-to-bufferpos--dos (+ pm byte
) #'identity
)
351 ;; FIXME: For utf-16, we could use the same approach as used for
352 ;; dos EOLs (counting the number of non-BMP chars instead of the
354 (guard (not (eq quality
'exact
))))
355 ;; Account for BOM, which is always 2 bytes in UTF-16.
356 (when (coding-system-get coding-system
:bom
)
357 (setq byte
(max 0 (- byte
2))))
358 ;; In approximate mode, assume all characters are within the
359 ;; BMP, i.e. take up 2 bytes.
360 (setq byte
(/ byte
2))
362 (filepos-to-bufferpos--dos (+ pm byte
) #'identity
)
366 ('approximate
(byte-to-position (+ pm byte
)))
368 ;; Rather than assume that the file exists and still holds the right
369 ;; data, we reconstruct it based on the buffer's content.
370 (let ((buf (current-buffer)))
372 (set-buffer-multibyte nil
)
373 (let ((tmp-buf (current-buffer)))
374 (with-current-buffer buf
377 ;; Since encoding should always return more bytes than
378 ;; there were chars, encoding all chars up to (+ byte pm)
379 ;; guarantees the encoded result has at least `byte' bytes.
380 (encode-coding-region pm
(min (point-max) (+ pm byte
))
381 coding-system tmp-buf
)))
383 (decode-coding-region (point-min)
384 (min (point-max) (+ pm byte
))
385 coding-system t
))))))))))))
387 (defun bufferpos-to-filepos (position &optional quality coding-system
)
388 "Try to return the file byte corresponding to a particular buffer POSITION.
389 Value is the file position given as a (0-based) byte count.
390 The function presumes the file is encoded with CODING-SYSTEM, which defaults
391 to `buffer-file-coding-system'.
393 `approximate', in which case we may cut some corners to avoid
395 `exact', in which case we may end up re-(en/de)coding a large
396 part of the file/buffer, this can be expensive and slow.
397 nil, in which case we may return nil rather than an approximation."
398 (unless coding-system
(setq coding-system buffer-file-coding-system
))
399 (let* ((eol (coding-system-eol-type coding-system
))
400 (lineno (if (= eol
1) (1- (line-number-at-pos position
)) 0))
401 (type (coding-system-type coding-system
))
402 (base (coding-system-base coding-system
))
403 (point-min 1)) ;Clarify what the `1' means.
404 (and (eq type
'utf-8
)
405 ;; Any post-read/pre-write conversions mean it's not really UTF-8.
406 (not (null (coding-system-get coding-system
:post-read-conversion
)))
407 (setq type
'not-utf-8
))
408 (and (memq type
'(charset raw-text undecided
))
409 ;; The following are all of type 'charset', but they are
410 ;; actually variable-width encodings.
411 (not (memq base
'(chinese-gbk chinese-gb18030 euc-tw euc-jis-2004
412 korean-iso-8bit chinese-iso-8bit
413 japanese-iso-8bit chinese-big5-hkscs
414 japanese-cp932 korean-cp949
)))
415 (setq type
'single-byte
))
418 (+ (or (position-bytes position
)
421 (position-bytes (point-max))))
422 ;; Account for BOM, if any.
423 (if (coding-system-get coding-system
:bom
) 3 0)
424 ;; Account for CR in CRLF pairs.
428 (+ position
(- point-min
) lineno
))
430 ;; FIXME: For utf-16, we could use the same approach as used for
431 ;; dos EOLs (counting the number of non-BMP chars instead of the
433 (guard (not (eq quality
'exact
))))
434 ;; In approximate mode, assume all characters are within the
435 ;; BMP, i.e. each one takes up 2 bytes.
436 (+ (* (- position point-min
) 2)
437 ;; Account for BOM, if any.
438 (if (coding-system-get coding-system
:bom
) 2 0)
439 ;; Account for CR in CRLF pairs.
443 ('approximate
(+ (position-bytes position
) (- point-min
) lineno
))
445 ;; Rather than assume that the file exists and still holds the right
446 ;; data, we reconstruct its relevant portion.
447 (let ((buf (current-buffer)))
449 (set-buffer-multibyte nil
)
450 (let ((tmp-buf (current-buffer)))
451 (with-current-buffer buf
454 (encode-coding-region (point-min) (min (point-max) position
)
455 coding-system tmp-buf
)))
456 (buffer-size))))))))))
464 ;;; mule-util.el ends here