Mercurial > hg > xemacs-beta

comparison lisp/mule/mule-misc.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents
children 6a378aca36af
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; mule-misc.el --- Miscellaneous Mule functions.
2
3 ;; Copyright (C) 1992,93,94,95 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Amdahl Corporation.
5 ;; Copyright (C) 1995 Sun Microsystems.
6
7 ;; This file is part of XEmacs.
8
9 ;; XEmacs is free software; you can redistribute it and/or modify it
10 ;; under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
12 ;; any later version.
13
14 ;; XEmacs is distributed in the hope that it will be useful, but
15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 ;; General Public License for more details.
18
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with XEmacs; see the file COPYING. If not, write to the
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
23
24 ;;;
25 ;;; protect specified local variables from kill-all-local-variables
26 ;;;
27
28 (defvar self-insert-after-hook nil
29 "Hook to run when extended self insertion command exits. Should take
30 two arguments START and END corresponding to character position.")
31
32 (make-variable-buffer-local 'self-insert-after-hook)
33
34 (defun toggle-display-direction ()
35 (interactive)
36 (setq display-direction (not display-direction))
37 (if (interactive-p) (redraw-display)))
38
39 ;;;
40 ;;; Utility functions for Mule
41 ;;;
42
43 ;(defun string-to-char-list (str)
44 ; (let ((len (length str))
45 ; (idx 0)
46 ; c l)
47 ; (while (< idx len)
48 ; (setq c (sref str idx))
49 ; (setq idx (+ idx (charset-dimension (char-charset c))))
50 ; (setq l (cons c l)))
51 ; (nreverse l)))
52
53 (defun string-to-char-list (str)
54 (mapcar 'identity str))
55
56 ;;; Slower, albeit more elegant, implementation??
57 ;; (defun string-columns (string)
58 ;; "Return number of columns STRING occupies when displayed.
59 ;; Uses the charset-columns attribute of the characters in STRING,
60 ;; which may not accurately represent the actual display width in a
61 ;; window system."
62 ;; (loop for c across string
63 ;; sum (charset-columns (char-charset c))))
64
65 (defun string-columns (string)
66 "Return number of columns STRING occupies when displayed.
67 Uses the charset-columns attribute of the characters in STRING,
68 which may not accurately represent the actual display width when
69 using a window system."
70 (let ((col 0)
71 (len (length string))
72 (i 0))
73 (while (< i len)
74 (setq col (+ col (charset-columns (char-charset (aref string i)))))
75 (setq i (1+ i)))
76 col))
77
78 (defalias 'string-width 'string-columns)
79
80 (defun delete-text-in-column (from to)
81 "Delete the text between column FROM and TO (exclusive) of the current line.
82 Nil of FORM or TO means the current column.
83 If there's a charcter across the borders, the character is replaced with
84 the same width of spaces before deleting."
85 (save-excursion
86 (let (p1 p2)
87 (if from
88 (progn
89 (setq p1 (move-to-column from))
90 (if (> p1 from)
91 (progn
92 (delete-char -1)
93 (insert-char ? (- p1 (current-column)))
94 (forward-char (- from p1))))))
95 (setq p1 (point))
96 (if to
97 (progn
98 (setq p2 (move-to-column to))
99 (if (> p2 to)
100 (progn
101 (delete-char -1)
102 (insert-char ? (- p2 (current-column)))
103 (forward-char (- to p2))))))
104 (setq p2 (point))
105 (delete-region p1 p2))))
106
107 ;; #### Someone translate this!!
108
109 (defun mc-normal-form-string (str)
110 "文字列 STR の漢字標準形文字列を返す．"
111 (let ((i 0))
112 (while (setq i (string-match "\n" str i))
113 (if (and (<= 1 i) (< i (1- (length str)))
114 (< (aref str (1- i)) 128)
115 (< (aref str (1+ i)) 128))
116 (aset str i ? ))
117 (setq i (1+ i)))
118 (if (string-match "\n" str 0)
119 (let ((c 0) (i 0) new)
120 (while (setq i (string-match "\n" str i))
121 (setq i (1+ i))
122 (setq c (1+ c)))
123 (setq new (make-string (- (length str) c) 0))
124 (setq i 0 c 0)
125 (while (< i (length str))
126 (cond((not (= (aref str i) ?\n ))
127 (aset new c (aref str i))
128 (setq c (1+ c))))
129
130 (setq i (1+ i))
131 )
132 new)
133 str)))
134
135
136 (defun string-memq (str list)
137 "Returns non-nil if STR is an element of LIST. Comparison done with string=.
138 The value is actually the tail of LIST whose car is STR.
139 If each element of LIST is not a string, it is converted to string
140 before comparison."
141 (let (find elm)
142 (while (and (not find) list)
143 (setq elm (car list))
144 (if (numberp elm) (setq elm (char-to-string elm)))
145 (if (string= str elm)
146 (setq find list)
147 (setq list (cdr list))))
148 find))
149
150 (defun cancel-undo-boundary ()
151 "Cancel undo boundary."
152 (if (and (consp buffer-undo-list)
153 ;; if car is nil.
154 (null (car buffer-undo-list)) )
155 (setq buffer-undo-list (cdr buffer-undo-list)) ))
156
157 ;;; Common API emulation functions for GNU Emacs-merged Mule.
158 ;;; As suggested by MORIOKA Tomohiko
159 (defun truncate-string (str width &optional start-column)
160 "Truncate STR to fit in WIDTH columns.
161 Optional non-nil arg START-COLUMN specifies the starting column."
162 (substring str (or start-column 0) width))
163
164 (defalias 'sref 'aref)
165 (defalias 'map-char-concat 'mapcar)
166 (defun char-bytes (chr) 1)
167 (defun char-length (chr) 1)
168
169 (defun char-columns (character)
170 "Return number of columns a CHARACTER occupies when displayed."
171 (charset-columns (char-charset character)))
172
173 (defalias 'charset-description 'charset-doc-string)
174
175 (defalias 'find-charset-string 'charsets-in-string)
176 (defalias 'find-charset-region 'charsets-in-region)
177
178 (defun find-non-ascii-charset-string (string)
179 "Return a list of charsets in the STRING except ascii.
180 For compatibility with Mule"
181 (delq 'ascii (charsets-in-string string)))
182
183 (defun find-non-ascii-charset-region (start end)
184 "Return a list of charsets except ascii
185 in the region between START and END.
186 For compatibility with Mule"
187 (delq 'ascii (charsets-in-region start end)))
188
189 ;(defun truncate-string-to-column (str width &optional start-column)
190 ; "Truncate STR to fit in WIDTH columns.
191 ;Optional non-nil arg START-COLUMN specifies the starting column."
192 ; (or start-column
193 ; (setq start-column 0))
194 ; (let ((max-width (string-width str))
195 ; (len (length str))
196 ; (from 0)
197 ; (column 0)
198 ; to-prev to ch)
199 ; (if (>= width max-width)
200 ; (setq width max-width))
201 ; (if (>= start-column width)
202 ; ""
203 ; (while (< column start-column)
204 ; (setq ch (aref str from)
205 ; column (+ column (char-width ch))
206 ; from (+ from (char-octets ch))))
207 ; (if (< width max-width)
208 ; (progn
209 ; (setq to from)
210 ; (while (<= column width)
211 ; (setq ch (aref str to)
212 ; column (+ column (char-width ch))
213 ; to-prev to
214 ; to (+ to (char-octets ch))))
215 ; (setq to to-prev)))
216 ; (substring str from to))))
217
218
219 ;;; Language environments
220
221 (defvar current-language-environment nil)
222
223 (defvar language-environment-list nil)
224
225 (defun current-language-environment ()
226 "Return the current language environment as a symbol.
227 Returns nil if `set-language-environment' has not been called."
228 current-language-environment)
229
230 (defun language-environment-list ()
231 "Return a list of all currently defined language environments."
232 language-environment-list)
233
234 (defun language-environment-p (sym)
235 "True if SYM names a defined language environment."
236 (memq sym (language-environment-list)))
237
238 (defun set-language-environment (env)
239 "Set the current language environment to ENV."
240 (interactive
241 (list (intern (completing-read "Language environment: "
242 obarray 'language-environment-p
243 'require-match))))
244 (when (not (string= (charset-registry 'ascii) "ISO8859-1"))
245 (set-charset-registry 'ascii "ISO8859-1"))
246 (let ((func (get env 'set-lang-environ)))
247 (if (not (null func))
248 (funcall func)))
249 (setq current-language-environment env))
250
251 (defun define-language-environment (env-sym doc-string enable-function)
252 "Define a new language environment, named by ENV-SYM.
253 DOC-STRING should be a string describing the environment.
254 ENABLE-FUNCTION should be a function of no arguments that will be called
255 when the language environment is made current."
256 (put env-sym 'lang-environ-doc-string doc-string)
257 (put env-sym 'set-lang-environ enable-function)
258 (setq language-environment-list (cons env-sym language-environment-list)))