--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/mule/mule-misc.el	Mon Aug 13 11:28:15 2007 +0200
@@ -0,0 +1,373 @@
+;; mule-misc.el --- Miscellaneous Mule functions.
+
+;; Copyright (C) 1995,1999 Electrotechnical Laboratory, JAPAN.
+;; Licensed to the Free Software Foundation.
+;; Copyright (C) 1992,93,94,95 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Amdahl Corporation.
+;; Copyright (C) 1995 Sun Microsystems.
+
+;; This file is part of XEmacs.
+
+;; XEmacs is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; XEmacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs; see the file COPYING.  If not, write to the 
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;;
+;;;  protect specified local variables from kill-all-local-variables
+;;;
+
+(defvar self-insert-after-hook nil
+  "Hook to run when extended self insertion command exits.  Should take
+two arguments START and END corresponding to character position.")
+
+(make-variable-buffer-local 'self-insert-after-hook)
+
+(defun toggle-display-direction ()
+  (interactive)
+  (setq display-direction (not display-direction))
+  (if (interactive-p) (redraw-display)))
+
+;;;
+;;; Utility functions for Mule
+;;;
+
+;(defun string-to-char-list (str)
+;  (let ((len (length str))
+;	(idx 0)
+;	c l)
+;    (while (< idx len)
+;      (setq c (sref str idx))
+;      (setq idx (+ idx (charset-dimension (char-charset c))))
+;      (setq l (cons c l)))
+;    (nreverse l)))
+
+(defun string-to-char-list (str)
+  (mapcar 'identity str))
+
+(defun string-width (string)
+  "Return number of columns STRING occupies when displayed.
+Uses the charset-columns attribute of the characters in STRING,
+which may not accurately represent the actual display width when
+using a window system."
+  (let ((col 0)
+	(len (length string))
+	(i 0))
+    (while (< i len)
+      (setq col (+ col (charset-width (char-charset (aref string i)))))
+      (setq i (1+ i)))
+    col))
+
+(defalias 'string-columns 'string-width)
+(make-obsolete 'string-columns 'string-width)
+
+(defun delete-text-in-column (from to)
+  "Delete the text between column FROM and TO (exclusive) of the current line.
+Nil of FORM or TO means the current column.
+
+If there's a character across the borders, the character is replaced
+with the same width of spaces before deleting."
+  (save-excursion
+    (let (p1 p2)
+      (if from
+	  (progn
+	    (setq p1 (move-to-column from))
+	    (if (> p1 from)
+		(progn
+		  (delete-char -1)
+		  (insert-char ?  (- p1 (current-column)))
+		  (forward-char (- from p1))))))
+      (setq p1 (point))
+      (if to
+	  (progn
+	    (setq p2 (move-to-column to))
+	    (if (> p2 to)
+		(progn
+		  (delete-char -1)
+		  (insert-char ?  (- p2 (current-column)))
+		  (forward-char (- to p2))))))
+      (setq p2 (point))
+      (delete-region p1 p2))))
+
+;; #### Someone translate this!!
+
+(defun mc-normal-form-string (str)
+  "文字列 STR の漢字標準形文字列を返す．"
+  (let ((i 0))
+    (while (setq i (string-match "\n" str i))
+      (if (and (<= 1 i) (< i (1- (length str)))
+	       (< (aref str (1- i)) 128)
+	       (< (aref str (1+ i)) 128))
+	  (aset str i ? ))
+      (setq i (1+ i)))
+    (if (string-match "\n" str 0)
+	(let ((c 0) (i 0) new)
+	  (while (setq i (string-match "\n" str i))
+	    (setq i (1+ i))
+	    (setq c (1+ c)))
+	  (setq new (make-string (- (length str) c) 0))
+	  (setq i 0 c 0)
+	  (while (< i (length str))
+	    (cond((not (= (aref str i) ?\n ))
+		  (aset new c (aref str i))
+		  (setq c (1+ c))))
+
+	    (setq i (1+ i))
+	    )
+	  new)
+      str)))
+
+
+(defun string-memq (str list)
+  "Returns non-nil if STR is an element of LIST.  Comparison done with string=.
+The value is actually the tail of LIST whose car is STR.
+If each element of LIST is not a string, it is converted to string
+ before comparison."
+  (let (find elm)
+    (while (and (not find) list)
+      (setq elm (car list))
+      (if (numberp elm) (setq elm (char-to-string elm)))
+      (if (string= str elm)
+	  (setq find list)
+	(setq list (cdr list))))
+    find))
+
+(defun cancel-undo-boundary ()
+  "Cancel undo boundary."
+  (if (and (consp buffer-undo-list)
+	   ;; if car is nil.
+	   (null (car buffer-undo-list)) )
+      (setq buffer-undo-list (cdr buffer-undo-list)) ))
+
+
+;;; Common API emulation functions for GNU Emacs-merged Mule.
+;;; As suggested by MORIOKA Tomohiko
+
+;; Following definition were imported from Emacs/mule-delta.
+
+;; Function `truncate-string-to-width' was moved to mule-util.el.
+
+;; end of imported definition
+
+
+(defalias 'sref 'aref)
+(defalias 'map-char-concat 'mapcar)
+(defun char-bytes (character)
+  "Return number of length a CHARACTER occupies in a string or buffer.
+It returns only 1 in XEmacs.  It is for compatibility with MULE 2.3."
+  1)
+(defalias 'char-length 'char-bytes)
+
+(defun char-width (character)
+  "Return number of columns a CHARACTER occupies when displayed."
+  (charset-width (char-charset character)))
+
+(defalias 'char-columns 'char-width)
+(make-obsolete 'char-columns 'char-width)
+
+(defalias 'find-charset-string 'charsets-in-string)
+(defalias 'find-charset-region 'charsets-in-region)
+
+(defun find-non-ascii-charset-string (string)
+  "Return a list of charsets in the STRING except ascii.
+It might be available for compatibility with Mule 2.3,
+because its `find-charset-string' ignores ASCII charset."
+  (delq 'ascii (charsets-in-string string)))
+
+(defun find-non-ascii-charset-region (start end)
+  "Return a list of charsets except ascii in the region between START and END.
+It might be available for compatibility with Mule 2.3,
+because its `find-charset-string' ignores ASCII charset."
+  (delq 'ascii (charsets-in-region start end)))
+
+;(defun split-char (char)
+;  "Return list of charset and one or two position-codes of CHAR."
+;  (let ((charset (char-charset char)))
+;    (if (eq charset 'ascii)
+;	(list charset (char-int char))
+;      (let ((i 0)
+;	    (len (charset-dimension charset))
+;	    (code (if (integerp char)
+;		      char
+;		    (char-int char)))
+;	    dest)
+;	(while (< i len)
+;	  (setq dest (cons (logand code 127) dest)
+;		code (lsh code -7)
+;		i (1+ i)))
+;	(cons charset dest)
+;	))))
+
+(defun char-octet (ch &optional n)
+  "Return the octet numbered N (should be 0 or 1) of char CH.
+N defaults to 0 if omitted."
+  (let ((split (split-char ch)))
+    (setq n (or n 0))
+    (cond ((eq n 0)
+	   (nth 1 split))
+	  ((eq n 1)
+	   (nth 2 split))
+	  (t (error "n must be 0 or 1")))))
+;; Made obsolete June 15, 1999.  Delete ASAP.
+(make-obsolete 'char-octet "Use split-char")
+
+;(defun split-char-or-char-int (char)
+;  "Return list of charset and one or two position-codes of CHAR.
+;CHAR must be character or integer."
+;  (if (characterp char)
+;      (split-char char)
+;    (let ((c (int-char char)))
+;      (if c
+;	  (split-char c)
+;	(list 'ascii c)
+;	))))
+
+
+;;; Commands
+
+(defun set-buffer-process-coding-system (decoding encoding)
+  "Set coding systems for the process associated with the current buffer.
+DECODING is the coding system to be used to decode input from the process,
+ENCODING is the coding system to be used to encode output to the process.
+
+For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems]."
+  (interactive
+   "zCoding-system for process input: \nzCoding-system for process output: ")
+  (let ((proc (get-buffer-process (current-buffer))))
+    (if (null proc)
+	(error "no process")
+      (check-coding-system decoding)
+      (check-coding-system encoding)
+      (set-process-coding-system proc decoding encoding)))
+  (force-mode-line-update))
+
+
+;;; Language environments
+
+;; (defvar current-language-environment nil)
+
+;; (defvar language-environment-list nil)
+
+;; (defun current-language-environment ()
+;;   "Return the current language environment as a symbol.
+;; Returns nil if `set-language-environment' has not been called."
+;;   current-language-environment)
+
+;; (defun language-environment-list ()
+;;   "Return a list of all currently defined language environments."
+;;   language-environment-list)
+
+;; (defun language-environment-p (sym)
+;;   "True if SYM names a defined language environment."
+;;   (memq sym (language-environment-list)))
+
+;; (defun set-language-environment (env)
+;;   "Set the current language environment to ENV."
+;;   (interactive
+;;    (list (intern (completing-read "Language environment: "
+;;                                   obarray 'language-environment-p
+;;                                   'require-match))))
+;;   (when (not (string= (charset-registry 'ascii) "iso8859-1"))
+;;     (set-charset-registry 'ascii "iso8859-1"))
+;;   (let ((func (get env 'set-lang-environ)))
+;;     (if (not (null func))
+;;         (funcall func)))
+;;   (setq current-language-environment env)
+;;   (if (featurep 'egg)
+;;       (egg-lang-switch-callback))
+;; ;;  (if (featurep 'quail)
+;; ;;      (quail-lang-switch-callback))
+;; )
+
+;; (defun define-language-environment (env-sym doc-string enable-function)
+;;   "Define a new language environment, named by ENV-SYM.
+;; DOC-STRING should be a string describing the environment.
+;; ENABLE-FUNCTION should be a function of no arguments that will be called
+;; when the language environment is made current."
+;;   (put env-sym 'lang-environ-doc-string doc-string)
+;;   (put env-sym 'set-lang-environ enable-function)
+;;   (setq language-environment-list (cons env-sym language-environment-list)))
+
+(defun define-egg-environment (env-sym doc-string enable-function)
+  "Define a new language environment for egg, named by ENV-SYM.
+DOC-STRING should be a string describing the environment.
+ENABLE-FUNCTION should be a function of no arguments that will be called
+when the language environment is made current."
+  (put env-sym 'egg-environ-doc-string doc-string)
+  (put env-sym 'set-egg-environ enable-function))
+
+;; (defun define-quail-environment (env-sym doc-string enable-function)
+;;   "Define a new language environment for quail, named by ENV-SYM.
+;; DOC-STRING should be a string describing the environment.
+;; ENABLE-FUNCTION should be a function of no arguments that will be called
+;; when the language environment is made current."
+;;   (put env-sym 'quail-environ-doc-string doc-string)
+;;   (put env-sym 'set-quail-environ enable-function))
+
+
+;;; @ coding-system category
+;;;
+
+(defun coding-system-get (coding-system prop)
+  "Extract a value from CODING-SYSTEM's property list for property PROP."
+  (or (plist-get
+       (get (coding-system-name coding-system) 'coding-system-property)
+       prop)
+      (condition-case nil
+	  (coding-system-property coding-system prop)
+	(error nil))))
+
+(defun coding-system-put (coding-system prop val)
+  "Change value in CODING-SYSTEM's property list PROP to VAL."
+  (put (coding-system-name coding-system)
+       'coding-system-property
+       (plist-put (get (coding-system-name coding-system)
+		       'coding-system-property)
+		  prop val)))
+
+(defun coding-system-category (coding-system)
+  "Return the coding category of CODING-SYSTEM."
+  (or (coding-system-get coding-system 'category)
+      (let ((type (coding-system-type coding-system)))
+	(cond ((eq type 'no-conversion)
+	       'no-conversion)
+	      ((eq type 'shift-jis)
+	       'shift-jis)
+	      ((eq type 'ucs-4)
+	       'ucs-4)
+	      ((eq type 'utf-8)
+	       'utf-8)
+	      ((eq type 'big5)
+	       'big5)
+	      ((eq type 'iso2022)
+	       (cond ((coding-system-lock-shift coding-system)
+		      'iso-lock-shift)
+		     ((coding-system-seven coding-system)
+		      'iso-7)
+		     (t
+		      (let ((dim 0)
+			    ccs
+			    (i 0))
+			(while (< i 4)
+			  (setq ccs (coding-system-charset coding-system i))
+			  (if (and ccs
+				   (> (charset-dimension ccs) dim))
+			      (setq dim (charset-dimension ccs))
+			    )
+			  (setq i (1+ i)))
+			(cond ((= dim 1) 'iso-8-1)
+			      ((= dim 2) 'iso-8-2)
+			      (t 'iso-8-designate))
+			))))))))
+	    
+;;; mule-misc.el ends here