2015-06-15 18:48:08 -04:00
|
|
|
|
;;; mule-util.el --- utility functions for multilingual environment (mule) -*- lexical-binding:t -*-
|
1997-02-20 07:02:49 +00:00
|
|
|
|
|
2022-01-01 02:45:51 -05:00
|
|
|
|
;; Copyright (C) 1997-1998, 2000-2022 Free Software Foundation, Inc.
|
2006-12-13 01:13:58 +00:00
|
|
|
|
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
|
2011-01-02 15:50:46 -08:00
|
|
|
|
;; 2005, 2006, 2007, 2008, 2009, 2010, 2011
|
2005-05-13 06:03:46 +00:00
|
|
|
|
;; National Institute of Advanced Industrial Science and Technology (AIST)
|
|
|
|
|
;; Registration Number H14PRO021
|
2003-09-08 12:53:41 +00:00
|
|
|
|
;; Copyright (C) 2003
|
|
|
|
|
;; National Institute of Advanced Industrial Science and Technology (AIST)
|
|
|
|
|
;; Registration Number H13PRO009
|
|
|
|
|
|
1997-02-20 07:02:49 +00:00
|
|
|
|
;; Keywords: mule, multilingual
|
|
|
|
|
|
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
|
|
2008-05-06 04:29:13 +00:00
|
|
|
|
;; GNU Emacs is free software: you can redistribute it and/or modify
|
1997-02-20 07:02:49 +00:00
|
|
|
|
;; it under the terms of the GNU General Public License as published by
|
2008-05-06 04:29:13 +00:00
|
|
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
|
|
|
;; (at your option) any later version.
|
1997-02-20 07:02:49 +00:00
|
|
|
|
|
|
|
|
|
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
|
;; GNU General Public License for more details.
|
|
|
|
|
|
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
2017-09-13 15:52:52 -07:00
|
|
|
|
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
1997-02-20 07:02:49 +00:00
|
|
|
|
|
2001-07-15 19:53:53 +00:00
|
|
|
|
;;; Commentary:
|
|
|
|
|
|
1997-02-20 07:02:49 +00:00
|
|
|
|
;;; Code:
|
|
|
|
|
|
2015-06-15 18:48:08 -04:00
|
|
|
|
;;; String manipulations while paying attention to multibyte characters.
|
1997-02-20 07:02:49 +00:00
|
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun store-substring (string idx obj)
|
|
|
|
|
"Embed OBJ (string or character) at index IDX of STRING."
|
1998-01-22 01:42:20 +00:00
|
|
|
|
(if (integerp obj)
|
|
|
|
|
(aset string idx obj)
|
|
|
|
|
(let ((len1 (length obj))
|
|
|
|
|
(i 0))
|
|
|
|
|
(while (< i len1)
|
|
|
|
|
(aset string (+ idx i) (aref obj i))
|
|
|
|
|
(setq i (1+ i)))))
|
|
|
|
|
string)
|
1997-02-20 07:02:49 +00:00
|
|
|
|
|
2020-10-04 22:41:36 +03:00
|
|
|
|
(defvar truncate-string-ellipsis nil
|
2015-11-29 19:40:08 +02:00
|
|
|
|
"String to use to indicate truncation.
|
2020-10-04 22:41:36 +03:00
|
|
|
|
Serves as default value of ELLIPSIS argument to `truncate-string-to-width'
|
|
|
|
|
returned by the function `truncate-string-ellipsis'.")
|
|
|
|
|
|
|
|
|
|
(defun truncate-string-ellipsis ()
|
2020-10-05 08:37:02 +03:00
|
|
|
|
"Return the string used to indicate truncation.
|
2020-10-04 22:41:36 +03:00
|
|
|
|
Use the value of the variable `truncate-string-ellipsis' when it's non-nil.
|
2020-10-06 11:24:15 +03:00
|
|
|
|
Otherwise, return the Unicode character U+2026 \"HORIZONTAL ELLIPSIS\"
|
|
|
|
|
when it's displayable on the selected frame, or `...'. This function
|
|
|
|
|
needs to be called on every use of `truncate-string-to-width' to
|
|
|
|
|
decide whether the selected frame can display that Unicode character."
|
2020-10-04 22:41:36 +03:00
|
|
|
|
(cond
|
|
|
|
|
(truncate-string-ellipsis)
|
2020-10-06 09:38:25 -04:00
|
|
|
|
((char-displayable-p ?…) "…")
|
2020-10-04 22:41:36 +03:00
|
|
|
|
("...")))
|
2014-06-19 10:58:57 -04:00
|
|
|
|
|
1997-02-20 07:02:49 +00:00
|
|
|
|
;;;###autoload
|
2002-05-21 21:22:21 +00:00
|
|
|
|
(defun truncate-string-to-width (str end-column
|
2019-10-07 20:11:26 +02:00
|
|
|
|
&optional start-column padding ellipsis
|
|
|
|
|
ellipsis-text-property)
|
1997-09-13 08:44:55 +00:00
|
|
|
|
"Truncate string STR to end at column END-COLUMN.
|
2002-05-21 21:22:21 +00:00
|
|
|
|
The optional 3rd arg START-COLUMN, if non-nil, specifies the starting
|
2021-10-30 10:26:38 +03:00
|
|
|
|
column (default: zero); that means to return the characters occupying
|
|
|
|
|
columns START-COLUMN ... END-COLUMN of STR. Both END-COLUMN and
|
|
|
|
|
START-COLUMN are specified in terms of character display width in the
|
|
|
|
|
current buffer; see `char-width'.
|
|
|
|
|
|
|
|
|
|
Since character composition on display can produce glyphs whose
|
|
|
|
|
width is smaller than the sum of `char-width' values of the
|
|
|
|
|
composed characters, this function can produce inaccurate results
|
|
|
|
|
when used in such cases.
|
2002-05-21 21:22:21 +00:00
|
|
|
|
|
|
|
|
|
The optional 4th arg PADDING, if non-nil, specifies a padding
|
|
|
|
|
character (which should have a display width of 1) to add at the end
|
|
|
|
|
of the result if STR doesn't reach column END-COLUMN, or if END-COLUMN
|
|
|
|
|
comes in the middle of a character in STR. PADDING is also added at
|
|
|
|
|
the beginning of the result if column START-COLUMN appears in the
|
|
|
|
|
middle of a character in STR.
|
1997-09-13 08:44:55 +00:00
|
|
|
|
|
|
|
|
|
If PADDING is nil, no padding is added in these cases, so
|
2002-05-21 21:22:21 +00:00
|
|
|
|
the resulting string may be narrower than END-COLUMN.
|
|
|
|
|
|
|
|
|
|
If ELLIPSIS is non-nil, it should be a string which will replace the
|
|
|
|
|
end of STR (including any padding) if it extends beyond END-COLUMN,
|
|
|
|
|
unless the display width of STR is equal to or less than the display
|
|
|
|
|
width of ELLIPSIS. If it is non-nil and not a string, then ELLIPSIS
|
2020-10-04 22:41:36 +03:00
|
|
|
|
defaults to `truncate-string-ellipsis', or to three dots when it's nil.
|
2019-10-07 20:11:26 +02:00
|
|
|
|
|
2020-03-01 18:50:14 +01:00
|
|
|
|
If ELLIPSIS-TEXT-PROPERTY is non-nil, a too-long string will not
|
2019-10-07 20:11:26 +02:00
|
|
|
|
be truncated, but instead the elided parts will be covered by a
|
|
|
|
|
`display' text property showing the ellipsis."
|
1997-02-20 07:02:49 +00:00
|
|
|
|
(or start-column
|
|
|
|
|
(setq start-column 0))
|
2002-05-21 21:22:21 +00:00
|
|
|
|
(when (and ellipsis (not (stringp ellipsis)))
|
2020-10-04 22:41:36 +03:00
|
|
|
|
(setq ellipsis (truncate-string-ellipsis)))
|
2002-05-21 21:22:21 +00:00
|
|
|
|
(let ((str-len (length str))
|
|
|
|
|
(str-width (string-width str))
|
|
|
|
|
(ellipsis-width (if ellipsis (string-width ellipsis) 0))
|
1997-02-20 07:02:49 +00:00
|
|
|
|
(idx 0)
|
|
|
|
|
(column 0)
|
|
|
|
|
(head-padding "") (tail-padding "")
|
|
|
|
|
ch last-column last-idx from-idx)
|
|
|
|
|
(condition-case nil
|
|
|
|
|
(while (< column start-column)
|
1998-01-22 01:42:20 +00:00
|
|
|
|
(setq ch (aref str idx)
|
1997-02-20 07:02:49 +00:00
|
|
|
|
column (+ column (char-width ch))
|
1998-01-22 01:42:20 +00:00
|
|
|
|
idx (1+ idx)))
|
2002-05-21 21:22:21 +00:00
|
|
|
|
(args-out-of-range (setq idx str-len)))
|
1997-02-20 07:02:49 +00:00
|
|
|
|
(if (< column start-column)
|
1997-09-13 08:44:55 +00:00
|
|
|
|
(if padding (make-string end-column padding) "")
|
2002-05-21 21:22:21 +00:00
|
|
|
|
(when (and padding (> column start-column))
|
|
|
|
|
(setq head-padding (make-string (- column start-column) padding)))
|
1997-02-20 07:02:49 +00:00
|
|
|
|
(setq from-idx idx)
|
2002-05-21 21:22:21 +00:00
|
|
|
|
(when (>= end-column column)
|
|
|
|
|
(if (and (< end-column str-width)
|
|
|
|
|
(> str-width ellipsis-width))
|
|
|
|
|
(setq end-column (- end-column ellipsis-width))
|
|
|
|
|
(setq ellipsis ""))
|
1997-09-13 08:44:55 +00:00
|
|
|
|
(condition-case nil
|
|
|
|
|
(while (< column end-column)
|
|
|
|
|
(setq last-column column
|
|
|
|
|
last-idx idx
|
1998-01-22 01:42:20 +00:00
|
|
|
|
ch (aref str idx)
|
1997-09-13 08:44:55 +00:00
|
|
|
|
column (+ column (char-width ch))
|
1998-01-22 01:42:20 +00:00
|
|
|
|
idx (1+ idx)))
|
2002-05-21 21:22:21 +00:00
|
|
|
|
(args-out-of-range (setq idx str-len)))
|
|
|
|
|
(when (> column end-column)
|
|
|
|
|
(setq column last-column
|
|
|
|
|
idx last-idx))
|
|
|
|
|
(when (and padding (< column end-column))
|
|
|
|
|
(setq tail-padding (make-string (- end-column column) padding))))
|
2019-10-07 20:11:26 +02:00
|
|
|
|
(if (and ellipsis-text-property
|
|
|
|
|
(not (equal ellipsis ""))
|
|
|
|
|
idx)
|
|
|
|
|
;; Use text properties for the ellipsis.
|
|
|
|
|
(concat head-padding
|
|
|
|
|
(substring str from-idx idx)
|
|
|
|
|
(propertize (substring str idx) 'display (or ellipsis "")))
|
|
|
|
|
;; (Possibly) chop off bits of the string.
|
|
|
|
|
(concat head-padding (substring str from-idx idx)
|
|
|
|
|
tail-padding ellipsis)))))
|
2002-05-21 21:22:21 +00:00
|
|
|
|
|
1997-02-20 07:02:49 +00:00
|
|
|
|
|
2015-06-15 18:48:08 -04:00
|
|
|
|
;;; Nested alist handler.
|
|
|
|
|
;; Nested alist is alist whose elements are also nested alist.
|
1997-02-20 07:02:49 +00:00
|
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
|
(defsubst nested-alist-p (obj)
|
1998-09-06 14:31:49 +00:00
|
|
|
|
"Return t if OBJ is a nested alist.
|
1997-02-20 07:02:49 +00:00
|
|
|
|
|
|
|
|
|
Nested alist is a list of the form (ENTRY . BRANCHES), where ENTRY is
|
|
|
|
|
any Lisp object, and BRANCHES is a list of cons cells of the form
|
2002-06-18 22:59:30 +00:00
|
|
|
|
\(KEY-ELEMENT . NESTED-ALIST).
|
1997-02-20 07:02:49 +00:00
|
|
|
|
|
|
|
|
|
You can use a nested alist to store any Lisp object (ENTRY) for a key
|
|
|
|
|
sequence KEYSEQ, where KEYSEQ is a sequence of KEY-ELEMENT. KEYSEQ
|
|
|
|
|
can be a string, a vector, or a list."
|
|
|
|
|
(and obj (listp obj) (listp (cdr obj))))
|
|
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun set-nested-alist (keyseq entry alist &optional len branches)
|
|
|
|
|
"Set ENTRY for KEYSEQ in a nested alist ALIST.
|
1998-09-06 14:31:49 +00:00
|
|
|
|
Optional 4th arg LEN non-nil means the first LEN elements in KEYSEQ
|
2008-11-20 23:07:44 +00:00
|
|
|
|
are considered.
|
|
|
|
|
Optional 5th argument BRANCHES if non-nil is branches for a keyseq
|
1997-02-20 07:02:49 +00:00
|
|
|
|
longer than KEYSEQ.
|
|
|
|
|
See the documentation of `nested-alist-p' for more detail."
|
|
|
|
|
(or (nested-alist-p alist)
|
1998-09-06 14:31:49 +00:00
|
|
|
|
(error "Invalid argument %s" alist))
|
2017-07-01 22:39:16 -04:00
|
|
|
|
(let ((len (or len (length keyseq)))
|
|
|
|
|
(i 0))
|
|
|
|
|
(cond
|
|
|
|
|
((stringp keyseq) ; We can use `assq' for characters.
|
|
|
|
|
(while (< i len)
|
|
|
|
|
(if (null (nested-alist-p alist))
|
|
|
|
|
(error "Keyseq %s is too long for this nested alist" keyseq))
|
|
|
|
|
(let* ((key-elt (aref keyseq i))
|
|
|
|
|
(slot (assq key-elt (cdr alist))))
|
|
|
|
|
(unless slot
|
|
|
|
|
(setq slot (list key-elt t))
|
|
|
|
|
(push slot (cdr alist)))
|
|
|
|
|
(setq alist (cdr slot)))
|
|
|
|
|
(setq i (1+ i))))
|
|
|
|
|
((arrayp keyseq)
|
|
|
|
|
(while (< i len)
|
|
|
|
|
(if (null (nested-alist-p alist))
|
|
|
|
|
(error "Keyseq %s is too long for this nested alist" keyseq))
|
|
|
|
|
(let* ((key-elt (aref keyseq i))
|
|
|
|
|
(slot (assoc key-elt (cdr alist))))
|
|
|
|
|
(unless slot
|
|
|
|
|
(setq slot (list key-elt t))
|
|
|
|
|
(push slot (cdr alist)))
|
|
|
|
|
(setq alist (cdr slot)))
|
|
|
|
|
(setq i (1+ i))))
|
|
|
|
|
((listp keyseq)
|
|
|
|
|
(while (< i len)
|
|
|
|
|
(if (null (nested-alist-p alist))
|
|
|
|
|
(error "Keyseq %s is too long for this nested alist" keyseq))
|
|
|
|
|
(let* ((key-elt (pop keyseq))
|
|
|
|
|
(slot (assoc key-elt (cdr alist))))
|
|
|
|
|
(unless slot
|
|
|
|
|
(setq slot (list key-elt t))
|
|
|
|
|
(push slot (cdr alist)))
|
|
|
|
|
(setq alist (cdr slot)))
|
|
|
|
|
(setq i (1+ i))))
|
|
|
|
|
(t (signal 'wrong-type-argument (list keyseq))))
|
1997-02-20 07:02:49 +00:00
|
|
|
|
(setcar alist entry)
|
|
|
|
|
(if branches
|
1999-12-15 00:42:14 +00:00
|
|
|
|
(setcdr (last alist) branches))))
|
1997-02-20 07:02:49 +00:00
|
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun lookup-nested-alist (keyseq alist &optional len start nil-for-too-long)
|
|
|
|
|
"Look up key sequence KEYSEQ in nested alist ALIST. Return the definition.
|
2008-11-20 23:07:44 +00:00
|
|
|
|
Optional 3rd argument LEN specifies the length of KEYSEQ.
|
|
|
|
|
Optional 4th argument START specifies index of the starting key.
|
1997-02-20 07:02:49 +00:00
|
|
|
|
The returned value is normally a nested alist of which
|
|
|
|
|
car part is the entry for KEYSEQ.
|
|
|
|
|
If ALIST is not deep enough for KEYSEQ, return number which is
|
|
|
|
|
how many key elements at the front of KEYSEQ it takes
|
|
|
|
|
to reach a leaf in ALIST.
|
2008-11-20 23:07:44 +00:00
|
|
|
|
Optional 5th argument NIL-FOR-TOO-LONG non-nil means return nil
|
1997-02-20 07:02:49 +00:00
|
|
|
|
even if ALIST is not deep enough."
|
|
|
|
|
(or (nested-alist-p alist)
|
2000-04-01 12:03:57 +00:00
|
|
|
|
(error "Invalid argument %s" alist))
|
1997-02-20 07:02:49 +00:00
|
|
|
|
(or len
|
|
|
|
|
(setq len (length keyseq)))
|
|
|
|
|
(let ((i (or start 0)))
|
|
|
|
|
(if (catch 'lookup-nested-alist-tag
|
2017-07-01 22:39:16 -04:00
|
|
|
|
(cond ((stringp keyseq) ; We can use `assq' for characters.
|
|
|
|
|
(while (< i len)
|
|
|
|
|
(if (setq alist (cdr (assq (aref keyseq i) (cdr alist))))
|
|
|
|
|
(setq i (1+ i))
|
|
|
|
|
(throw 'lookup-nested-alist-tag t))))
|
|
|
|
|
((arrayp keyseq)
|
|
|
|
|
(while (< i len)
|
|
|
|
|
(if (setq alist (cdr (assoc (aref keyseq i) (cdr alist))))
|
|
|
|
|
(setq i (1+ i))
|
|
|
|
|
(throw 'lookup-nested-alist-tag t))))
|
|
|
|
|
((listp keyseq)
|
|
|
|
|
(setq keyseq (nthcdr i keyseq))
|
|
|
|
|
(while (< i len)
|
|
|
|
|
(if (setq alist (cdr (assoc (pop keyseq) (cdr alist))))
|
|
|
|
|
(setq i (1+ i))
|
|
|
|
|
(throw 'lookup-nested-alist-tag t))))
|
|
|
|
|
(t (signal 'wrong-type-argument (list keyseq)))))
|
1997-02-20 07:02:49 +00:00
|
|
|
|
;; KEYSEQ is too long.
|
|
|
|
|
(if nil-for-too-long nil i)
|
|
|
|
|
alist)))
|
|
|
|
|
|
1997-06-18 12:55:11 +00:00
|
|
|
|
|
1997-02-20 07:02:49 +00:00
|
|
|
|
;; Coding system related functions.
|
|
|
|
|
|
1997-06-18 12:55:11 +00:00
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun coding-system-post-read-conversion (coding-system)
|
2001-12-15 16:43:11 +00:00
|
|
|
|
"Return the value of CODING-SYSTEM's `post-read-conversion' property."
|
2002-05-26 22:42:00 +00:00
|
|
|
|
(coding-system-get coding-system :post-read-conversion))
|
1997-06-18 12:55:11 +00:00
|
|
|
|
|
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun coding-system-pre-write-conversion (coding-system)
|
2001-12-15 16:43:11 +00:00
|
|
|
|
"Return the value of CODING-SYSTEM's `pre-write-conversion' property."
|
2002-05-26 22:42:00 +00:00
|
|
|
|
(coding-system-get coding-system :pre-write-conversion))
|
1997-06-18 12:55:11 +00:00
|
|
|
|
|
|
|
|
|
;;;###autoload
|
1998-05-18 01:01:00 +00:00
|
|
|
|
(defun coding-system-translation-table-for-decode (coding-system)
|
2003-09-08 12:53:41 +00:00
|
|
|
|
"Return the value of CODING-SYSTEM's `decode-translation-table' property."
|
2002-05-26 22:42:00 +00:00
|
|
|
|
(coding-system-get coding-system :decode-translation-table))
|
1997-08-22 01:22:49 +00:00
|
|
|
|
|
|
|
|
|
;;;###autoload
|
1998-05-18 01:01:00 +00:00
|
|
|
|
(defun coding-system-translation-table-for-encode (coding-system)
|
2003-09-08 12:53:41 +00:00
|
|
|
|
"Return the value of CODING-SYSTEM's `encode-translation-table' property."
|
2002-05-26 22:42:00 +00:00
|
|
|
|
(coding-system-get coding-system :encode-translation-table))
|
1997-06-18 12:55:11 +00:00
|
|
|
|
|
2003-09-08 12:53:41 +00:00
|
|
|
|
;;;###autoload
|
|
|
|
|
(defmacro with-coding-priority (coding-systems &rest body)
|
|
|
|
|
"Execute BODY like `progn' with CODING-SYSTEMS at the front of priority list.
|
2011-02-04 11:45:46 +01:00
|
|
|
|
CODING-SYSTEMS is a list of coding systems. See `set-coding-system-priority'.
|
2011-12-11 21:32:49 -08:00
|
|
|
|
This affects the implicit sorting of lists of coding systems returned by
|
2008-11-20 23:07:44 +00:00
|
|
|
|
operations such as `find-coding-systems-region'."
|
Prefer `declare` over a `put` of `list-indent-function`.
While at it, I enabled lexical-binding in the affected files.
* lisp/cedet/semantic/sb.el: Enable lexical-binding.
(semantic-sb-with-tag-buffer): Use `declare`.
* lisp/cedet/semantic/bovine/el.el: Enable lexical-binding.
(semantic-elisp-setup-form-parser): Use `declare`.
* lisp/emacs-lisp/ert.el:
* lisp/emacs-lisp/ert-x.el: Remove redundant `put`.
* lisp/emulation/cua-rect.el: Enable lexical-binding.
(cua--rectangle-operation, cua--rectangle-aux-replace): Use `declare`.
* lisp/mh-e/mh-acros.el: Enable lexical-binding.
(mh-do-in-gnu-emacs, mh-do-in-xemacs, mh-funcall-if-exists, defun-mh)
(defmacro-mh, with-mh-folder-updating, mh-in-show-buffer)
(mh-do-at-event-location, mh-iterate-on-messages-in-region)
(mh-iterate-on-range): Use `declare`.
* lisp/mh-e/mh-compat.el: Enable lexical-binding.
(mh-flet): Use `declare`.
* lisp/mh-e/mh-e.el: Enable lexical-binding.
(defgroup-mh, defcustom-mh, defface-mh): Use `declare`.
* lisp/net/sieve.el: Enable lexical-binding. Remove redundant :group args.
(sieve-activate, sieve-remove, sieve-edit-script): Remove unused arg
from the interactive spec.
(sieve-deactivate-all): Remove unused var `name`.
(sieve-change-region): Use `declare`.
* lisp/obsolete/fast-lock.el: Enable lexical-binding.
Remove redundant :group args. Remove XEmacs compat code.
(save-buffer-state): Remove macro.
(fast-lock-add-properties): Use `with-silent-modifications` instead.
* lisp/obsolete/lazy-lock.el: Enable lexical-binding.
Remove redundant :group args.
(do-while): Use `declare`.
(save-buffer-state): Remove macro.
(lazy-lock-fontify-rest-after-change, lazy-lock-defer-line-after-change)
(lazy-lock-defer-rest-after-change, lazy-lock-after-fontify-buffer)
(lazy-lock-after-unfontify-buffer, lazy-lock-fontify-region):
Use `with-silent-modifications` instead.
* lisp/obsolete/pgg.el: Enable lexical-binding. Remove XEmacs compat code.
(pgg-save-coding-system, pgg-as-lbt, pgg-process-when-success):
Use `declare`.
(pgg-add-passphrase-to-cache): Remove unused var `new-timer`.
(pgg-decrypt-region): Remove unused var `buf`.
* lisp/org/org-agenda.el (org-let, org-let2): Move from org-macs and
use `declare`.
* lisp/org/org-macs.el (org-let, org-let2): Move these functions that
are inherently harmful to your karma to the only package that uses them.
(org-scroll): Use `pcase` to avoid `eval` and use more readable syntax
for those integers standing for events.
* lisp/progmodes/antlr-mode.el: Enable lexical-binding.
(save-buffer-state-x): Use `declare` and `with-silent-modifications`.
* lisp/international/mule-util.el (with-coding-priority):
* lisp/cedet/ede/proj-comp.el (proj-comp-insert-variable-once):
* lisp/org/org-element.el (org-element-map):
* test/lisp/emacs-lisp/bytecomp-tests.el (test-byte-comp-compile-and-load):
* test/lisp/emacs-lisp/generator-tests.el (cps-testcase): Use `declare`.
2021-02-22 11:54:17 -05:00
|
|
|
|
(declare (indent 1) (debug t))
|
2003-09-08 12:53:41 +00:00
|
|
|
|
(let ((current (make-symbol "current")))
|
|
|
|
|
`(let ((,current (coding-system-priority-list)))
|
|
|
|
|
(apply #'set-coding-system-priority ,coding-systems)
|
|
|
|
|
(unwind-protect
|
|
|
|
|
(progn ,@body)
|
|
|
|
|
(apply #'set-coding-system-priority ,current)))))
|
|
|
|
|
|
1998-01-22 01:42:20 +00:00
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun detect-coding-with-language-environment (from to lang-env)
|
2003-09-11 09:51:13 +00:00
|
|
|
|
"Detect a coding system for the text between FROM and TO with LANG-ENV.
|
1998-09-06 14:31:49 +00:00
|
|
|
|
The detection takes into account the coding system priorities for the
|
1998-01-22 01:42:20 +00:00
|
|
|
|
language environment LANG-ENV."
|
|
|
|
|
(let ((coding-priority (get-language-info lang-env 'coding-priority)))
|
|
|
|
|
(if coding-priority
|
2002-05-26 22:42:00 +00:00
|
|
|
|
(with-coding-priority coding-priority
|
|
|
|
|
(detect-coding-region from to)))))
|
1997-10-23 12:05:45 +00:00
|
|
|
|
|
2016-01-12 20:49:34 -05:00
|
|
|
|
(declare-function internal-char-font "font.c" (position &optional ch))
|
2008-06-12 03:56:20 +00:00
|
|
|
|
|
2015-06-16 14:28:38 -04:00
|
|
|
|
(defun filepos-to-bufferpos--dos (byte f)
|
|
|
|
|
(let ((eol-offset 0)
|
|
|
|
|
;; Make sure we terminate, even if BYTE falls right in the middle
|
|
|
|
|
;; of a CRLF or some other weird corner case.
|
2018-08-22 20:45:47 -07:00
|
|
|
|
(omin 0) omax
|
2015-06-16 14:28:38 -04:00
|
|
|
|
pos lines)
|
|
|
|
|
(while
|
|
|
|
|
(progn
|
|
|
|
|
(setq pos (funcall f (- byte eol-offset)))
|
2015-06-18 15:06:53 +03:00
|
|
|
|
;; Protect against accidental values of BYTE outside of the
|
|
|
|
|
;; valid region.
|
|
|
|
|
(when (null pos)
|
|
|
|
|
(if (<= byte eol-offset)
|
|
|
|
|
(setq pos (point-min))
|
|
|
|
|
(setq pos (point-max))))
|
2015-06-16 14:28:38 -04:00
|
|
|
|
;; Adjust POS for DOS EOL format.
|
|
|
|
|
(setq lines (1- (line-number-at-pos pos)))
|
2018-08-22 20:45:47 -07:00
|
|
|
|
(and (not (= lines eol-offset)) (or (not omax) (> omax omin))))
|
2015-06-16 14:28:38 -04:00
|
|
|
|
(if (> lines eol-offset)
|
2018-08-22 20:45:47 -07:00
|
|
|
|
(setq omax (if omax (min (1- omax) lines) lines)
|
2015-06-16 14:28:38 -04:00
|
|
|
|
eol-offset omax)
|
|
|
|
|
(setq omin (max (1+ omin) lines)
|
|
|
|
|
eol-offset omin)))
|
|
|
|
|
pos))
|
|
|
|
|
|
2015-06-15 18:48:08 -04:00
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun filepos-to-bufferpos (byte &optional quality coding-system)
|
|
|
|
|
"Try to return the buffer position corresponding to a particular file position.
|
|
|
|
|
The file position is given as a (0-based) BYTE count.
|
|
|
|
|
The function presumes the file is encoded with CODING-SYSTEM, which defaults
|
|
|
|
|
to `buffer-file-coding-system'.
|
|
|
|
|
QUALITY can be:
|
|
|
|
|
`approximate', in which case we may cut some corners to avoid
|
|
|
|
|
excessive work.
|
2015-06-16 14:28:38 -04:00
|
|
|
|
`exact', in which case we may end up re-(en/de)coding a large
|
2021-08-13 13:06:33 +02:00
|
|
|
|
part of the file/buffer, this can be expensive and slow. (It
|
|
|
|
|
is an error to request the `exact' method when the buffer's
|
|
|
|
|
EOL format is not yet decided.)
|
2015-06-15 18:48:08 -04:00
|
|
|
|
nil, in which case we may return nil rather than an approximation."
|
|
|
|
|
(unless coding-system (setq coding-system buffer-file-coding-system))
|
|
|
|
|
(let ((eol (coding-system-eol-type coding-system))
|
|
|
|
|
(type (coding-system-type coding-system))
|
2015-06-18 15:06:53 +03:00
|
|
|
|
(base (coding-system-base coding-system))
|
2015-06-15 18:48:08 -04:00
|
|
|
|
(pm (save-restriction (widen) (point-min))))
|
2021-08-13 13:06:33 +02:00
|
|
|
|
;; Handle EOL edge cases.
|
|
|
|
|
(unless (numberp eol)
|
|
|
|
|
(if (eq quality 'exact)
|
|
|
|
|
(error "Unknown EOL format in coding system: %s" coding-system)
|
|
|
|
|
(setq eol 0)))
|
2015-06-18 15:06:53 +03:00
|
|
|
|
(and (eq type 'utf-8)
|
|
|
|
|
;; Any post-read/pre-write conversions mean it's not really UTF-8.
|
2015-06-19 10:51:22 -04:00
|
|
|
|
(not (null (coding-system-get coding-system :post-read-conversion)))
|
2015-06-18 15:06:53 +03:00
|
|
|
|
(setq type 'not-utf-8))
|
|
|
|
|
(and (memq type '(charset raw-text undecided))
|
|
|
|
|
;; The following are all of type 'charset', but they are
|
|
|
|
|
;; actually variable-width encodings.
|
|
|
|
|
(not (memq base '(chinese-gbk chinese-gb18030 euc-tw euc-jis-2004
|
|
|
|
|
korean-iso-8bit chinese-iso-8bit
|
|
|
|
|
japanese-iso-8bit chinese-big5-hkscs
|
|
|
|
|
japanese-cp932 korean-cp949)))
|
|
|
|
|
(setq type 'single-byte))
|
2015-06-15 18:48:08 -04:00
|
|
|
|
(pcase type
|
2018-11-05 01:22:15 +01:00
|
|
|
|
('utf-8
|
2015-06-15 18:48:08 -04:00
|
|
|
|
(when (coding-system-get coding-system :bom)
|
|
|
|
|
(setq byte (max 0 (- byte 3))))
|
2015-06-16 14:28:38 -04:00
|
|
|
|
(if (= eol 1)
|
|
|
|
|
(filepos-to-bufferpos--dos (+ pm byte) #'byte-to-position)
|
|
|
|
|
(byte-to-position (+ pm byte))))
|
2018-11-05 01:22:15 +01:00
|
|
|
|
('single-byte
|
2015-06-19 10:51:22 -04:00
|
|
|
|
(if (= eol 1)
|
|
|
|
|
(filepos-to-bufferpos--dos (+ pm byte) #'identity)
|
|
|
|
|
(+ pm byte)))
|
2018-11-05 01:22:15 +01:00
|
|
|
|
((and 'utf-16
|
2015-06-19 10:51:22 -04:00
|
|
|
|
;; FIXME: For utf-16, we could use the same approach as used for
|
|
|
|
|
;; dos EOLs (counting the number of non-BMP chars instead of the
|
|
|
|
|
;; number of lines).
|
|
|
|
|
(guard (not (eq quality 'exact))))
|
2015-06-18 15:06:53 +03:00
|
|
|
|
;; Account for BOM, which is always 2 bytes in UTF-16.
|
2015-06-19 11:19:06 +03:00
|
|
|
|
(when (coding-system-get coding-system :bom)
|
2015-06-19 10:51:22 -04:00
|
|
|
|
(setq byte (max 0 (- byte 2))))
|
2015-06-18 15:06:53 +03:00
|
|
|
|
;; In approximate mode, assume all characters are within the
|
|
|
|
|
;; BMP, i.e. take up 2 bytes.
|
|
|
|
|
(setq byte (/ byte 2))
|
2015-06-16 14:28:38 -04:00
|
|
|
|
(if (= eol 1)
|
|
|
|
|
(filepos-to-bufferpos--dos (+ pm byte) #'identity)
|
|
|
|
|
(+ pm byte)))
|
2015-06-15 18:48:08 -04:00
|
|
|
|
(_
|
|
|
|
|
(pcase quality
|
2018-11-05 01:22:15 +01:00
|
|
|
|
('approximate (byte-to-position (+ pm byte)))
|
|
|
|
|
('exact
|
2015-06-16 14:28:38 -04:00
|
|
|
|
;; Rather than assume that the file exists and still holds the right
|
|
|
|
|
;; data, we reconstruct it based on the buffer's content.
|
|
|
|
|
(let ((buf (current-buffer)))
|
|
|
|
|
(with-temp-buffer
|
|
|
|
|
(set-buffer-multibyte nil)
|
|
|
|
|
(let ((tmp-buf (current-buffer)))
|
|
|
|
|
(with-current-buffer buf
|
|
|
|
|
(save-restriction
|
|
|
|
|
(widen)
|
|
|
|
|
;; Since encoding should always return more bytes than
|
|
|
|
|
;; there were chars, encoding all chars up to (+ byte pm)
|
|
|
|
|
;; guarantees the encoded result has at least `byte' bytes.
|
|
|
|
|
(encode-coding-region pm (min (point-max) (+ pm byte))
|
|
|
|
|
coding-system tmp-buf)))
|
|
|
|
|
(+ pm (length
|
|
|
|
|
(decode-coding-region (point-min)
|
|
|
|
|
(min (point-max) (+ pm byte))
|
|
|
|
|
coding-system t))))))))))))
|
2015-07-18 13:23:22 +03:00
|
|
|
|
;;;###autoload
|
|
|
|
|
(defun bufferpos-to-filepos (position &optional quality coding-system)
|
|
|
|
|
"Try to return the file byte corresponding to a particular buffer POSITION.
|
|
|
|
|
Value is the file position given as a (0-based) byte count.
|
|
|
|
|
The function presumes the file is encoded with CODING-SYSTEM, which defaults
|
|
|
|
|
to `buffer-file-coding-system'.
|
|
|
|
|
QUALITY can be:
|
|
|
|
|
`approximate', in which case we may cut some corners to avoid
|
|
|
|
|
excessive work.
|
|
|
|
|
`exact', in which case we may end up re-(en/de)coding a large
|
2021-08-13 13:06:33 +02:00
|
|
|
|
part of the file/buffer, this can be expensive and slow. (It
|
|
|
|
|
is an error to request the `exact' method when the buffer's
|
|
|
|
|
EOL format is not yet decided.)
|
2015-07-18 13:23:22 +03:00
|
|
|
|
nil, in which case we may return nil rather than an approximation."
|
|
|
|
|
(unless coding-system (setq coding-system buffer-file-coding-system))
|
|
|
|
|
(let* ((eol (coding-system-eol-type coding-system))
|
|
|
|
|
(type (coding-system-type coding-system))
|
|
|
|
|
(base (coding-system-base coding-system))
|
2021-08-13 13:06:33 +02:00
|
|
|
|
(point-min 1) ;Clarify what the `1' means.
|
|
|
|
|
lineno)
|
|
|
|
|
;; Handle EOL edge cases.
|
|
|
|
|
(unless (numberp eol)
|
|
|
|
|
(if (eq quality 'exact)
|
|
|
|
|
(error "Unknown EOL format in coding system: %s" coding-system)
|
|
|
|
|
(setq eol 0)))
|
|
|
|
|
(setq lineno (if (= eol 1)
|
|
|
|
|
(1- (line-number-at-pos position))
|
|
|
|
|
0))
|
2015-07-18 13:23:22 +03:00
|
|
|
|
(and (eq type 'utf-8)
|
|
|
|
|
;; Any post-read/pre-write conversions mean it's not really UTF-8.
|
|
|
|
|
(not (null (coding-system-get coding-system :post-read-conversion)))
|
|
|
|
|
(setq type 'not-utf-8))
|
|
|
|
|
(and (memq type '(charset raw-text undecided))
|
|
|
|
|
;; The following are all of type 'charset', but they are
|
|
|
|
|
;; actually variable-width encodings.
|
|
|
|
|
(not (memq base '(chinese-gbk chinese-gb18030 euc-tw euc-jis-2004
|
|
|
|
|
korean-iso-8bit chinese-iso-8bit
|
|
|
|
|
japanese-iso-8bit chinese-big5-hkscs
|
|
|
|
|
japanese-cp932 korean-cp949)))
|
|
|
|
|
(setq type 'single-byte))
|
|
|
|
|
(pcase type
|
2018-11-05 01:22:15 +01:00
|
|
|
|
('utf-8
|
2019-04-29 16:32:52 -04:00
|
|
|
|
(+ (or (position-bytes position)
|
|
|
|
|
(if (<= position 0)
|
|
|
|
|
point-min
|
|
|
|
|
(position-bytes (point-max))))
|
2015-07-18 13:23:22 +03:00
|
|
|
|
;; Account for BOM, if any.
|
|
|
|
|
(if (coding-system-get coding-system :bom) 3 0)
|
|
|
|
|
;; Account for CR in CRLF pairs.
|
2019-04-29 16:32:52 -04:00
|
|
|
|
lineno
|
|
|
|
|
(- point-min)))
|
2018-11-05 01:22:15 +01:00
|
|
|
|
('single-byte
|
2019-04-29 16:32:52 -04:00
|
|
|
|
(+ position (- point-min) lineno))
|
2018-11-05 01:22:15 +01:00
|
|
|
|
((and 'utf-16
|
2015-07-18 13:23:22 +03:00
|
|
|
|
;; FIXME: For utf-16, we could use the same approach as used for
|
|
|
|
|
;; dos EOLs (counting the number of non-BMP chars instead of the
|
|
|
|
|
;; number of lines).
|
|
|
|
|
(guard (not (eq quality 'exact))))
|
|
|
|
|
;; In approximate mode, assume all characters are within the
|
|
|
|
|
;; BMP, i.e. each one takes up 2 bytes.
|
2019-04-29 16:32:52 -04:00
|
|
|
|
(+ (* (- position point-min) 2)
|
2015-07-18 13:23:22 +03:00
|
|
|
|
;; Account for BOM, if any.
|
|
|
|
|
(if (coding-system-get coding-system :bom) 2 0)
|
|
|
|
|
;; Account for CR in CRLF pairs.
|
|
|
|
|
lineno))
|
|
|
|
|
(_
|
|
|
|
|
(pcase quality
|
2019-04-29 16:32:52 -04:00
|
|
|
|
('approximate (+ (position-bytes position) (- point-min) lineno))
|
2018-11-05 01:22:15 +01:00
|
|
|
|
('exact
|
2015-07-18 13:23:22 +03:00
|
|
|
|
;; Rather than assume that the file exists and still holds the right
|
|
|
|
|
;; data, we reconstruct its relevant portion.
|
|
|
|
|
(let ((buf (current-buffer)))
|
|
|
|
|
(with-temp-buffer
|
|
|
|
|
(set-buffer-multibyte nil)
|
|
|
|
|
(let ((tmp-buf (current-buffer)))
|
|
|
|
|
(with-current-buffer buf
|
|
|
|
|
(save-restriction
|
|
|
|
|
(widen)
|
|
|
|
|
(encode-coding-region (point-min) (min (point-max) position)
|
|
|
|
|
coding-system tmp-buf)))
|
2019-04-29 16:32:52 -04:00
|
|
|
|
(buffer-size))))))))))
|
1997-02-20 07:02:49 +00:00
|
|
|
|
|
2000-04-01 12:03:57 +00:00
|
|
|
|
(provide 'mule-util)
|
1999-12-15 00:42:14 +00:00
|
|
|
|
|
2002-05-21 21:22:21 +00:00
|
|
|
|
;; Local Variables:
|
Use UTF-8 for most files with non-ASCII characters.
* admin/notes/unicode (etc/tutorials/TUTORIAL.ko, leim/quail/hanja.el)
(leim/quail/hanja3.el, leim/quail/symbol-ksc.el):
Now utf-8, not iso-2022-7bit. Also, files that contain non-UTF-8
characters are now encoded in utf-8-emacs, not iso-2022-7bit.
* etc/tutorials/TUTORIAL.ko, tutorials/TUTORIAL.th:
Switch from iso-2022-7bit to utf-8.
* leim/quail/cyrillic.el, leim/quail/czech.el, leim/quail/ethiopic.el:
* leim/quail/greek.el, leim/quail/hanja.el, leim/quail/hanja3.el:
* leim/quail/hebrew.el, leim/quail/lao.el, leim/quail/lrt.el:
* leim/quail/slovak.el, leim/quail/symbol-ksc.el, leim/quail/thai.el:
* leim/quail/tibetan.el, leim/quail/viqr.el, leim/quail/vntelex.el:
* leim/quail/vnvni.el, leim/quail/welsh.el:
* lisp/international/latin1-disp.el, lisp/international/mule-util.el:
* lisp/language/cyril-util.el, lisp/language/european.el:
* lisp/language/ind-util.el, lisp/language/lao-util.el, lisp/language/thai.el:
* lisp/language/tibet-util.el, lisp/language/tibetan.el:
* lisp/language/viet-util.el:
Switch from iso-2022-7bit to utf-8 or (if needed) utf-8-emacs.
Fixes: debbugs:13936
2013-04-01 18:18:40 -07:00
|
|
|
|
;; coding: utf-8
|
2002-05-21 21:22:21 +00:00
|
|
|
|
;; End:
|
|
|
|
|
|
2000-04-01 12:03:57 +00:00
|
|
|
|
;;; mule-util.el ends here
|