[bpt/emacs.git] / lisp / international / mule-util.el

;;; mule-util.el --- utility functions for mulitilingual environment (mule)

;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004,
;;   2005, 2006, 2007  Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;;   2005, 2006, 2007
;;   National Institute of Advanced Industrial Science and Technology (AIST)
;;   Registration Number H14PRO021

;; Keywords: mule, multilingual

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; 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
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;;; Code:

;;; String manipulations while paying attention to multibyte
;;; characters.

;;;###autoload
(defun string-to-sequence (string type)
  "Convert STRING to a sequence of TYPE which contains characters in STRING.
TYPE should be `list' or `vector'."
;;;  (let ((len (length string))
;;;	   (i 0)
;;;	   val)
    (cond ((eq type 'list)
	   ;; Applicable post-Emacs 20.2 and asymptotically ~10 times
	   ;; faster than the code below:
	   (append string nil))
;;; 	   (setq val (make-list len 0))
;;; 	   (let ((l val))
;;; 	     (while (< i len)
;;; 	       (setcar l (aref string i))
;;; 	       (setq l (cdr l) i (1+ i))))))
	  ((eq type 'vector)
	   ;; As above.
	   (vconcat string))
;;; 	   (setq val (make-vector len 0))
;;; 	   (while (< i len)
;;; 	     (aset val i (aref string i))
;;; 	     (setq i (1+ i))))
	  (t
	   (error "Invalid type: %s" type)))
;;;    val)
)

;;;###autoload
(make-obsolete 'string-to-sequence
	       "use `string-to-list' or `string-to-vector'."
	       "22.1")

;;;###autoload
(defsubst string-to-list (string)
  "Return a list of characters in STRING."
  (append string nil))

;;;###autoload
(defsubst string-to-vector (string)
  "Return a vector of characters in STRING."
  (vconcat string))

;;;###autoload
(defun store-substring (string idx obj)
  "Embed OBJ (string or character) at index IDX of STRING."
  (if (integerp obj)
      (aset string idx obj)
    (let ((len1 (length obj))
	  (len2 (length string))
	  (i 0))
      (while (< i len1)
	(aset string (+ idx i) (aref obj i))
	(setq i (1+ i)))))
  string)

