1 ;; mule-misc.el --- Miscellaneous Mule functions.
3 ;; Copyright (C) 1995,1999 Electrotechnical Laboratory, JAPAN.
4 ;; Licensed to the Free Software Foundation.
5 ;; Copyright (C) 1992,93,94,95 Free Software Foundation, Inc.
6 ;; Copyright (C) 1995 Amdahl Corporation.
7 ;; Copyright (C) 1995 Sun Microsystems.
9 ;; This file is part of XEmacs.
11 ;; XEmacs is free software; you can redistribute it and/or modify it
12 ;; under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; XEmacs is distributed in the hope that it will be useful, but
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with XEmacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
27 ;;; protect specified local variables from kill-all-local-variables
30 (defvar self-insert-after-hook nil
31 "Hook to run when extended self insertion command exits. Should take
32 two arguments START and END corresponding to character position.")
34 (make-variable-buffer-local 'self-insert-after-hook)
36 (defun toggle-display-direction ()
38 (setq display-direction (not display-direction))
39 (if (interactive-p) (redraw-display)))
42 ;;; Utility functions for Mule
45 ;(defun string-to-char-list (str)
46 ; (let ((len (length str))
50 ; (setq c (sref str idx))
51 ; (setq idx (+ idx (charset-dimension (char-charset c))))
52 ; (setq l (cons c l)))
55 (defun string-to-char-list (str)
56 (mapcar 'identity str))
58 (defun string-width (string)
59 "Return number of columns STRING occupies when displayed.
60 Uses the charset-columns attribute of the characters in STRING,
61 which may not accurately represent the actual display width when
62 using a window system."
67 (setq col (+ col (charset-width (char-charset (aref string i)))))
71 (defalias 'string-columns 'string-width)
72 (make-obsolete 'string-columns 'string-width)
74 (defun delete-text-in-column (from to)
75 "Delete the text between column FROM and TO (exclusive) of the current line.
76 Nil of FORM or TO means the current column.
78 If there's a character across the borders, the character is replaced
79 with the same width of spaces before deleting."
84 (setq p1 (move-to-column from))
88 (insert-char ? (- p1 (current-column)))
89 (forward-char (- from p1))))))
93 (setq p2 (move-to-column to))
97 (insert-char ? (- p2 (current-column)))
98 (forward-char (- to p2))))))
100 (delete-region p1 p2))))
102 ;; #### Someone translate this!!
104 (defun mc-normal-form-string (str)
105 "
\e$BJ8;zNs
\e(B STR
\e$B$N4A;zI8=`7AJ8;zNs$rJV$9!%
\e(B"
107 (while (setq i (string-match "\n" str i))
108 (if (and (<= 1 i) (< i (1- (length str)))
109 (< (aref str (1- i)) 128)
110 (< (aref str (1+ i)) 128))
113 (if (string-match "\n" str 0)
114 (let ((c 0) (i 0) new)
115 (while (setq i (string-match "\n" str i))
118 (setq new (make-string (- (length str) c) 0))
120 (while (< i (length str))
121 (cond((not (= (aref str i) ?\n ))
122 (aset new c (aref str i))
131 (defun string-memq (str list)
132 "Returns non-nil if STR is an element of LIST. Comparison done with string=.
133 The value is actually the tail of LIST whose car is STR.
134 If each element of LIST is not a string, it is converted to string
137 (while (and (not find) list)
138 (setq elm (car list))
139 (if (numberp elm) (setq elm (char-to-string elm)))
140 (if (string= str elm)
142 (setq list (cdr list))))
145 (defun cancel-undo-boundary ()
146 "Cancel undo boundary."
147 (if (and (consp buffer-undo-list)
149 (null (car buffer-undo-list)) )
150 (setq buffer-undo-list (cdr buffer-undo-list)) ))
153 ;;; Common API emulation functions for GNU Emacs-merged Mule.
154 ;;; As suggested by MORIOKA Tomohiko
156 ;; Following definition were imported from Emacs/mule-delta.
158 ;; Function `truncate-string-to-width' was moved to mule-util.el.
160 ;; end of imported definition
163 (defalias 'sref 'aref)
164 (defalias 'map-char-concat 'mapcar)
165 (defun char-bytes (character)
166 "Return number of length a CHARACTER occupies in a string or buffer.
167 It returns only 1 in XEmacs. It is for compatibility with MULE 2.3."
169 (defalias 'char-length 'char-bytes)
171 (defun char-width (character)
172 "Return number of columns a CHARACTER occupies when displayed."
173 (charset-width (char-charset character)))
175 (defalias 'char-columns 'char-width)
176 (make-obsolete 'char-columns 'char-width)
178 (defalias 'find-charset-string 'charsets-in-string)
179 (defalias 'find-charset-region 'charsets-in-region)
181 (defun find-non-ascii-charset-string (string)
182 "Return a list of charsets in the STRING except ascii.
183 It might be available for compatibility with Mule 2.3,
184 because its `find-charset-string' ignores ASCII charset."
185 (delq 'ascii (charsets-in-string string)))
187 (defun find-non-ascii-charset-region (start end)
188 "Return a list of charsets except ascii in the region between START and END.
189 It might be available for compatibility with Mule 2.3,
190 because its `find-charset-string' ignores ASCII charset."
191 (delq 'ascii (charsets-in-region start end)))
193 ;(defun split-char (char)
194 ; "Return list of charset and one or two position-codes of CHAR."
195 ; (let ((charset (char-charset char)))
196 ; (if (eq charset 'ascii)
197 ; (list charset (char-int char))
199 ; (len (charset-dimension charset))
200 ; (code (if (integerp char)
205 ; (setq dest (cons (logand code 127) dest)
208 ; (cons charset dest)
211 (defun char-octet (ch &optional n)
212 "Return the octet numbered N (should be 0 or 1) of char CH.
213 N defaults to 0 if omitted."
214 (let ((split (split-char ch)))
220 (t (error "n must be 0 or 1")))))
221 ;; Made obsolete June 15, 1999. Delete ASAP.
222 (make-obsolete 'char-octet "Use split-char")
224 ;(defun split-char-or-char-int (char)
225 ; "Return list of charset and one or two position-codes of CHAR.
226 ;CHAR must be character or integer."
227 ; (if (characterp char)
229 ; (let ((c (int-char char)))
238 (defun set-buffer-process-coding-system (decoding encoding)
239 "Set coding systems for the process associated with the current buffer.
240 DECODING is the coding system to be used to decode input from the process,
241 ENCODING is the coding system to be used to encode output to the process.
243 For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems]."
245 "zCoding-system for process input: \nzCoding-system for process output: ")
246 (let ((proc (get-buffer-process (current-buffer))))
249 (check-coding-system decoding)
250 (check-coding-system encoding)
251 (set-process-coding-system proc decoding encoding)))
252 (force-mode-line-update))
255 ;;; Language environments
257 ;; (defvar current-language-environment nil)
259 ;; (defvar language-environment-list nil)
261 ;; (defun current-language-environment ()
262 ;; "Return the current language environment as a symbol.
263 ;; Returns nil if `set-language-environment' has not been called."
264 ;; current-language-environment)
266 ;; (defun language-environment-list ()
267 ;; "Return a list of all currently defined language environments."
268 ;; language-environment-list)
270 ;; (defun language-environment-p (sym)
271 ;; "True if SYM names a defined language environment."
272 ;; (memq sym (language-environment-list)))
274 ;; (defun set-language-environment (env)
275 ;; "Set the current language environment to ENV."
277 ;; (list (intern (completing-read "Language environment: "
278 ;; obarray 'language-environment-p
279 ;; 'require-match))))
280 ;; (when (not (string= (charset-registry 'ascii) "iso8859-1"))
281 ;; (set-charset-registry 'ascii "iso8859-1"))
282 ;; (let ((func (get env 'set-lang-environ)))
283 ;; (if (not (null func))
285 ;; (setq current-language-environment env)
286 ;; (if (featurep 'egg)
287 ;; (egg-lang-switch-callback))
288 ;; ;; (if (featurep 'quail)
289 ;; ;; (quail-lang-switch-callback))
292 ;; (defun define-language-environment (env-sym doc-string enable-function)
293 ;; "Define a new language environment, named by ENV-SYM.
294 ;; DOC-STRING should be a string describing the environment.
295 ;; ENABLE-FUNCTION should be a function of no arguments that will be called
296 ;; when the language environment is made current."
297 ;; (put env-sym 'lang-environ-doc-string doc-string)
298 ;; (put env-sym 'set-lang-environ enable-function)
299 ;; (setq language-environment-list (cons env-sym language-environment-list)))
301 (defun define-egg-environment (env-sym doc-string enable-function)
302 "Define a new language environment for egg, named by ENV-SYM.
303 DOC-STRING should be a string describing the environment.
304 ENABLE-FUNCTION should be a function of no arguments that will be called
305 when the language environment is made current."
306 (put env-sym 'egg-environ-doc-string doc-string)
307 (put env-sym 'set-egg-environ enable-function))
309 ;; (defun define-quail-environment (env-sym doc-string enable-function)
310 ;; "Define a new language environment for quail, named by ENV-SYM.
311 ;; DOC-STRING should be a string describing the environment.
312 ;; ENABLE-FUNCTION should be a function of no arguments that will be called
313 ;; when the language environment is made current."
314 ;; (put env-sym 'quail-environ-doc-string doc-string)
315 ;; (put env-sym 'set-quail-environ enable-function))
318 ;;; @ coding-system category
321 (defun coding-system-get (coding-system prop)
322 "Extract a value from CODING-SYSTEM's property list for property PROP."
324 (get (coding-system-name coding-system) 'coding-system-property)
327 (coding-system-property coding-system prop)
330 (defun coding-system-put (coding-system prop val)
331 "Change value in CODING-SYSTEM's property list PROP to VAL."
332 (put (coding-system-name coding-system)
333 'coding-system-property
334 (plist-put (get (coding-system-name coding-system)
335 'coding-system-property)
338 (defun coding-system-category (coding-system)
339 "Return the coding category of CODING-SYSTEM."
340 (or (coding-system-get coding-system 'category)
341 (let ((type (coding-system-type coding-system)))
342 (cond ((eq type 'no-conversion)
344 ((eq type 'shift-jis)
353 (cond ((coding-system-lock-shift coding-system)
355 ((coding-system-seven coding-system)
362 (setq ccs (coding-system-charset coding-system i))
364 (> (charset-dimension ccs) dim))
365 (setq dim (charset-dimension ccs))
368 (cond ((= dim 1) 'iso-8-1)
370 (t 'iso-8-designate))
373 ;;; mule-misc.el ends here