502
+ − 1 ;; mule-misc.el --- Miscellaneous Mule functions. -*- coding: iso-2022-7bit; -*-
428
+ − 2
+ − 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.
+ − 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
444
+ − 22 ;; along with XEmacs; see the file COPYING. If not, write to the
428
+ − 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-width (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 "$BJ8;zNs(B STR $B$N4A;zI8=`7AJ8;zNs$rJV$9!%(B"
+ − 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)
438
+ − 166 "Return number of bytes a CHARACTER occupies in a string or buffer.
+ − 167 It always returns 1 in XEmacs. It is for compatibility with MULE 2.3."
428
+ − 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-width (char-charset character)))
+ − 174
+ − 175 (defalias 'char-columns 'char-width)
+ − 176 (make-obsolete 'char-columns 'char-width)
+ − 177
+ − 178 (defalias 'find-charset-string 'charsets-in-string)
+ − 179 (defalias 'find-charset-region 'charsets-in-region)
+ − 180
+ − 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)))
+ − 186
+ − 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)))
+ − 192
+ − 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))
+ − 198 ; (let ((i 0)
+ − 199 ; (len (charset-dimension charset))
+ − 200 ; (code (if (integerp char)
+ − 201 ; char
+ − 202 ; (char-int char)))
+ − 203 ; dest)
+ − 204 ; (while (< i len)
+ − 205 ; (setq dest (cons (logand code 127) dest)
+ − 206 ; code (lsh code -7)
+ − 207 ; i (1+ i)))
+ − 208 ; (cons charset dest)
+ − 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 ; ))))
+ − 221
+ − 222
+ − 223 ;;; Language environments
+ − 224
+ − 225 ;; (defvar current-language-environment nil)
+ − 226
+ − 227 ;; (defvar language-environment-list nil)
+ − 228
+ − 229 ;; (defun current-language-environment ()
+ − 230 ;; "Return the current language environment as a symbol.
+ − 231 ;; Returns nil if `set-language-environment' has not been called."
+ − 232 ;; current-language-environment)
+ − 233
+ − 234 ;; (defun language-environment-list ()
+ − 235 ;; "Return a list of all currently defined language environments."
+ − 236 ;; language-environment-list)
+ − 237
+ − 238 ;; (defun language-environment-p (sym)
+ − 239 ;; "True if SYM names a defined language environment."
+ − 240 ;; (memq sym (language-environment-list)))
+ − 241
+ − 242 ;; (defun set-language-environment (env)
+ − 243 ;; "Set the current language environment to ENV."
+ − 244 ;; (interactive
+ − 245 ;; (list (intern (completing-read "Language environment: "
+ − 246 ;; obarray 'language-environment-p
+ − 247 ;; 'require-match))))
+ − 248 ;; (when (not (string= (charset-registry 'ascii) "iso8859-1"))
+ − 249 ;; (set-charset-registry 'ascii "iso8859-1"))
+ − 250 ;; (let ((func (get env 'set-lang-environ)))
+ − 251 ;; (if (not (null func))
+ − 252 ;; (funcall func)))
+ − 253 ;; (setq current-language-environment env)
+ − 254 ;; (if (featurep 'egg)
+ − 255 ;; (egg-lang-switch-callback))
+ − 256 ;; ;; (if (featurep 'quail)
+ − 257 ;; ;; (quail-lang-switch-callback))
+ − 258 ;; )
+ − 259
+ − 260 ;; (defun define-language-environment (env-sym doc-string enable-function)
+ − 261 ;; "Define a new language environment, named by ENV-SYM.
+ − 262 ;; DOC-STRING should be a string describing the environment.
+ − 263 ;; ENABLE-FUNCTION should be a function of no arguments that will be called
+ − 264 ;; when the language environment is made current."
+ − 265 ;; (put env-sym 'lang-environ-doc-string doc-string)
+ − 266 ;; (put env-sym 'set-lang-environ enable-function)
+ − 267 ;; (setq language-environment-list (cons env-sym language-environment-list)))
+ − 268
+ − 269 (defun define-egg-environment (env-sym doc-string enable-function)
+ − 270 "Define a new language environment for egg, named by ENV-SYM.
+ − 271 DOC-STRING should be a string describing the environment.
+ − 272 ENABLE-FUNCTION should be a function of no arguments that will be called
+ − 273 when the language environment is made current."
+ − 274 (put env-sym 'egg-environ-doc-string doc-string)
+ − 275 (put env-sym 'set-egg-environ enable-function))
+ − 276
+ − 277 ;; (defun define-quail-environment (env-sym doc-string enable-function)
+ − 278 ;; "Define a new language environment for quail, named by ENV-SYM.
+ − 279 ;; DOC-STRING should be a string describing the environment.
+ − 280 ;; ENABLE-FUNCTION should be a function of no arguments that will be called
+ − 281 ;; when the language environment is made current."
+ − 282 ;; (put env-sym 'quail-environ-doc-string doc-string)
+ − 283 ;; (put env-sym 'set-quail-environ enable-function))
+ − 284
+ − 285
+ − 286 ;;; @ coding-system category
+ − 287 ;;;
+ − 288
+ − 289 ;;; mule-misc.el ends here