;;;###autoload
(defun truncate-string-to-width (str end-column
				     &optional start-column padding ellipsis)
  "Truncate string STR to end at column END-COLUMN.
The optional 3rd arg START-COLUMN, if non-nil, specifies the starting
column; 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 also `char-width'.

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.

If PADDING is nil, no padding is added in these cases, so
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
defaults to \"...\"."
  (or start-column
      (setq start-column 0))
  (when (and ellipsis (not (stringp ellipsis)))
    (setq ellipsis "..."))
  (let ((str-len (length str))
	(str-width (string-width str))
	(ellipsis-len (if ellipsis (length ellipsis) 0))
	(ellipsis-width (if ellipsis (string-width ellipsis) 0))
	(idx 0)
	(column 0)
	(head-padding "") (tail-padding "")
	ch last-column last-idx from-idx)
    (condition-case nil
	(while (< column start-column)
	  (setq ch (aref str idx)
		column (+ column (char-width ch))
		idx (1+ idx)))
      (args-out-of-range (setq idx str-len)))
    (if (< column start-column)
	(if padding (make-string end-column padding) "")
      (when (and padding (> column start-column))
	(setq head-padding (make-string (- column start-column) padding)))
      (setq from-idx idx)
      (when (>= end-column column)
	(if (and (< end-column str-width)
		 (> str-width ellipsis-width))
	    (setq end-column (- end-column ellipsis-width))
	  (setq ellipsis ""))
	(condition-case nil
	    (while (< column end-column)
	      (setq last-column column
		    last-idx idx
		    ch (aref str idx)
		    column (+ column (char-width ch))
		    idx (1+ idx)))
	  (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))))
      (concat head-padding (substring str from-idx idx)
	      tail-padding ellipsis))))

;;; Test suite for truncate-string-to-width
;; (dolist (test '((("" 0) . "")
;; 		(("x" 1) . "x")
;; 		(("xy" 1) . "x")
;; 		(("xy" 2 1) . "y")
;; 		(("xy" 0) . "")
;; 		(("xy" 3) . "xy")
;; 		(("\e$AVP\e(B" 0) . "")
;; 		(("\e$AVP\e(B" 1) . "")
;; 		(("\e$AVP\e(B" 2) . "\e$AVP\e(B")
;; 		(("\e$AVP\e(B" 1 nil ? ) . " ")
;; 		(("\e$AVPND\e(B" 3 1 ? ) . "  ")
;; 		(("x\e$AVP\e(Bx" 2) . "x")
;; 		(("x\e$AVP\e(Bx" 3) . "x\e$AVP\e(B")
;; 		(("x\e$AVP\e(Bx" 3) . "x\e$AVP\e(B")
;; 		(("x\e$AVP\e(Bx" 4 1) . "\e$AVP\e(Bx")
;; 		(("kor\e$(CGQ\e(Be\e$(C1[\e(Ban" 8 1 ? ) . "or\e$(CGQ\e(Be\e$(C1[\e(B")
;; 		(("kor\e$(CGQ\e(Be\e$(C1[\e(Ban" 7 2 ? ) . "r\e$(CGQ\e(Be ")
;; 		(("" 0 nil nil "...") . "")
;; 		(("x" 3 nil nil "...") . "x")
;; 		(("\e$AVP\e(B" 3 nil nil "...") . "\e$AVP\e(B")
;; 		(("foo" 3 nil nil "...") . "foo")
;; 		(("foo" 2 nil nil "...") . "fo") ;; XEmacs failure?
;; 		(("foobar" 6 0 nil "...") . "foobar")
;; 		(("foobarbaz" 6 nil nil "...") . "foo...")
;; 		(("foobarbaz" 7 2 nil "...") . "ob...")
;; 		(("foobarbaz" 9 3 nil "...") . "barbaz")
;; 		(("\e$B$3\e(Bh\e$B$s\e(Be\e$B$K\e(Bl\e$B$A\e(Bl\e$B$O\e(Bo" 15 1 ?  t) . " h\e$B$s\e(Be\e$B$K\e(Bl\e$B$A\e(Bl\e$B$O\e(Bo")
;; 		(("\e$B$3\e(Bh\e$B$s\e(Be\e$B$K\e(Bl\e$B$A\e(Bl\e$B$O\e(Bo" 14 1 ?  t) . " h\e$B$s\e(Be\e$B$K\e(Bl\e$B$A\e(B...")
;; 		(("x" 3 nil nil "\e$(0GnM$\e(B") . "x")
;; 		(("\e$AVP\e(B" 2 nil nil "\e$(0GnM$\e(B") . "\e$AVP\e(B")
;; 		(("\e$AVP\e(B" 1 nil ?x "\e$(0GnM$\e(B") . "x") ;; XEmacs error
;; 		(("\e$AVPND\e(B" 3 nil ?  "\e$(0GnM$\e(B") . "\e$AVP\e(B ") ;; XEmacs error
;; 		(("foobarbaz" 4 nil nil  "\e$(0GnM$\e(B") . "\e$(0GnM$\e(B")
;; 		(("foobarbaz" 5 nil nil  "\e$(0GnM$\e(B") . "f\e$(0GnM$\e(B")
;; 		(("foobarbaz" 6 nil nil  "\e$(0GnM$\e(B") . "fo\e$(0GnM$\e(B")
;; 		(("foobarbaz" 8 3 nil "\e$(0GnM$\e(B") . "b\e$(0GnM$\e(B")
;; 		(("\e$B$3\e(Bh\e$B$s\e(Be\e$B$K\e(Bl\e$B$A\e(Bl\e$B$O\e(Bo" 14 4 ?x "\e$BF|K\8l\e(B") . "xe\e$B$KF|K\8l\e(B")
;; 		(("\e$B$3\e(Bh\e$B$s\e(Be\e$B$K\e(Bl\e$B$A\e(Bl\e$B$O\e(Bo" 13 4 ?x "\e$BF|K\8l\e(B") . "xex\e$BF|K\8l\e(B")
;; 		))
;;   (let (ret)
;;     (condition-case e
;; 	(setq ret (apply #'truncate-string-to-width (car test)))
;;       (error (setq ret e)))
;;     (unless (equal ret (cdr test))
;;       (error "%s: expected %s, got %s"
;; 	     (prin1-to-string (cons 'truncate-string-to-width (car test)))
;; 	     (prin1-to-string (cdr test))
;; 	     (if (consp ret)
;; 		 (format "error: %s: %s" (car ret)
;; 			 (prin1-to-string (cdr ret)))
;; 	       (prin1-to-string ret))))))

\f
;;; Nested alist handler.  Nested alist is alist whose elements are
;;; also nested alist.

;;;###autoload
(defsubst nested-alist-p (obj)
  "Return t if OBJ is a nested alist.

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
\(KEY-ELEMENT . NESTED-ALIST).

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.
Optional 4th arg LEN non-nil means the first LEN elements in KEYSEQ
 is considered.
Optional argument BRANCHES if non-nil is branches for a keyseq
longer than KEYSEQ.
See the documentation of `nested-alist-p' for more detail."
  (or (nested-alist-p alist)
      (error "Invalid argument %s" alist))
  (let ((islist (listp keyseq))
	(len (or len (length keyseq)))
	(i 0)
	key-elt slot)
    (while (< i len)
      (if (null (nested-alist-p alist))
	  (error "Keyseq %s is too long for this nested alist" keyseq))
      (setq key-elt (if islist (nth i keyseq) (aref keyseq i)))
      (setq slot (assoc key-elt (cdr alist)))
      (if (null slot)
	  (progn
	    (setq slot (cons key-elt (list t)))
	    (setcdr alist (cons slot (cdr alist)))))
      (setq alist (cdr slot))
      (setq i (1+ i)))
    (setcar alist entry)
    (if branches
	(setcdr (last alist) branches))))

