Mercurial > hg > xemacs-beta

comparison lisp/mule/mule-misc.el @ 392:1f50e6fe4f3f r21-2-11

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-11
author cvs
date Mon, 13 Aug 2007 11:10:50 +0200
parents 4f79e16b1112
children 8e84bee8ddd0 74fd4e045ea6
comparison
equal deleted inserted replaced
391:e50d8e68d7a5 392:1f50e6fe4f3f
1 ;; mule-misc.el --- Miscellaneous Mule functions.
2
3 ;; Copyright (C) 1995 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.
8
9 ;; This file is part of XEmacs.
10
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)
14 ;; any later version.
15
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.
20
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.
25
26 ;;;
27 ;;; protect specified local variables from kill-all-local-variables
28 ;;;
29
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.")
33
34 (make-variable-buffer-local 'self-insert-after-hook)
35
36 (defun toggle-display-direction ()
37 (interactive)
38 (setq display-direction (not display-direction))
39 (if (interactive-p) (redraw-display)))
40
41 ;;;
42 ;;; Utility functions for Mule
43 ;;;
44
45 ;(defun string-to-char-list (str)
46 ; (let ((len (length str))
47 ; (idx 0)
48 ; c l)
49 ; (while (< idx len)
50 ; (setq c (sref str idx))
51 ; (setq idx (+ idx (charset-dimension (char-charset c))))
52 ; (setq l (cons c l)))
53 ; (nreverse l)))
54
55 (defun string-to-char-list (str)
56 (mapcar 'identity str))
57
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."
63 (let ((col 0)
64 (len (length string))
65 (i 0))
66 (while (< i len)
67 (setq col (+ col (charset-columns (char-charset (aref string i)))))
68 (setq i (1+ i)))
69 col))
70
71 (defalias 'string-columns 'string-width)
72 (make-obsolete 'string-columns 'string-width)
73
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.
77
78 If there's a character across the borders, the character is replaced
79 with the same width of spaces before deleting."
80 (save-excursion
81 (let (p1 p2)
82 (if from
83 (progn
84 (setq p1 (move-to-column from))
85 (if (> p1 from)
86 (progn
87 (delete-char -1)
88 (insert-char ? (- p1 (current-column)))
89 (forward-char (- from p1))))))
90 (setq p1 (point))
91 (if to
92 (progn
93 (setq p2 (move-to-column to))
94 (if (> p2 to)
95 (progn
96 (delete-char -1)
97 (insert-char ? (- p2 (current-column)))
98 (forward-char (- to p2))))))
99 (setq p2 (point))
100 (delete-region p1 p2))))
101
102 ;; #### Someone translate this!!
103
104 (defun mc-normal-form-string (str)
105 "文字列 STR の漢字標準形文字列を返す．"
106 (let ((i 0))
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))
111 (aset str i ? ))
112 (setq i (1+ i)))
113 (if (string-match "\n" str 0)
114 (let ((c 0) (i 0) new)
115 (while (setq i (string-match "\n" str i))
116 (setq i (1+ i))
117 (setq c (1+ c)))
118 (setq new (make-string (- (length str) c) 0))
119 (setq i 0 c 0)
120 (while (< i (length str))
121 (cond((not (= (aref str i) ?\n ))
122 (aset new c (aref str i))
123 (setq c (1+ c))))
124
125 (setq i (1+ i))
126 )
127 new)
128 str)))
129
130
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
135 before comparison."
136 (let (find elm)
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)
141 (setq find list)
142 (setq list (cdr list))))
143 find))
144
145 (defun cancel-undo-boundary ()
146 "Cancel undo boundary."
147 (if (and (consp buffer-undo-list)
148 ;; if car is nil.
149 (null (car buffer-undo-list)) )
150 (setq buffer-undo-list (cdr buffer-undo-list)) ))
151
152
153 ;;; Common API emulation functions for GNU Emacs-merged Mule.
154 ;;; As suggested by MORIOKA Tomohiko
155
156 ;; Following definition were imported from Emacs/mule-delta.
157
158 ;; Function `truncate-string-to-width' was moved to mule-util.el.
159
160 ;; end of imported definition
161
162
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."
168 1)
169 (defalias 'char-length 'char-bytes)
170
171 (defun char-width (character)
172 "Return number of columns a CHARACTER occupies when displayed."
173 (charset-columns (char-charset character)))
174
175 (defalias 'char-columns 'char-width)
176 (make-obsolete 'char-columns 'char-width)
177
178 (defalias 'charset-description 'charset-doc-string)
179
180 (defalias 'find-charset-string 'charsets-in-string)
181 (defalias 'find-charset-region 'charsets-in-region)
182
183 (defun find-non-ascii-charset-string (string)
184 "Return a list of charsets in the STRING except ascii.
185 It might be available for compatibility with Mule 2.3,
186 because its `find-charset-string' ignores ASCII charset."
187 (delq 'ascii (charsets-in-string string)))
188
189 (defun find-non-ascii-charset-region (start end)
190 "Return a list of charsets except ascii in the region between START and END.
191 It might be available for compatibility with Mule 2.3,
192 because its `find-charset-string' ignores ASCII charset."
193 (delq 'ascii (charsets-in-region start end)))
194
195 (defun split-char (char)
196 "Return list of charset and one or two position-codes of CHAR."
197 (let ((charset (char-charset char)))
198 (if (eq charset 'ascii)
199 (list charset (char-int char))
200 (let ((i 0)
201 (len (charset-dimension charset))
202 (code (if (integerp char)
203 char
204 (char-int char)))
205 dest)
206 (while (< i len)
207 (setq dest (cons (logand code 127) dest)
208 code (lsh code -7)
209 i (1+ i)))
210 (cons charset dest)
211 ))))
212
213
214 ;;; Commands
215
216 (defun set-buffer-process-coding-system (decoding encoding)
217 "Set coding systems for the process associated with the current buffer.
218 DECODING is the coding system to be used to decode input from the process,
219 ENCODING is the coding system to be used to encode output to the process.
220
221 For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems]."
222 (interactive
223 "zCoding-system for process input: \nzCoding-system for process output: ")
224 (let ((proc (get-buffer-process (current-buffer))))
225 (if (null proc)
226 (error "no process")
227 (check-coding-system decoding)
228 (check-coding-system encoding)
229 (set-process-coding-system proc decoding encoding)))
230 (force-mode-line-update))
231
232
233 ;;; Language environments
234
235 ;; (defvar current-language-environment nil)
236
237 ;; (defvar language-environment-list nil)
238
239 ;; (defun current-language-environment ()
240 ;; "Return the current language environment as a symbol.
241 ;; Returns nil if `set-language-environment' has not been called."
242 ;; current-language-environment)
243
244 ;; (defun language-environment-list ()
245 ;; "Return a list of all currently defined language environments."
246 ;; language-environment-list)
247
248 ;; (defun language-environment-p (sym)
249 ;; "True if SYM names a defined language environment."
250 ;; (memq sym (language-environment-list)))
251
252 ;; (defun set-language-environment (env)
253 ;; "Set the current language environment to ENV."
254 ;; (interactive
255 ;; (list (intern (completing-read "Language environment: "
256 ;; obarray 'language-environment-p
257 ;; 'require-match))))
258 ;; (when (not (string= (charset-registry 'ascii) "iso8859-1"))
259 ;; (set-charset-registry 'ascii "iso8859-1"))
260 ;; (let ((func (get env 'set-lang-environ)))
261 ;; (if (not (null func))
262 ;; (funcall func)))
263 ;; (setq current-language-environment env)
264 ;; (if (featurep 'egg)
265 ;; (egg-lang-switch-callback))
266 ;; ;; (if (featurep 'quail)
267 ;; ;; (quail-lang-switch-callback))
268 ;; )
269
270 ;; (defun define-language-environment (env-sym doc-string enable-function)
271 ;; "Define a new language environment, named by ENV-SYM.
272 ;; DOC-STRING should be a string describing the environment.
273 ;; ENABLE-FUNCTION should be a function of no arguments that will be called
274 ;; when the language environment is made current."
275 ;; (put env-sym 'lang-environ-doc-string doc-string)
276 ;; (put env-sym 'set-lang-environ enable-function)
277 ;; (setq language-environment-list (cons env-sym language-environment-list)))
278
279 (defun define-egg-environment (env-sym doc-string enable-function)
280 "Define a new language environment for egg, named by ENV-SYM.
281 DOC-STRING should be a string describing the environment.
282 ENABLE-FUNCTION should be a function of no arguments that will be called
283 when the language environment is made current."
284 (put env-sym 'egg-environ-doc-string doc-string)
285 (put env-sym 'set-egg-environ enable-function))
286
287 ;; (defun define-quail-environment (env-sym doc-string enable-function)
288 ;; "Define a new language environment for quail, named by ENV-SYM.
289 ;; DOC-STRING should be a string describing the environment.
290 ;; ENABLE-FUNCTION should be a function of no arguments that will be called
291 ;; when the language environment is made current."
292 ;; (put env-sym 'quail-environ-doc-string doc-string)
293 ;; (put env-sym 'set-quail-environ enable-function))
294
295 ;;; mule-misc.el ends here