1 ;;; mule-util.el --- utility functions for multilingual environment (mule) -*- lexical-binding:t -*-
3 ;; Copyright (C) 1997-1998, 2000-2017 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
))
286 (defun char-displayable-p (char)
287 "Return non-nil if we should be able to display CHAR.
288 On a multi-font display, the test is only whether there is an
289 appropriate font from the selected frame's fontset to display
290 CHAR's charset in general. Since fonts may be specified on a
291 per-character basis, this may not be accurate."
293 ;; ASCII characters are always displayable.
295 ((not enable-multibyte-characters
)
296 ;; Maybe there's a font for it, but we can't put it in the buffer.
299 (let ((font-glyph (internal-char-font nil char
)))
301 (if (consp font-glyph
)
302 ;; On a window system, a character is displayable
303 ;; if a font for that character is in the default
304 ;; face of the currently selected frame.
306 ;; On a text terminal supporting glyph codes, CHAR is
307 ;; displayable if its glyph code is nonnegative.
309 ;; On a text terminal without glyph codes, CHAR is displayable
310 ;; if the coding system for the terminal can encode it.
311 (let ((coding (terminal-coding-system)))
313 (let ((cs-list (coding-system-get coding
:charset-list
)))
317 (mapc #'(lambda (charset)
318 (if (encode-char char charset
)
319 (throw 'tag charset
)))
322 ((eq cs-list
'iso-2022
)
324 (mapc #'(lambda (charset)
325 (if (and (plist-get (charset-plist charset
)
327 (encode-char char charset
))
328 (throw 'tag2 charset
)))
331 ((eq cs-list
'emacs-mule
)
333 (mapc #'(lambda (charset)
334 (if (and (plist-get (charset-plist charset
)
336 (encode-char char charset
))
337 (throw 'tag3 charset
)))
341 (defun filepos-to-bufferpos--dos (byte f
)
343 ;; Make sure we terminate, even if BYTE falls right in the middle
344 ;; of a CRLF or some other weird corner case.
345 (omin 0) (omax most-positive-fixnum
)
349 (setq pos
(funcall f
(- byte eol-offset
)))
350 ;; Protect against accidental values of BYTE outside of the
353 (if (<= byte eol-offset
)
354 (setq pos
(point-min))
355 (setq pos
(point-max))))
356 ;; Adjust POS for DOS EOL format.
357 (setq lines
(1- (line-number-at-pos pos
)))
358 (and (not (= lines eol-offset
)) (> omax omin
)))
359 (if (> lines eol-offset
)
360 (setq omax
(min (1- omax
) lines
)
362 (setq omin
(max (1+ omin
) lines
)
367 (defun filepos-to-bufferpos (byte &optional quality coding-system
)
368 "Try to return the buffer position corresponding to a particular file position.
369 The file position is given as a (0-based) BYTE count.
370 The function presumes the file is encoded with CODING-SYSTEM, which defaults
371 to `buffer-file-coding-system'.
373 `approximate', in which case we may cut some corners to avoid
375 `exact', in which case we may end up re-(en/de)coding a large
376 part of the file/buffer, this can be expensive and slow.
377 nil, in which case we may return nil rather than an approximation."
378 (unless coding-system
(setq coding-system buffer-file-coding-system
))
379 (let ((eol (coding-system-eol-type coding-system
))
380 (type (coding-system-type coding-system
))
381 (base (coding-system-base coding-system
))
382 (pm (save-restriction (widen) (point-min))))
383 (and (eq type
'utf-8
)
384 ;; Any post-read/pre-write conversions mean it's not really UTF-8.
385 (not (null (coding-system-get coding-system
:post-read-conversion
)))
386 (setq type
'not-utf-8
))
387 (and (memq type
'(charset raw-text undecided
))
388 ;; The following are all of type 'charset', but they are
389 ;; actually variable-width encodings.
390 (not (memq base
'(chinese-gbk chinese-gb18030 euc-tw euc-jis-2004
391 korean-iso-8bit chinese-iso-8bit
392 japanese-iso-8bit chinese-big5-hkscs
393 japanese-cp932 korean-cp949
)))
394 (setq type
'single-byte
))
397 (when (coding-system-get coding-system
:bom
)
398 (setq byte
(max 0 (- byte
3))))
400 (filepos-to-bufferpos--dos (+ pm byte
) #'byte-to-position
)
401 (byte-to-position (+ pm byte
))))
404 (filepos-to-bufferpos--dos (+ pm byte
) #'identity
)
407 ;; FIXME: For utf-16, we could use the same approach as used for
408 ;; dos EOLs (counting the number of non-BMP chars instead of the
410 (guard (not (eq quality
'exact
))))
411 ;; Account for BOM, which is always 2 bytes in UTF-16.
412 (when (coding-system-get coding-system
:bom
)
413 (setq byte
(max 0 (- byte
2))))
414 ;; In approximate mode, assume all characters are within the
415 ;; BMP, i.e. take up 2 bytes.
416 (setq byte
(/ byte
2))
418 (filepos-to-bufferpos--dos (+ pm byte
) #'identity
)
422 (`approximate
(byte-to-position (+ pm byte
)))
424 ;; Rather than assume that the file exists and still holds the right
425 ;; data, we reconstruct it based on the buffer's content.
426 (let ((buf (current-buffer)))
428 (set-buffer-multibyte nil
)
429 (let ((tmp-buf (current-buffer)))
430 (with-current-buffer buf
433 ;; Since encoding should always return more bytes than
434 ;; there were chars, encoding all chars up to (+ byte pm)
435 ;; guarantees the encoded result has at least `byte' bytes.
436 (encode-coding-region pm
(min (point-max) (+ pm byte
))
437 coding-system tmp-buf
)))
439 (decode-coding-region (point-min)
440 (min (point-max) (+ pm byte
))
441 coding-system t
))))))))))))
443 (defun bufferpos-to-filepos (position &optional quality coding-system
)
444 "Try to return the file byte corresponding to a particular buffer POSITION.
445 Value is the file position given as a (0-based) byte count.
446 The function presumes the file is encoded with CODING-SYSTEM, which defaults
447 to `buffer-file-coding-system'.
449 `approximate', in which case we may cut some corners to avoid
451 `exact', in which case we may end up re-(en/de)coding a large
452 part of the file/buffer, this can be expensive and slow.
453 nil, in which case we may return nil rather than an approximation."
454 (unless coding-system
(setq coding-system buffer-file-coding-system
))
455 (let* ((eol (coding-system-eol-type coding-system
))
456 (lineno (if (= eol
1) (1- (line-number-at-pos position
)) 0))
457 (type (coding-system-type coding-system
))
458 (base (coding-system-base coding-system
))
460 (and (eq type
'utf-8
)
461 ;; Any post-read/pre-write conversions mean it's not really UTF-8.
462 (not (null (coding-system-get coding-system
:post-read-conversion
)))
463 (setq type
'not-utf-8
))
464 (and (memq type
'(charset raw-text undecided
))
465 ;; The following are all of type 'charset', but they are
466 ;; actually variable-width encodings.
467 (not (memq base
'(chinese-gbk chinese-gb18030 euc-tw euc-jis-2004
468 korean-iso-8bit chinese-iso-8bit
469 japanese-iso-8bit chinese-big5-hkscs
470 japanese-cp932 korean-cp949
)))
471 (setq type
'single-byte
))
474 (setq byte
(position-bytes position
))
478 (setq byte
(position-bytes (point-max)))))
479 (setq byte
(1- byte
))
481 ;; Account for BOM, if any.
482 (if (coding-system-get coding-system
:bom
) 3 0)
483 ;; Account for CR in CRLF pairs.
486 (+ position -
1 lineno
))
488 ;; FIXME: For utf-16, we could use the same approach as used for
489 ;; dos EOLs (counting the number of non-BMP chars instead of the
491 (guard (not (eq quality
'exact
))))
492 ;; In approximate mode, assume all characters are within the
493 ;; BMP, i.e. each one takes up 2 bytes.
494 (+ (* (1- position
) 2)
495 ;; Account for BOM, if any.
496 (if (coding-system-get coding-system
:bom
) 2 0)
497 ;; Account for CR in CRLF pairs.
501 (`approximate
(+ (position-bytes position
) -
1 lineno
))
503 ;; Rather than assume that the file exists and still holds the right
504 ;; data, we reconstruct its relevant portion.
505 (let ((buf (current-buffer)))
507 (set-buffer-multibyte nil
)
508 (let ((tmp-buf (current-buffer)))
509 (with-current-buffer buf
512 (encode-coding-region (point-min) (min (point-max) position
)
513 coding-system tmp-buf
)))
514 (1- (point-max)))))))))))
522 ;;; mule-util.el ends here