Mercurial > hg > xemacs-beta

comparison lisp/mule/mule-misc.el @ 398:74fd4e045ea6 r21-2-29

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-29
author cvs
date Mon, 13 Aug 2007 11:13:30 +0200
parents 4f79e16b1112
children 697ef44129c6
comparison
equal deleted inserted replaced
397:f4aeb21a5bad 398:74fd4e045ea6
1 ;; mule-misc.el --- Miscellaneous Mule functions. 1 ;; mule-misc.el --- Miscellaneous Mule functions.
2 2
3 ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. 3 ;; Copyright (C) 1995,1999 Electrotechnical Laboratory, JAPAN.
4 ;; Licensed to the Free Software Foundation. 4 ;; Licensed to the Free Software Foundation.
5 ;; Copyright (C) 1992,93,94,95 Free Software Foundation, Inc. 5 ;; Copyright (C) 1992,93,94,95 Free Software Foundation, Inc.
6 ;; Copyright (C) 1995 Amdahl Corporation. 6 ;; Copyright (C) 1995 Amdahl Corporation.
7 ;; Copyright (C) 1995 Sun Microsystems. 7 ;; Copyright (C) 1995 Sun Microsystems.
8 8
62 using a window system." 62 using a window system."
63 (let ((col 0) 63 (let ((col 0)
64 (len (length string)) 64 (len (length string))
65 (i 0)) 65 (i 0))
66 (while (< i len) 66 (while (< i len)
67 (setq col (+ col (charset-columns (char-charset (aref string i))))) 67 (setq col (+ col (charset-width (char-charset (aref string i)))))
68 (setq i (1+ i))) 68 (setq i (1+ i)))
69 col)) 69 col))
70 70
71 (defalias 'string-columns 'string-width) 71 (defalias 'string-columns 'string-width)
72 (make-obsolete 'string-columns 'string-width) 72 (make-obsolete 'string-columns 'string-width)
161 161
162 162
163 (defalias 'sref 'aref) 163 (defalias 'sref 'aref)
164 (defalias 'map-char-concat 'mapcar) 164 (defalias 'map-char-concat 'mapcar)
165 (defun char-bytes (character) 165 (defun char-bytes (character)
166 "Return number of length a CHARACTER occupies in a string or buffer. 166 "Return number of bytes a CHARACTER occupies in a string or buffer.
167 It returns only 1 in XEmacs. It is for compatibility with MULE 2.3." 167 It always returns 1 in XEmacs. It is for compatibility with MULE 2.3."
168 1) 168 1)
169 (defalias 'char-length 'char-bytes) 169 (defalias 'char-length 'char-bytes)
170 170
171 (defun char-width (character) 171 (defun char-width (character)
172 "Return number of columns a CHARACTER occupies when displayed." 172 "Return number of columns a CHARACTER occupies when displayed."
173 (charset-columns (char-charset character))) 173 (charset-width (char-charset character)))
174 174
175 (defalias 'char-columns 'char-width) 175 (defalias 'char-columns 'char-width)
176 (make-obsolete 'char-columns 'char-width) 176 (make-obsolete 'char-columns 'char-width)
177
178 (defalias 'charset-description 'charset-doc-string)
179 177
180 (defalias 'find-charset-string 'charsets-in-string) 178 (defalias 'find-charset-string 'charsets-in-string)
181 (defalias 'find-charset-region 'charsets-in-region) 179 (defalias 'find-charset-region 'charsets-in-region)
182 180
183 (defun find-non-ascii-charset-string (string) 181 (defun find-non-ascii-charset-string (string)
190 "Return a list of charsets except ascii in the region between START and END. 188 "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, 189 It might be available for compatibility with Mule 2.3,
192 because its `find-charset-string' ignores ASCII charset." 190 because its `find-charset-string' ignores ASCII charset."
193 (delq 'ascii (charsets-in-region start end))) 191 (delq 'ascii (charsets-in-region start end)))
194 192
195 (defun split-char (char) 193 ;(defun split-char (char)
196 "Return list of charset and one or two position-codes of CHAR." 194 ; "Return list of charset and one or two position-codes of CHAR."
197 (let ((charset (char-charset char))) 195 ; (let ((charset (char-charset char)))
198 (if (eq charset 'ascii) 196 ; (if (eq charset 'ascii)
199 (list charset (char-int char)) 197 ; (list charset (char-int char))
200 (let ((i 0) 198 ; (let ((i 0)
201 (len (charset-dimension charset)) 199 ; (len (charset-dimension charset))
202 (code (if (integerp char) 200 ; (code (if (integerp char)
203 char 201 ; char
204 (char-int char))) 202 ; (char-int char)))
205 dest) 203 ; dest)
206 (while (< i len) 204 ; (while (< i len)
207 (setq dest (cons (logand code 127) dest) 205 ; (setq dest (cons (logand code 127) dest)
208 code (lsh code -7) 206 ; code (lsh code -7)
209 i (1+ i))) 207 ; i (1+ i)))
210 (cons charset dest) 208 ; (cons charset dest)
211 )))) 209 ; ))))
210
211 ;(defun split-char-or-char-int (char)
212 ; "Return list of charset and one or two position-codes of CHAR.
213 ;CHAR must be character or integer."
214 ; (if (characterp char)
215 ; (split-char char)
216 ; (let ((c (int-char char)))
217 ; (if c
218 ; (split-char c)
219 ; (list 'ascii c)
220 ; ))))
212 221
213 222
214 ;;; Commands 223 ;;; Commands
215 224
216 (defun set-buffer-process-coding-system (decoding encoding) 225 (defun set-buffer-process-coding-system (decoding encoding)
290 ;; ENABLE-FUNCTION should be a function of no arguments that will be called 299 ;; ENABLE-FUNCTION should be a function of no arguments that will be called
291 ;; when the language environment is made current." 300 ;; when the language environment is made current."
292 ;; (put env-sym 'quail-environ-doc-string doc-string) 301 ;; (put env-sym 'quail-environ-doc-string doc-string)
293 ;; (put env-sym 'set-quail-environ enable-function)) 302 ;; (put env-sym 'set-quail-environ enable-function))
294 303
304
305 ;;; @ coding-system category
306 ;;;
307
308 (defun coding-system-get (coding-system prop)
309 "Extract a value from CODING-SYSTEM's property list for property PROP."
310 (or (plist-get
311 (get (coding-system-name coding-system) 'coding-system-property)
312 prop)
313 (condition-case nil
314 (coding-system-property coding-system prop)
315 (error nil))))
316
317 (defun coding-system-put (coding-system prop val)
318 "Change value in CODING-SYSTEM's property list PROP to VAL."
319 (put (coding-system-name coding-system)
320 'coding-system-property
321 (plist-put (get (coding-system-name coding-system)
322 'coding-system-property)
323 prop val)))
324
325 (defun coding-system-category (coding-system)
326 "Return the coding category of CODING-SYSTEM."
327 (or (coding-system-get coding-system 'category)
328 (let ((type (coding-system-type coding-system)))
329 (cond ((eq type 'no-conversion)
330 'no-conversion)
331 ((eq type 'shift-jis)
332 'shift-jis)
333 ((eq type 'ucs-4)
334 'ucs-4)
335 ((eq type 'utf-8)
336 'utf-8)
337 ((eq type 'big5)
338 'big5)
339 ((eq type 'iso2022)
340 (cond ((coding-system-lock-shift coding-system)
341 'iso-lock-shift)
342 ((coding-system-seven coding-system)
343 'iso-7)
344 (t
345 (let ((dim 0)
346 ccs
347 (i 0))
348 (while (< i 4)
349 (setq ccs (coding-system-charset coding-system i))
350 (if (and ccs
351 (> (charset-dimension ccs) dim))
352 (setq dim (charset-dimension ccs))
353 )
354 (setq i (1+ i)))
355 (cond ((= dim 1) 'iso-8-1)
356 ((= dim 2) 'iso-8-2)
357 (t 'iso-8-designate))
358 ))))))))
359
295 ;;; mule-misc.el ends here 360 ;;; mule-misc.el ends here