Mercurial > hg > xemacs-beta

comparison lisp/mule/mule-misc.el @ 412:697ef44129c6 r21-2-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-14
author cvs
date Mon, 13 Aug 2007 11:20:41 +0200
parents 74fd4e045ea6
children e804706bfb8c
comparison
equal deleted inserted replaced
411:12e008d41344 412:697ef44129c6
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-width (char-charset (aref string i))))) 67 (setq col (+ col (charset-columns (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 bytes a CHARACTER occupies in a string or buffer. 166 "Return number of length a CHARACTER occupies in a string or buffer.
167 It always returns 1 in XEmacs. It is for compatibility with MULE 2.3." 167 It returns only 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-width (char-charset character))) 173 (charset-columns (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 177
178 (defalias 'find-charset-string 'charsets-in-string) 178 (defalias 'find-charset-string 'charsets-in-string)
188 "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.
189 It might be available for compatibility with Mule 2.3, 189 It might be available for compatibility with Mule 2.3,
190 because its `find-charset-string' ignores ASCII charset." 190 because its `find-charset-string' ignores ASCII charset."
191 (delq 'ascii (charsets-in-region start end))) 191 (delq 'ascii (charsets-in-region start end)))
192 192
193 ;(defun split-char (char) 193 (defun split-char (char)
194 ; "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."
195 ; (let ((charset (char-charset char))) 195 (let ((charset (char-charset char)))
196 ; (if (eq charset 'ascii) 196 (if (eq charset 'ascii)
197 ; (list charset (char-int char)) 197 (list charset (char-int char))
198 ; (let ((i 0) 198 (let ((i 0)
199 ; (len (charset-dimension charset)) 199 (len (charset-dimension charset))
200 ; (code (if (integerp char) 200 (code (if (integerp char)
201 ; char 201 char
202 ; (char-int char))) 202 (char-int char)))
203 ; dest) 203 dest)
204 ; (while (< i len) 204 (while (< i len)
205 ; (setq dest (cons (logand code 127) dest) 205 (setq dest (cons (logand code 127) dest)
206 ; code (lsh code -7) 206 code (lsh code -7)
207 ; i (1+ i))) 207 i (1+ i)))
208 ; (cons charset dest) 208 (cons charset dest)
209 ; )))) 209 ))))
210 210
211 ;(defun split-char-or-char-int (char) 211 (defun split-char-or-char-int (char)
212 ; "Return list of charset and one or two position-codes of CHAR. 212 "Return list of charset and one or two position-codes of CHAR.
213 ;CHAR must be character or integer." 213 CHAR must be character or integer."
214 ; (if (characterp char) 214 (if (characterp char)
215 ; (split-char char) 215 (split-char char)
216 ; (let ((c (int-char char))) 216 (let ((c (int-char char)))
217 ; (if c 217 (if c
218 ; (split-char c) 218 (split-char c)
219 ; (list 'ascii c) 219 (list 'ascii c)
220 ; )))) 220 ))))
221 221
222 222
223 ;;; Commands 223 ;;; Commands
224 224
225 (defun set-buffer-process-coding-system (decoding encoding) 225 (defun set-buffer-process-coding-system (decoding encoding)
299 ;; 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
300 ;; when the language environment is made current." 300 ;; when the language environment is made current."
301 ;; (put env-sym 'quail-environ-doc-string doc-string) 301 ;; (put env-sym 'quail-environ-doc-string doc-string)
302 ;; (put env-sym 'set-quail-environ enable-function)) 302 ;; (put env-sym 'set-quail-environ enable-function))
303 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
360 ;;; mule-misc.el ends here 304 ;;; mule-misc.el ends here