;;;###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.
Optional 1st argument LEN specifies the length of KEYSEQ.
Optional 2nd argument START specifies index of the starting key.
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.
Optional 3rd argument NIL-FOR-TOO-LONG non-nil means return nil
 even if ALIST is not deep enough."
  (or (nested-alist-p alist)
      (error "Invalid argument %s" alist))
  (or len
      (setq len (length keyseq)))
  (let ((i (or start 0)))
    (if (catch 'lookup-nested-alist-tag
	  (if (listp keyseq)
	      (while (< i len)
		(if (setq alist (cdr (assoc (nth i keyseq) (cdr alist))))
		    (setq i (1+ i))
		  (throw 'lookup-nested-alist-tag t))))
	  (while (< i len)
	    (if (setq alist (cdr (assoc (aref keyseq i) (cdr alist))))
		(setq i (1+ i))
	      (throw 'lookup-nested-alist-tag t))))
	;; KEYSEQ is too long.
	(if nil-for-too-long nil i)
      alist)))

\f
;; Coding system related functions.

;;;###autoload
(defun coding-system-post-read-conversion (coding-system)
  "Return the value of CODING-SYSTEM's `post-read-conversion' property."
  (coding-system-get coding-system 'post-read-conversion))

;;;###autoload
(defun coding-system-pre-write-conversion (coding-system)
  "Return the value of CODING-SYSTEM's `pre-write-conversion' property."
  (coding-system-get coding-system 'pre-write-conversion))

;;;###autoload
(defun coding-system-translation-table-for-decode (coding-system)
  "Return the value of CODING-SYSTEM's `translation-table-for-decode' property."
  (coding-system-get coding-system 'translation-table-for-decode))

;;;###autoload
(defun coding-system-translation-table-for-encode (coding-system)
  "Return the value of CODING-SYSTEM's `translation-table-for-encode' property."
  (coding-system-get coding-system 'translation-table-for-encode))

;;;###autoload
(defmacro detect-coding-with-priority (from to priority-list)
  "Detect a coding system of the text between FROM and TO with PRIORITY-LIST.
PRIORITY-LIST is an alist of coding categories vs the corresponding
coding systems ordered by priority."
  `(unwind-protect
       (let* ((prio-list ,priority-list)
	      (coding-category-list coding-category-list)
	      ,@(mapcar (function (lambda (x) (list x x)))
			coding-category-list))
	 (mapc (function (lambda (x) (set (car x) (cdr x))))
	       prio-list)
	 (set-coding-priority (mapcar #'car prio-list))
	 ;; Changing the binding of a coding category requires this call.
	 (update-coding-systems-internal)
	 (detect-coding-region ,from ,to))
     ;; We must restore the internal database.
     (set-coding-priority coding-category-list)
     (update-coding-systems-internal)))

;;;###autoload
(defun detect-coding-with-language-environment (from to lang-env)
  "Detect a coding system of the text between FROM and TO with LANG-ENV.
The detection takes into account the coding system priorities for the
language environment LANG-ENV."
  (let ((coding-priority (get-language-info lang-env 'coding-priority)))
    (if coding-priority
	(detect-coding-with-priority
	 from to
	 (mapcar (function (lambda (x)
			     (cons (coding-system-get x 'coding-category) x)))
		 coding-priority))
      (detect-coding-region from to))))

;;;###autoload
(defun char-displayable-p (char)
  "Return non-nil if we should be able to display CHAR.
On a multi-font display, the test is only whether there is an
appropriate font from the selected frame's fontset to display CHAR's
charset in general.  Since fonts may be specified on a per-character
basis, this may not be accurate."
  (cond ((< char 256)
	 ;; Single byte characters are always displayable.
	 t)
	((not enable-multibyte-characters)
	 ;; Maybe there's a font for it, but we can't put it in the buffer.
	 nil)
	((display-multi-font-p)
	 ;; On a window system, a character is displayable if we have
	 ;; a font for that character in the default face of the
	 ;; currently selected frame.
	 (car (internal-char-font nil char)))
	(t
	 (let ((coding (terminal-coding-system)))
	   (if coding
	       (let ((safe-chars (coding-system-get coding 'safe-chars))
		     (safe-charsets (coding-system-get coding 'safe-charsets)))
		 (or (and safe-chars
			  (aref safe-chars char))
		     (and safe-charsets
			  (memq (char-charset char) safe-charsets)))))))))
\f
(provide 'mule-util)

;; Local Variables:
;; coding: iso-2022-7bit
;; End:

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