cgit.sxemacs.org Git - packages/blob - mule-packages/skk/skk-cursor.el

   1 ;;; skk-cursor.el --- SKK cursor control.
   2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000
   3 ;; Masatake YAMATO <masata-y@is.aist-nara.ac.jp>
   4
   5 ;; Author: Masatake YAMATO <masata-y@is.aist-nara.ac.jp>
   6 ;; Maintainer: Mikio Nakajima <minakaji@osaka.email.ne.jp>
   7 ;; Version: $Id: skk-cursor.el,v 1.2 2000-11-08 01:51:43 youngs Exp $
   8 ;; Keywords: japanese
   9 ;; Last Modified: $Date: 2000-11-08 01:51:43 $
  10
  11 ;; This file is part of SKK.
  12
  13 ;; SKK is free software; you can redistribute it and/or modify it under
  14 ;; the terms of the GNU General Public License as published by the Free
  15 ;; Software Foundation; either versions 2, or (at your option) any later
  16 ;; version.
  17
  18 ;; SKK is distributed in the hope that it will be useful but WITHOUT
  19 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  20 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  21 ;; License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with SKK, see the file COPYING.  If not, write to the Free
  25 ;; Software Foundation Inc., 59 Temple Place - Suite 330, Boston,
  26 ;; MA 02111-1307, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; [Todo] Use `skk-cursor-' prefix for all variables and functions.
  31 ;;   skk-default-cursor-color -> skk-cursor-default-color
  32 ;;   skk-jisx0208-latin-cursor-color -> skk-cursor-jisx0208-latin-color
  33 ;;   skk-katakana-cursor-color -> skk-cursor-katakana-color
  34 ;;   skk-hiragana-cursor-color -> skk-cursor-hiragana-color
  35 ;;   skk-latin-cursor-color -> skk-cursor-latin-color
  36
  37 ;;; Code:
  38 (eval-when-compile (require 'static) (require 'skk-foreword))
  39
  40 ;; User variables.
  41 ;; \e$BJQ?tL>$N\e(B prefix \e$B$r\e(B skk-cursor- \e$B$KE}0l$9$l$P$3$N%0%k!<%W$,@8$-$F$/$k$s$@$,\e(B...
  42 ;; 10.x \e$B$O$3$l0J>eJQ?tL>$rJQ99$7$J$$J}$,NI$$$H;W$&$N$G!"$3$N$^$^$K$7$F$*$/!#\e(B
  43 ;;(defgroup skk-cursor nil "SKK cursor related customization."
  44 ;;  :prefix "skk-"
  45 ;;  :group 'skk)
  46
  47 (defcustom skk-default-cursor-color
  48   (if (eq skk-emacs-type 'xemacs)
  49       (frame-property (selected-frame) 'cursor-color)
  50     (cdr (assq 'cursor-color (frame-parameters (selected-frame)))))
  51   "*SKK \e$B$N%*%U$r<($9%+!<%=%k?'!#\e(B
  52 skk-use-color-cursor \e$B$,\e(B non-nil \e$B$N$H$-$K;HMQ$5$l$k!#\e(B"
  53   :group 'skk)
  54
  55 (defcustom skk-hiragana-cursor-color (if (eq skk-background-mode 'light)
  56                                          "coral4"
  57                                        "pink" )
  58   "*\e$B$+$J%b!<%I$r<($9%+!<%=%k?'!#\e(B
  59 skk-use-color-cursor \e$B$,\e(B non-nil \e$B$N$H$-$K;HMQ$5$l$k!#\e(B"
  60   :type 'string
  61   :group 'skk)
  62
  63 (defcustom skk-katakana-cursor-color (if (eq skk-background-mode 'light)
  64                                          "forestgreen"
  65                                        "green" )
  66   "*\e$B%+%?%+%J%b!<%I$r<($9%+!<%=%k?'!#\e(B
  67 skk-use-color-cursor \e$B$,\e(B non-nil \e$B$N$H$-$K;HMQ$5$l$k!#\e(B"
  68   :type 'string
  69   :group 'skk)
  70
  71 (defcustom skk-jisx0208-latin-cursor-color "gold"
  72   "*\e$BA43Q1Q;z%b!<%I$r<($9%+!<%=%k?'!#\e(B
  73 skk-use-color-cursor \e$B$,\e(B non-nil \e$B$N$H$-$K;HMQ$5$l$k!#\e(B"
  74   :type 'string
  75   :group 'skk)
  76
  77 (defcustom skk-latin-cursor-color (if (eq skk-background-mode 'light)
  78                                       "ivory4"
  79                                     "gray" )
  80   "*\e$B%"%9%-!<%b!<%I$r<($9%+!<%=%k?'!#\e(B
  81 skk-use-color-cursor \e$B$,\e(B non-nil \e$B$N$H$-$K;HMQ$5$l$k!#\e(B"
  82   :type 'string
  83   :group 'skk)
  84
  85 (defcustom skk-abbrev-cursor-color "royalblue"
  86   "*abbrev \e$B%b!<%I$r<($9%+!<%=%k?'!#\e(B
  87 skk-use-color-cursor \e$B$,\e(B non-nil \e$B$N$H$-$K;HMQ$5$l$k!#\e(B"
  88   :type 'string
  89   :group 'skk)
  90
  91 (defcustom skk-report-set-cursor-error t
  92   "*Non-nil \e$B$G$"$l$P!"%+%i!<%^%C%W@Z$l$,5/$-$?>l9g!"%(%i!<%a%C%;!<%8$rI=<($9$k!#\e(B
  93 nil \e$B$G$"$l$P!"I=<($7$J$$!#\e(B"
  94   :type 'boolean
  95   :group 'skk)
  96
  97 ;; functions.
  98 (defun skk-cursor-set-color (color)
  99   ;; \e$B%+!<%=%k$N?'$r\e(B COLOR \e$B$KJQ99$9$k!#\e(B
 100   (condition-case nil
 101       (set-cursor-color color)
 102     (error
 103      (set-cursor-color skk-default-cursor-color)
 104      (and skk-report-set-cursor-error
 105           (skk-message
 106            "\e$B%+%i!<%^%C%W@Z$l$G$9!#%G%#%U%)%k%H$N%+%i!<$r;H$$$^$9!#\e(B"
 107            "Color map is exhausting, use default cursor color" )))))
 108
 109 (defun skk-cursor-change-when-ovwrt ()
 110   (static-cond
 111    ((eq skk-emacs-type 'xemacs) (setq bar-cursor overwrite-mode))
 112    (t (if overwrite-mode
 113           (modify-frame-parameters (selected-frame) '((cursor-type bar . 3)))
 114         (modify-frame-parameters (selected-frame) '((cursor-type . box)))))))
 115
 116 (defun skk-cursor-set-properly (&optional color)
 117   ;; \e$B%+%l%s%H%P%C%U%!$N\e(B SKK \e$B$N%b!<%I$K=>$$!"%+!<%=%k$N?'$rJQ99$9$k!#\e(B
 118   ;; \e$B%*%W%7%g%J%k0z?t$N\e(B COLOR \e$B$,;XDj$5$l$?$H$-$O!"$=$N%+!<%=%k?'$r;H$&!#\e(B
 119   ;; OVWRT \e$B%b!<%I$N$H$-$O%+!<%=%k$NI}$r>.$5$/$9$k!#\e(B
 120    (if (not (get-buffer-window (current-buffer)))
 121       nil
 122     (if skk-use-color-cursor
 123         (skk-cursor-set-color
 124          (cond (color)
 125                ((not skk-mode) skk-default-cursor-color)
 126                (skk-abbrev-mode skk-abbrev-cursor-color)
 127                (skk-jisx0208-latin-mode
 128                 skk-jisx0208-latin-cursor-color)
 129                (skk-katakana skk-katakana-cursor-color)
 130                (skk-j-mode skk-hiragana-cursor-color)
 131                (t skk-latin-cursor-color))))
 132     (and skk-use-cursor-change (skk-cursor-change-when-ovwrt))))
 133
 134 ;;; advices.
 135 (defadvice kill-buffer (after skk-cursor-ad activate)
 136   "\e$BF~NO%b!<%I$K1~$8%+!<%=%k?'$rJQ2=$5$;$k!#\e(BOvwrt \e$B%b!<%I$N$H$-$K%+!<%=%kI}$r>.$5$/$9$k!#\e(B"
 137   (interactive "bKill buffer: ")
 138   (skk-cursor-set-properly))
 139
 140 (defadvice other-window (after skk-cursor-ad activate)
 141   "\e$BF~NO%b!<%I$K1~$8%+!<%=%k?'$rJQ2=$5$;$k!#\e(BOvwrt \e$B%b!<%I$N$H$-$K%+!<%=%kI}$r>.$5$/$9$k!#\e(B"
 142   (interactive "p")
 143   (skk-cursor-set-properly))
 144
 145 (static-cond
 146  ((featurep 'xemacs)
 147   (defadvice select-frame (after skk-cursor-ad activate)
 148     "\e$BF~NO%b!<%I$K1~$8%+!<%=%k?'$rJQ2=$5$;$k!#\e(BOvwrt \e$B%b!<%I$N$H$-$K%+!<%=%kI}$r>.$5$/$9$k!#\e(B"
 149     (skk-cursor-set-properly)))
 150  (t
 151   (defadvice select-frame (after skk-cursor-ad activate)
 152     "\e$BF~NO%b!<%I$K1~$8%+!<%=%k?'$rJQ2=$5$;$k!#\e(BOvwrt \e$B%b!<%I$N$H$-$K%+!<%=%kI}$r>.$5$/$9$k!#\e(B"
 153     (interactive "e")
 154     (skk-cursor-set-properly))))
 155
 156 (defadvice switch-to-buffer (after skk-cursor-ad activate)
 157   "\e$BF~NO%b!<%I$K1~$8%+!<%=%k?'$rJQ2=$5$;$k!#\e(BOvwrt \e$B%b!<%I$N$H$-$K%+!<%=%kI}$r>.$5$/$9$k!#\e(B"
 158   (interactive "BSwitch to buffer: ")
 159   (skk-cursor-set-properly))
 160
 161 (let ((funcs '(
 162                ;; cover to original Emacs functions.
 163                bury-buffer
 164                delete-frame
 165                delete-window
 166                ;; execute-extended-command
 167 ;              kill-buffer
 168 ;              other-window
 169                overwrite-mode
 170                pop-to-buffer
 171 ;              select-frame
 172                select-window
 173 ;              switch-to-buffer
 174                ;; cover to SKK functions.
 175                skk-auto-fill-mode
 176                skk-gyakubiki-katakana-message
 177                skk-gyakubiki-katakana-region
 178                skk-gyakubiki-message
 179                skk-hiragana-region
 180                skk-hurigana-katakana-region
 181                skk-hurigana-message
 182                skk-hurigana-region
 183                skk-jisx0201-region
 184                skk-jisx0208-latin-region
 185                skk-katakana-region
 186                skk-latin-region
 187                skk-mode
 188                skk-romaji-message
 189                skk-romaji-region
 190                skk-save-jisyo
 191                skk-toggle-kana)))
 192   (while funcs
 193     (eval
 194      (`
 195       (defadvice (, (intern (symbol-name (car funcs))))
 196         (after skk-cursor-ad activate)
 197         "\e$BF~NO%b!<%I$K1~$8%+!<%=%k?'$rJQ2=$5$;$k!#\e(BOvwrt \e$B%b!<%I$N$H$-$K%+!<%=%kI}$r>.$5$/$9$k!#\e(B"
 198         ;; \e$BJL$N%P%C%U%!$XHt$V%3%^%s%I$O\e(B skk-mode \e$B$,\e(B nil \e$B$G$b%+!<%=%k?'$rD4@0$9$kI,MW$,\e(B
 199         ;; \e$B$"$k!#\e(B
 200         ;; CLASS \e$B$O\e(B after.
 201         (skk-cursor-set-properly))))
 202     (setq funcs (cdr funcs))))
 203
 204 (static-cond
 205  ((featurep 'xemacs)
 206   (defadvice recenter (after skk-cursor-ad activate)
 207     "\e$BF~NO%b!<%I$K1~$8%+!<%=%k?'$rJQ2=$5$;$k!#\e(BOvwrt \e$B%b!<%I$N$H$-$K%+!<%=%kI}$r>.$5$/$9$k!#\e(B"
 208     (and skk-mode (skk-cursor-set-properly))))
 209  (t
 210   (defadvice recenter (after skk-cursor-ad activate)
 211     "\e$BF~NO%b!<%I$K1~$8%+!<%=%k?'$rJQ2=$5$;$k!#\e(BOvwrt \e$B%b!<%I$N$H$-$K%+!<%=%kI}$r>.$5$/$9$k!#\e(B"
 212     (interactive "P")
 213     (and skk-mode (skk-cursor-set-properly)))))
 214
 215 (let ((funcs '(
 216                goto-line
 217                insert-file
 218                keyboard-quit
 219 ;              recenter
 220                yank
 221                yank-pop
 222                ;; cover to hilit functions.
 223                hilit-recenter
 224                hilit-yank
 225                hilit-yank-pop
 226                ;; cover to VIP/Viper functions.
 227                vip-Append
 228                vip-Insert
 229                vip-insert
 230                vip-intercept-ESC-key
 231                vip-open-line
 232                viper-Append
 233                viper-Insert
 234                viper-hide-replace-overlay
 235                viper-insert
 236                viper-intercept-ESC-key
 237                viper-open-line
 238                )))
 239   (while funcs
 240     (eval
 241      (`
 242       (defadvice (, (intern (symbol-name (car funcs))))
 243         (after skk-cursor-ad activate)
 244         "\e$BF~NO%b!<%I$K1~$8%+!<%=%k?'$rJQ2=$5$;$k!#\e(BOvwrt \e$B%b!<%I$N$H$-$K%+!<%=%kI}$r>.$5$/$9$k!#\e(B"
 245         ;; skk-mode \e$B$,\e(B nil \e$B$+\e(B non-nil \e$B$+$NH=DjIU$-!#\e(B
 246         ;; CLASS \e$B$O\e(B after.
 247         (and skk-mode (skk-cursor-set-properly)))))
 248     (setq funcs (cdr funcs))))
 249
 250 ;;\e$BF~NO%b!<%I$K1~$8%+!<%=%k?'$rJQ2=$5$;$k!#\e(BOvwrt \e$B%b!<%I$N$H$-$K%+!<%=%kI}$r>.$5$/$9$k!#\e(B
 251 ;; CLASS \e$B$O\e(B before.
 252 ;; \e$B%_%K%P%C%U%!$+$i85$N%+%l%s%H%P%C%U%!$rC5$7=P$7!"%+!<%=%k$r%;%C%H!#\e(B
 253 (let ((funcs '(exit-minibuffer)))
 254   (static-if (eq skk-emacs-type 'xemacs)
 255       (setq funcs (cons 'minibuffer-keyboard-quit funcs)))
 256   (while funcs
 257     (eval
 258      (`
 259       (defadvice (, (intern (symbol-name (car funcs))))
 260         (before skk-cursor-ad activate)
 261         "\e$BF~NO%b!<%I$K1~$8%+!<%=%k?'$rJQ2=$5$;$k!#\e(BOvwrt \e$B%b!<%I$N$H$-$K%+!<%=%kI}$r>.$5$/$9$k!#\e(B"
 262         ;; \e$B%_%K%P%C%U%!$+$i85$N%+%l%s%H%P%C%U%!$rC5$7=P$7!"%+!<%=%k$r%;%C%H!#\e(B
 263         ;; CLASS \e$B$O\e(B before.
 264         (with-current-buffer (skk-minibuffer-origin) (skk-cursor-set-properly)))))
 265     (setq funcs (cdr funcs))))
 266
 267 ;; \e$BF~NO%b!<%I$K1~$8%+!<%=%k?'$rJQ2=$5$;$k!#\e(BOvwrt \e$B%b!<%I$N$H$-$K%+!<%=%kI}$r>.$5$/$9$k!#\e(B
 268 ;; CLASS \e$B$O\e(B around.
 269 ;; skk-abbrev-mode \e$B$N$H$-$@$1%+!<%=%k$r%;%C%H!#\e(B
 270 (let ((funcs '(
 271                ;; cover to original Emacs functions.
 272                newline
 273                ;; cover to SKK functions.
 274                skk-delete-backward-char
 275                skk-insert
 276                skk-start-henkan
 277                )))
 278   (while funcs
 279     (eval
 280      (`
 281       (defadvice (, (intern (symbol-name (car funcs))))
 282         (around skk-cursor-ad activate preactivate)
 283         "\e$BF~NO%b!<%I$K1~$8%+!<%=%k?'$rJQ2=$5$;$k!#\e(BOvwrt \e$B%b!<%I$N$H$-$K%+!<%=%kI}$r>.$5$/$9$k!#\e(B"
 284         ;; CLASS \e$B$O\e(B around.
 285         ;; skk-abbrev-mode \e$B$N$H$-$@$1%+!<%=%k$r%;%C%H!#\e(B
 286         (if skk-abbrev-mode
 287             (progn ad-do-it (skk-cursor-set-properly))
 288           ad-do-it))))
 289     (setq funcs (cdr funcs))))
 290
 291 (static-when (featurep 'xemacs)
 292   (defadvice abort-recursive-edit (before skk-cursor-ad activate preactivate)
 293     "\e$BF~NO%b!<%I$K1~$8%+!<%=%k?'$rJQ2=$5$;$k!#\e(BOvwrt \e$B%b!<%I$N$H$-$K%+!<%=%kI}$r>.$5$/$9$k!#\e(B"
 294     (with-current-buffer (skk-minibuffer-origin) (skk-cursor-set-properly))))
 295
 296 (defadvice skk-latin-mode (after skk-cursor-ad activate)
 297   "\e$B%+!<%=%k?'$r\e(B skk-latin-cursor-color \e$B$KJQ2=$5$;$k!#\e(BOvwrt \e$B%b!<%I$N$H$-$K%+!<%=%kI}$r>.$5$/$9$k!#\e(B"
 298   (skk-cursor-set-properly skk-latin-cursor-color))
 299
 300 (defadvice skk-jisx0208-latin-mode (after skk-cursor-ad activate)
 301   "\e$B%+!<%=%k?'$r\e(B skk-jisx0208-latin-cursor-color \e$B$KJQ2=$5$;$k!#\e(BOvwrt \e$B%b!<%I$N$H$-$K%+!<%=%kI}$r>.$5$/$9$k!#\e(B"
 302   (skk-cursor-set-properly skk-jisx0208-latin-cursor-color))
 303
 304 (defadvice skk-abbrev-mode (after skk-cursor-ad activate)
 305   "\e$B1~$8%+!<%=%k?'$r\e(B skk-abbrev-cursor-color \e$B$KJQ2=$5$;$k!#\e(BOvwrt \e$B%b!<%I$N$H$-$K%+!<%=%kI}$r>.$5$/$9$k!#\e(B"
 306   (skk-cursor-set-properly skk-abbrev-cursor-color))
 307
 308 (defadvice skk-kakutei (after skk-cursor-ad activate)
 309   "\e$BF~NO%b!<%I$K1~$8%+!<%=%k?'$rJQ2=$5$;$k!#\e(BOvwrt \e$B%b!<%I$N$H$-$K%+!<%=%kI}$r>.$5$/$9$k!#\e(B"
 310   (if (interactive-p) (skk-cursor-set-properly)))
 311
 312 ;; VIP/Viper related
 313 (defadvice skk-mode (after skk-viper-ad activate)
 314   (add-hook 'viper-post-command-hooks
 315             (function (lambda () (and skk-mode (skk-set-cursor-properly))))
 316             'append 'local))
 317
 318 ;;; Hooks.
 319 (add-hook 'after-make-frame-hook 'skk-cursor-set-properly)
 320 (add-hook 'minibuffer-setup-hook 'skk-cursor-set-properly)
 321 (add-hook 'minibuffer-exit-hook 'skk-cursor-set-properly 'append)
 322
 323 (defalias 'skk-set-cursor-color 'skk-cursor-set-color)
 324 (defalias 'skk-change-cursor-when-ovwrt 'skk-cursor-change-when-ovwrt)
 325 (defalias 'skk-set-cursor-properly 'skk-cursor-set-properly)
 326
 327 ;; \e$B:G=i$K\e(B load \e$B$5$l$?$H$-$O!"\e(Bskk-cursor adviced function \e$B$K$J$kA0$N4X?t$K$h$C$F\e(B
 328 ;; \e$B8F$P$l$F$*$j!"\e(Badvice \e$B$,8z$$$F$J$$$N$G!"%H%C%W%l%Y%k$G%+!<%=%k$r9g$o$;$F$*$/!#\e(B
 329 (and (get-buffer-window (current-buffer))
 330      ;; only first time when this file loaded.
 331      ;;(not skk-mode-invoked)
 332      (skk-cursor-set-properly skk-hiragana-cursor-color))
 333
 334 ;;; Hooks
 335 (add-hook 'isearch-mode-end-hook 'skk-cursor-set-properly 'append)
 336
 337 (provide 'skk-cursor)
 338 ;;; Local Variables:
 339 ;;; End:
 340 ;;; skk-cursor.el ends here