Mercurial > hg > xemacs-beta

comparison lisp/egg/egg.el @ 142:1856695b1fa9 r20-2b5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-2b5
author cvs
date Mon, 13 Aug 2007 09:33:18 +0200
parents 585fb297b004
children 25f70ba0133c
comparison
equal deleted inserted replaced
141:ea67ad3963dc 142:1856695b1fa9
403 "FSFmacs event emulator that shoves non key events into 403 "FSFmacs event emulator that shoves non key events into
404 unread-command-events to facilitate translation from Mule-2.3" 404 unread-command-events to facilitate translation from Mule-2.3"
405 (let ((event (make-event)) 405 (let ((event (make-event))
406 (ch nil)) 406 (ch nil))
407 (next-command-event event) 407 (next-command-event event)
408 (if (and (key-press-event-p event) 408 (if (key-press-event-p event)
409 (eq 0 (event-modifier-bits event))) 409 (if (eq 0 (event-modifier-bits event))
410 (setq ch (event-key event)) 410 (setq ch (event-key event))
411 (if (eq 1 (event-modifier-bits event)) 411 (if (eq 1 (event-modifier-bits event))
412 (setq ch (int-to-char (- (char-to-int (event-key event)) 96))) 412 (setq ch (int-to-char (- (char-to-int (event-key event)) 96)))
413 (setq unread-command-events (list event)))) 413 (setq unread-command-events (list event))))
414 (setq unread-command-events (list event)))
414 ch)) 415 ch))
415 416
416 (eval-when-compile (require 'egg-jsymbol)) 417 (eval-when-compile (require 'egg-jsymbol))
417 418
418 ;;; 419 ;;;
597 (inhibit-quit t) 598 (inhibit-quit t)
598 (menubuffer (get-buffer-create " *menu*")) 599 (menubuffer (get-buffer-create " *menu*"))
599 (minibuffer (window-buffer (minibuffer-window))) 600 (minibuffer (window-buffer (minibuffer-window)))
600 value) 601 value)
601 (save-window-excursion 602 (save-window-excursion
602 (if (fboundp 'redirect-frame-focus)
603 (redirect-frame-focus (selected-frame)
604 (window-frame (minibuffer-window))))
605 (set-window-buffer (minibuffer-window) menubuffer) 603 (set-window-buffer (minibuffer-window) menubuffer)
606 (select-window (minibuffer-window)) 604 (select-window (minibuffer-window))
607 (set-buffer menubuffer) 605 (set-buffer menubuffer)
608 (delete-region (point-min) (point-max)) 606 (delete-region (point-min) (point-max))
609 (insert (nth 1 menu)) 607 (insert (nth 1 menu))
1626 1624
1627 (defun its:delete-charp (ch) 1625 (defun its:delete-charp (ch)
1628 (and (characterp ch) (<= ch 127) 1626 (and (characterp ch) (<= ch 127)
1629 (eq (lookup-key fence-mode-map (char-to-string ch)) 'fence-backward-delete-char))) 1627 (eq (lookup-key fence-mode-map (char-to-string ch)) 'fence-backward-delete-char)))
1630 1628
1629 (defvar egg:fence-buffer nil "Buffer fence is active in")
1630
1631 (defun fence-self-insert-command () 1631 (defun fence-self-insert-command ()
1632 (interactive) 1632 (interactive)
1633 (let ((ch (event-to-character last-command-event))) 1633 (if (not (eq (current-buffer) egg:fence-buffer))
1634 (cond((or (not egg:*input-mode*) 1634 nil ;; #### This is to bandaid a deep event-handling bug
1635 (null (get-next-map its:*current-map* ch))) 1635 (let ((ch (event-to-character last-command-event)))
1636 (insert ch)) 1636 (cond((or (not egg:*input-mode*)
1637 (t 1637 (null (get-next-map its:*current-map* ch)))
1638 (insert ch) 1638 (insert ch))
1639 (its:translate-region (1- (point)) (point) t))))) 1639 (t
1640 (insert ch)
1641 (its:translate-region (1- (point)) (point) t))))))
1640 1642
1641 ;;; 1643 ;;;
1642 ;;; its: completing-read system 1644 ;;; its: completing-read system
1643 ;;; 1645 ;;;
1644 1646
2080 2082
2081 (defvar egg:*in-fence-mode* nil "T if in fence mode.") 2083 (defvar egg:*in-fence-mode* nil "T if in fence mode.")
2082 (make-variable-buffer-local 'egg:*in-fence-mode*) 2084 (make-variable-buffer-local 'egg:*in-fence-mode*)
2083 (set-default 'egg:*in-fence-mode* nil) 2085 (set-default 'egg:*in-fence-mode* nil)
2084 2086
2085 (defvar egg:fence-buffer nil "Buffer fence is active in")
2086
2087 ;;(load-library "its-dump/roma-kana") ;;;(define-its-mode "roma-kana" " a$B$"(B") 2087 ;;(load-library "its-dump/roma-kana") ;;;(define-its-mode "roma-kana" " a$B$"(B")
2088 ;;(load-library "its-dump/roma-kata") ;;;(define-its-mode "roma-kata" " a$B%"(B") 2088 ;;(load-library "its-dump/roma-kata") ;;;(define-its-mode "roma-kata" " a$B%"(B")
2089 ;;(load-library "its-dump/downcase") ;;;(define-its-mode "downcase" " a a") 2089 ;;(load-library "its-dump/downcase") ;;;(define-its-mode "downcase" " a a")
2090 ;;(load-library "its-dump/upcase") ;;;(define-its-mode "upcase" " a A") 2090 ;;(load-library "its-dump/upcase") ;;;(define-its-mode "upcase" " a A")
2091 ;;(load-library "its-dump/zenkaku-downcase") ;;;(define-its-mode "zenkaku-downcase" " a$B#a(B") 2091 ;;(load-library "its-dump/zenkaku-downcase") ;;;(define-its-mode "zenkaku-downcase" " a$B#a(B")
2581 (insert egg:*fence-close*) 2581 (insert egg:*fence-close*)
2582 (or (markerp egg:*region-end*) (set-marker-insertion-type (setq egg:*region-end* (make-marker)) t)) 2582 (or (markerp egg:*region-end*) (set-marker-insertion-type (setq egg:*region-end* (make-marker)) t))
2583 (set-marker egg:*region-end* egg:*region-start*) 2583 (set-marker egg:*region-end* egg:*region-start*)
2584 (egg:fence-face-on) 2584 (egg:fence-face-on)
2585 (goto-char egg:*region-start*) 2585 (goto-char egg:*region-start*)
2586 (add-hook 'pre-command-hook 'fence-pre-command-hook) 2586 (add-hook 'post-command-hook 'fence-post-command-hook)
2587 ) 2587 )
2588 2588
2589 (defun henkan-fence-region-or-single-space () 2589 (defun henkan-fence-region-or-single-space ()
2590 (interactive) 2590 (interactive)
2591 (if egg:*input-mode* 2591 (if egg:*input-mode*
2643 (transpose-chars arg) 2643 (transpose-chars arg)
2644 (beep))) 2644 (beep)))
2645 2645
2646 (defun egg:exit-if-empty-region () 2646 (defun egg:exit-if-empty-region ()
2647 (if (= egg:*region-start* egg:*region-end*) 2647 (if (= egg:*region-start* egg:*region-end*)
2648 (fence-exit-mode))) 2648 (fence-exit-internal)))
2649 2649
2650 (defun fence-delete-char () 2650 (defun fence-delete-char ()
2651 (interactive) 2651 (interactive)
2652 (if (< (point) egg:*region-end*) 2652 (if (< (point) egg:*region-end*)
2653 (progn 2653 (progn
2668 (delete-region (point) egg:*region-end*) 2668 (delete-region (point) egg:*region-end*)
2669 (egg:exit-if-empty-region)) 2669 (egg:exit-if-empty-region))
2670 2670
2671 (defun fence-exit-mode () 2671 (defun fence-exit-mode ()
2672 (interactive) 2672 (interactive)
2673 (fence-exit-internal))
2674
2675 (defun fence-exit-internal ()
2673 (delete-region (- egg:*region-start* (length egg:*fence-open*)) egg:*region-start*) 2676 (delete-region (- egg:*region-start* (length egg:*fence-open*)) egg:*region-start*)
2674 (delete-region egg:*region-end* (+ egg:*region-end* (length egg:*fence-close*))) 2677 (delete-region egg:*region-end* (+ egg:*region-end* (length egg:*fence-close*)))
2675 (egg:fence-face-off) 2678 (egg:fence-face-off)
2676 (if its:*previous-map* 2679 (if its:*previous-map*
2677 (setq its:*current-map* its:*previous-map* 2680 (setq its:*current-map* its:*previous-map*
2690 correspoding to character position.") 2693 correspoding to character position.")
2691 2694
2692 (defun egg:quit-egg-mode () 2695 (defun egg:quit-egg-mode ()
2693 ;;;(use-global-map egg:*global-map-backup*) 2696 ;;;(use-global-map egg:*global-map-backup*)
2694 (use-local-map egg:*local-map-backup*) 2697 (use-local-map egg:*local-map-backup*)
2695 (remove-hook 'pre-command-hook 'fence-pre-command-hook) 2698 (remove-hook 'post-command-hook 'fence-post-command-hook)
2696 (setq egg:*in-fence-mode* nil) 2699 (setq egg:*in-fence-mode* nil)
2697 (egg:mode-line-display) 2700 (egg:mode-line-display)
2698 (if overwrite-mode 2701 (if overwrite-mode
2699 (let ((str (buffer-substring egg:*region-end* egg:*region-start*))) 2702 (let ((str (buffer-substring egg:*region-end* egg:*region-start*)))
2700 (delete-text-in-column nil (+ (current-column) (string-width str))))) 2703 (delete-text-in-column nil (+ (current-column) (string-width str)))))
2713 (if egg-insert-after-hook 2716 (if egg-insert-after-hook
2714 (run-hooks 'egg-insert-after-hook)) 2717 (run-hooks 'egg-insert-after-hook))
2715 ) 2718 )
2716 2719
2717 (defun fence-cancel-input () 2720 (defun fence-cancel-input ()
2721 "Cancel all fence operations in the current buffer"
2718 (interactive) 2722 (interactive)
2723 (fence-kill-operation))
2724
2725 (defun fence-kill-operation ()
2726 "Internal method to remove fences"
2719 (delete-region egg:*region-start* egg:*region-end*) 2727 (delete-region egg:*region-start* egg:*region-end*)
2720 (fence-exit-mode)) 2728 (fence-exit-internal))
2721 2729
2722 (defun fence-mouse-protect () 2730 (defun fence-post-command-hook ()
2723 "Cancel entry in progress if mouse events occur." 2731 ;; For use as the value of `post-command-hook' when fence is active.
2724 (if egg:*in-fence-mode* 2732 ;; If we got out of the region specified by the fence,
2725 (save-excursion
2726 (its:reset-input)
2727 (fence-cancel-input))))
2728
2729 (if (boundp 'mouse-track-cleanup-hook)
2730 (add-hook 'mouse-track-cleanup-hook 'fence-mouse-protect))
2731
2732 (defun fence-pre-command-hook ()
2733 ;; cribbed off of isearch-mode
2734 ;;
2735 ;; For use as the value of `pre-command-hook' when fence is active.
2736 ;; If the command about to be executed is not ours,
2737 ;; kill the fence before that command is executed. 2733 ;; kill the fence before that command is executed.
2738 ;; 2734 ;;
2739 (cond ((not (eq (current-buffer) egg:fence-buffer)) 2735 (cond ((not (eq (current-buffer) egg:fence-buffer))
2740 ;; If the buffer (likely meaning "frame") has changed, bail. 2736 ;; If the buffer (likely meaning "frame") has changed, bail.
2741 ;; This can also happen if a proc filter has popped up another 2737 ;; This can also happen if a proc filter has popped up another
2743 ;; but the way in which egg would have hosed you in that 2739 ;; but the way in which egg would have hosed you in that
2744 ;; case is unarguably even worse. 2740 ;; case is unarguably even worse.
2745 (save-excursion 2741 (save-excursion
2746 (set-buffer egg:fence-buffer) 2742 (set-buffer egg:fence-buffer)
2747 (its:reset-input) 2743 (its:reset-input)
2748 (fence-cancel-input))) 2744 (fence-kill-operation)))
2749 ((not (and this-command 2745 ((or (< (point) egg:*region-start*)
2750 (symbolp this-command) 2746 (> (point) egg:*region-end*))
2751 (get this-command 'egg-fence-command))) 2747 (save-excursion
2752 (its:reset-input) 2748 (its:reset-input)
2753 (fence-cancel-input)) 2749 (fence-kill-operation)))))
2754 (t
2755 (if (or (not (pos-visible-in-window-safe
2756 (marker-position egg:*region-start*)))
2757 (not (pos-visible-in-window-safe
2758 (marker-position egg:*region-end*))))
2759 (recenter))))
2760 )
2761 2750
2762 (defun egg-lang-switch-callback () 2751 (defun egg-lang-switch-callback ()
2763 "Do whatever processing is necessary when the language-environment changes." 2752 "Do whatever processing is necessary when the language-environment changes."
2764 (if egg:*in-fence-mode* 2753 (if egg:*in-fence-mode*
2765 (progn 2754 (progn
2766 (its:reset-input) 2755 (its:reset-input)
2767 (fence-cancel-input))) 2756 (fence-kill-operation)))
2768 (let ((func (get current-language-environment 'set-egg-environ))) 2757 (let ((func (get current-language-environment 'set-egg-environ)))
2769 (if (not (null func)) 2758 (if (not (null func))
2770 (funcall func))) 2759 (funcall func)))
2771 (egg:mode-line-display)) 2760 (egg:mode-line-display))
2772 2761
2821 (define-key fence-mode-map [delete] 'fence-backward-delete-char) 2810 (define-key fence-mode-map [delete] 'fence-backward-delete-char)
2822 (define-key fence-mode-map [backspace] 'fence-backward-delete-char) 2811 (define-key fence-mode-map [backspace] 'fence-backward-delete-char)
2823 (define-key fence-mode-map [right] 'fence-forward-char) 2812 (define-key fence-mode-map [right] 'fence-forward-char)
2824 (define-key fence-mode-map [left] 'fence-backward-char) 2813 (define-key fence-mode-map [left] 'fence-backward-char)
2825 2814
2826 (put 'fence-self-insert-command 'egg-fence-command t)
2827 (put 'fence-hiragana 'egg-fence-command t)
2828 (put 'fence-katakana 'egg-fence-command t)
2829 (put 'fence-hankaku 'egg-fence-command t)
2830 (put 'fence-zenkaku 'egg-fence-command t)
2831 (put 'its:select-hiragana 'egg-fence-command t)
2832 (put 'its:select-katakana 'egg-fence-command t)
2833 (put 'its:select-downcase 'egg-fence-command t)
2834 (put 'its:select-upcase 'egg-fence-command t)
2835 (put 'its:select-zenkaku-downcase 'egg-fence-command t)
2836 (put 'its:select-zenkaku-upcase 'egg-fence-command t)
2837 (put 'its:minibuffer-completion-help 'egg-fence-command t)
2838 (put 'henkan-fence-region-or-single-space 'egg-fence-command t)
2839 (put 'henkan-fence-region 'egg-fence-command t)
2840 (put 'fence-beginning-of-line 'egg-fence-command t)
2841 (put 'fence-backward-char 'egg-fence-command t)
2842 (put 'fence-cancel-input 'egg-fence-command t)
2843 (put 'fence-delete-char 'egg-fence-command t)
2844 (put 'fence-end-of-line 'egg-fence-command t)
2845 (put 'fence-forward-char 'egg-fence-command t)
2846 (put 'fence-cancel-input 'egg-fence-command t)
2847 (put 'fence-mode-help-command 'egg-fence-command t)
2848 (put 'fence-kill-line 'egg-fence-command t)
2849 (put 'fence-exit-mode 'egg-fence-command t)
2850 (put 'fence-exit-mode 'egg-fence-command t)
2851 (put 'fence-exit-mode 'egg-fence-command t)
2852 (put 'its:select-previous-mode 'egg-fence-command t)
2853 (put 'fence-transpose-chars 'egg-fence-command t)
2854 (put 'eval-expression 'egg-fence-command t)
2855 (put 'fence-toggle-egg-mode 'egg-fence-command t)
2856 (put 'jis-code-input 'egg-fence-command t)
2857 (put 'fence-backward-delete-char 'egg-fence-command t)
2858 (put 'fence-backward-delete-char 'egg-fence-command t)
2859 (put 'fence-backward-delete-char 'egg-fence-command t)
2860 (put 'fence-forward-char 'egg-fence-command t)
2861 (put 'fence-backward-char 'egg-fence-command t)
2862 (put 'hiragana-region 'egg-fence-command t)
2863 (put 'hiragana-paragraph 'egg-fence-command t)
2864 (put 'hiragana-sentance 'egg-fence-command t)
2865 (put 'katakana-region 'egg-fence-command t)
2866 (put 'katakana-paragraph 'egg-fence-command t)
2867 (put 'katakana-sentance 'egg-fence-command t)
2868 (put 'hankaku-region 'egg-fence-command t)
2869 (put 'hankaku-paragraph 'egg-fence-command t)
2870 (put 'hankaku-sentance 'egg-fence-command t)
2871 (put 'hankaku-word 'egg-fence-command t)
2872 (put 'zenkaku-region 'egg-fence-command t)
2873 (put 'zenkaku-paragraph 'egg-fence-command t)
2874 (put 'zenkaku-sentance 'egg-fence-command t)
2875 (put 'zenkaku-word 'egg-fence-command t)
2876 (put 'roma-kana-region 'egg-fence-command t)
2877 (put 'roma-kana-paragraph 'egg-fence-command t)
2878 (put 'roma-kana-sentance 'egg-fence-command t)
2879 (put 'roma-kana-word 'egg-fence-command t)
2880 (put 'roma-kanji-region 'egg-fence-command t)
2881 (put 'roma-kanji-paragraph 'egg-fence-command t)
2882 (put 'roma-kanji-sentance 'egg-fence-command t)
2883 (put 'roma-kanji-word 'egg-fence-command t)
2884 (put 'its:select-mode 'egg-fence-command t)
2885 (put 'its:select-mode-from-menu 'egg-fence-command t)
2886 (put 'its:next-mode 'egg-fence-command t)
2887 (put 'its:previous-mode 'egg-fence-command t)
2888 (put 'its:select-hiragana 'egg-fence-command t)
2889 (put 'its:select-katakana 'egg-fence-command t)
2890 (put 'its:select-downcase 'egg-fence-command t)
2891 (put 'its:select-upcase 'egg-fence-command t)
2892 (put 'its:select-zenkaku-downcase 'egg-fence-command t)
2893 (put 'its:select-zenkaku-upcase 'egg-fence-command t)
2894 (put 'its:select-mode-temporally 'egg-fence-command t)
2895 (put 'its:select-previous-mode 'egg-fence-command t)
2896 (put 'fence-toggle-egg-mode 'egg-fence-command t)
2897 (put 'fence-transpose-chars 'egg-fence-command t)
2898 (put 'henkan-region 'egg-fence-command t)
2899 (put 'henkan-paragraph 'egg-fence-command t)
2900 (put 'henkan-sentance 'egg-fence-command t)
2901 (put 'henkan-word 'egg-fence-command t)
2902 (put 'henkan-kakutei 'egg-fence-command t)
2903 (put 'gyaku-henkan-region 'egg-fence-command t)
2904 (put 'gyaku-henkan-sentance 'egg-fence-command t)
2905 (put 'gyaku-henkan-word 'egg-fence-command t)
2906 (put 'gyaku-henkan-kakutei 'egg-fence-command t)
2907 (put 'henkan-kakutei-first-char 'egg-fence-command t)
2908 (put 'henkan-kakutei-before-point 'egg-fence-command t)
2909 (put 'sai-henkan 'egg-fence-command t)
2910 (put 'henkan-forward-bunsetu 'egg-fence-command t)
2911 (put 'henkan-backward-bunsetu 'egg-fence-command t)
2912 (put 'henkan-first-bunsetu 'egg-fence-command t)
2913 (put 'henkan-last-bunsetu 'egg-fence-command t)
2914 (put 'henkan-hiragana 'egg-fence-command t)
2915 (put 'henkan-katakana 'egg-fence-command t)
2916 (put 'henkan-next-kouho 'egg-fence-command t)
2917 (put 'henkan-next-kouho-dai 'egg-fence-command t)
2918 (put 'henkan-next-kouho-sho 'egg-fence-command t)
2919 (put 'henkan-previous-kouho 'egg-fence-command t)
2920 (put 'henkan-previous-kouho-dai 'egg-fence-command t)
2921 (put 'henkan-previous-kouho-sho 'egg-fence-command t)
2922 (put 'henkan-bunsetu-chijime-dai 'egg-fence-command t)
2923 (put 'henkan-bunsetu-chijime-sho 'egg-fence-command t)
2924 (put 'henkan-bunsetu-nobasi-dai 'egg-fence-command t)
2925 (put 'henkan-bunsetu-nobasi-sho 'egg-fence-command t)
2926 (put 'henkan-saishou-bunsetu 'egg-fence-command t)
2927 (put 'henkan-saichou-bunsetu 'egg-fence-command t)
2928 (put 'henkan-quit 'egg-fence-command t)
2929 (put 'henkan-select-kouho-dai 'egg-fence-command t)
2930 (put 'henkan-select-kouho-sho 'egg-fence-command t)
2931 (put 'henkan-word-off 'egg-fence-command t)
2932 (put 'henkan-kakutei-and-self-insert 'egg-fence-command t)
2933 (put 'henkan-help-command 'egg-fence-command t)
2934 (put 'toroku-region 'egg-fence-command t)
2935 (put 'toroku-henkan-mode 'egg-fence-command t)
2936 (put 'recenter 'egg-fence-command t)
2937
2938
2939 ;;;---------------------------------------------------------------------- 2815 ;;;----------------------------------------------------------------------
2940 ;;; 2816 ;;;
2941 ;;; Read hiragana from minibuffer 2817 ;;; Read hiragana from minibuffer
2942 ;;; 2818 ;;;
2943 ;;;---------------------------------------------------------------------- 2819 ;;;----------------------------------------------------------------------
2993 (define-key global-map "\C-^" 'special-symbol-input) 2869 (define-key global-map "\C-^" 'special-symbol-input)
2994 2870
2995 (autoload 'busyu-input "egg-busyu" nil t) 2871 (autoload 'busyu-input "egg-busyu" nil t)
2996 (autoload 'kakusuu-input "egg-busyu" nil t) 2872 (autoload 'kakusuu-input "egg-busyu" nil t)
2997 2873
2874 ;; put us into all existing buffer's modelines
2875 (if (not (featurep 'egg))
2876 (mapc-internal
2877 (lambda (buf)
2878 (save-excursion
2879 (set-buffer buf)
2880 (setq modeline-format (cons (list 'display-minibuffer-mode-in-minibuffer
2881 ;;; minibuffer mode in minibuffer
2882 (list
2883 (list 'its:*previous-map* "<" "[")
2884 'mode-line-egg-mode
2885 (list 'its:*previous-map* ">" "]")
2886 )
2887 ;;;; minibuffer mode in mode line
2888 (list
2889 (list 'minibuffer-window-selected
2890 (list 'display-minibuffer-mode
2891 "m"
2892 " ")
2893 " ")
2894 (list 'its:*previous-map* "<" "[")
2895 (list 'minibuffer-window-selected
2896 (list 'display-minibuffer-mode
2897 'mode-line-egg-mode-in-minibuffer
2898 'mode-line-egg-mode)
2899 'mode-line-egg-mode)
2900 (list 'its:*previous-map* ">" "]")
2901 ))
2902 modeline-format))))
2903 (buffer-list)))
2904
2998 (provide 'egg) 2905 (provide 'egg)
2999 2906
3000 ;; if set-lang-environment has already been called, call egg-lang-switch-callback 2907 ;; if set-lang-environment has already been called, call egg-lang-switch-callback
3001 (if (not (null current-language-environment)) 2908 (if (not (null current-language-environment))
3002 (egg-lang-switch-callback)) 2909 (egg-lang-switch-callback))