lisp/mule/mule-misc.el

   1 ;; mule-misc.el --- Miscellaneous Mule functions.
   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
  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-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   "\e$BJ8;zNs\e(B STR \e$B$N4A;zI8=`7AJ8;zNs$rJV$9!%\e(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)
 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."
 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 (defun coding-system-get (coding-system prop)
 290   "Extract a value from CODING-SYSTEM's property list for property PROP."
 291   (or (plist-get
 292        (get (coding-system-name coding-system) 'coding-system-property)
 293        prop)
 294       (condition-case nil
 295           (coding-system-property coding-system prop)
 296         (error nil))))
 297
 298 (defun coding-system-put (coding-system prop value)
 299   "Change value in CODING-SYSTEM's property list PROP to VALUE."
 300   (put (coding-system-name coding-system)
 301        'coding-system-property
 302        (plist-put (get (coding-system-name coding-system)
 303                        'coding-system-property)
 304                   prop value)))
 305
 306 (defun coding-system-category (coding-system)
 307   "Return the coding category of CODING-SYSTEM."
 308   (or (coding-system-get coding-system 'category)
 309       (let ((type (coding-system-type coding-system)))
 310         (cond ((eq type 'no-conversion)
 311                'no-conversion)
 312               ((eq type 'shift-jis)
 313                'shift-jis)
 314               ((eq type 'ucs-4)
 315                'ucs-4)
 316               ((eq type 'utf-8)
 317                'utf-8)
 318               ((eq type 'big5)
 319                'big5)
 320               ((eq type 'iso2022)
 321                (cond ((coding-system-lock-shift coding-system)
 322                       'iso-lock-shift)
 323                      ((coding-system-seven coding-system)
 324                       'iso-7)
 325                      (t
 326                       (let ((dim 0)
 327                             ccs
 328                             (i 0))
 329                         (while (< i 4)
 330                           (setq ccs (coding-system-charset coding-system i))
 331                           (if (and ccs
 332                                    (> (charset-dimension ccs) dim))
 333                               (setq dim (charset-dimension ccs))
 334                             )
 335                           (setq i (1+ i)))
 336                         (cond ((= dim 1) 'iso-8-1)
 337                               ((= dim 2) 'iso-8-2)
 338                               (t 'iso-8-designate))
 339                         ))))))))
 340
 341 ;;; mule-misc.el ends here