|
0
|
1 ;;; electric.el --- window maker and Command loop for `electric' modes.
|
|
|
2
|
|
72
|
3 ;; Copyright (C) 1985, 1986, 1995 Free Software Foundation, Inc.
|
|
0
|
4
|
|
|
5 ;; Author: K. Shane Hartman
|
|
|
6 ;; Maintainer: FSF
|
|
|
7 ;; Keywords: extensions
|
|
|
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 Free
|
|
72
|
23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
|
|
24 ;; 02111-1307, USA.
|
|
0
|
25
|
|
72
|
26 ;;; Synched up with: FSF 19.34.
|
|
0
|
27
|
|
|
28 ;;; Commentary:
|
|
|
29
|
|
|
30 ; zaaaaaaap
|
|
|
31
|
|
|
32 ;;; Code:
|
|
|
33
|
|
|
34 ;; This loop is the guts for non-standard modes which retain control
|
|
|
35 ;; until some event occurs. It is a `do-forever', the only way out is
|
|
|
36 ;; to throw. It assumes that you have set up the keymap, window, and
|
|
|
37 ;; everything else: all it does is read commands and execute them -
|
|
|
38 ;; providing error messages should one occur (if there is no loop
|
|
|
39 ;; function - which see). The required argument is a tag which should
|
|
|
40 ;; expect a value of nil if the user decides to punt. The second
|
|
|
41 ;; argument is the prompt to be used: if nil, use "->", if 'noprompt,
|
|
|
42 ;; don't use a prompt, if a string, use that string as prompt, and if
|
|
|
43 ;; a function of no variable, it will be evaluated in every iteration
|
|
|
44 ;; of the loop and its return value, which can be nil, 'noprompt or a
|
|
|
45 ;; string, will be used as prompt. Given third argument non-nil, it
|
|
|
46 ;; INHIBITS quitting unless the user types C-g at toplevel. This is
|
|
|
47 ;; so user can do things like C-u C-g and not get thrown out. Fourth
|
|
|
48 ;; argument, if non-nil, should be a function of two arguments which
|
|
|
49 ;; is called after every command is executed. The fifth argument, if
|
|
|
50 ;; provided, is the state variable for the function. If the
|
|
|
51 ;; loop-function gets an error, the loop will abort WITHOUT throwing
|
|
|
52 ;; (moral: use unwind-protect around call to this function for any
|
|
|
53 ;; critical stuff). The second argument for the loop function is the
|
|
|
54 ;; conditions for any error that occurred or nil if none.
|
|
|
55
|
|
|
56 (defun Electric-command-loop (return-tag
|
|
|
57 &optional prompt inhibit-quit
|
|
|
58 loop-function loop-state)
|
|
|
59
|
|
|
60 (let (cmd
|
|
|
61 (err nil)
|
|
|
62 (electrified-buffer (current-buffer)) ; XEmacs -
|
|
|
63 (prompt-string prompt))
|
|
|
64 (while t
|
|
|
65 (if (not (or (stringp prompt) (eq prompt nil) (eq prompt 'noprompt)))
|
|
|
66 (setq prompt-string (funcall prompt)))
|
|
|
67 (if (not (stringp prompt-string))
|
|
|
68 (if (eq prompt-string 'noprompt)
|
|
|
69 (setq prompt-string nil)
|
|
|
70 (setq prompt-string "->")))
|
|
|
71 (setq cmd (read-key-sequence prompt-string))
|
|
72
|
72 ;; XEmacs
|
|
0
|
73 (or prefix-arg (setq last-command this-command))
|
|
|
74 (setq last-command-event (aref cmd (1- (length cmd)))
|
|
|
75 current-mouse-event
|
|
|
76 (and (or (button-press-event-p last-command-event)
|
|
|
77 (button-release-event-p last-command-event)
|
|
|
78 (menu-event-p last-command-event))
|
|
|
79 last-command-event)
|
|
|
80 this-command (if (menu-event-p last-command-event)
|
|
|
81 last-command-event
|
|
|
82 (key-binding cmd t))
|
|
|
83 cmd this-command)
|
|
|
84 ;; This makes universal-argument-other-key work.
|
|
|
85 (setq universal-argument-num-events 0)
|
|
|
86 (if (or (prog1 quit-flag (setq quit-flag nil))
|
|
72
|
87 ;; XEmacs
|
|
0
|
88 (eq (event-to-character last-input-event) (quit-char)))
|
|
|
89 (progn (setq unread-command-events nil
|
|
|
90 prefix-arg nil)
|
|
|
91 ;; If it wasn't cancelling a prefix character, then quit.
|
|
|
92 (if (or (= (length (this-command-keys)) 1)
|
|
|
93 (not inhibit-quit)) ; safety
|
|
|
94 (progn (ding nil 'quit) ; XEmacs -
|
|
|
95 (message "Quit")
|
|
|
96 (throw return-tag nil))
|
|
|
97 (setq cmd nil))))
|
|
|
98 (setq current-prefix-arg prefix-arg)
|
|
|
99 (if cmd
|
|
|
100 (condition-case conditions
|
|
72
|
101 ;; XEmacs
|
|
0
|
102 (progn (if (eventp cmd)
|
|
|
103 (progn
|
|
|
104 (let ((b (current-buffer)))
|
|
|
105 (dispatch-event cmd)
|
|
|
106 (if (not (eq b (current-buffer)))
|
|
|
107 (throw return-tag (current-buffer)))))
|
|
|
108 (command-execute cmd))
|
|
|
109 (setq last-command this-command)
|
|
|
110 (if (or (prog1 quit-flag (setq quit-flag nil))
|
|
72
|
111 ;; XEmacs
|
|
0
|
112 (eq (event-to-character last-input-event)
|
|
|
113 (quit-char)))
|
|
|
114 (progn (setq unread-command-events nil)
|
|
|
115 (if (not inhibit-quit)
|
|
72
|
116 ;; XEmacs
|
|
0
|
117 (progn (ding nil 'quit)
|
|
|
118 (message "Quit")
|
|
|
119 (throw return-tag nil))
|
|
|
120 (message "Quit inhibited")
|
|
|
121 (ding)))))
|
|
72
|
122 (buffer-read-only (if loop-function
|
|
|
123 (setq err conditions)
|
|
|
124 (ding)
|
|
|
125 (message "Buffer is read-only")
|
|
|
126 (sit-for 2)))
|
|
|
127 (beginning-of-buffer (if loop-function
|
|
|
128 (setq err conditions)
|
|
|
129 (ding)
|
|
|
130 (message "Beginning of Buffer")
|
|
|
131 (sit-for 2)))
|
|
|
132 (end-of-buffer (if loop-function
|
|
|
133 (setq err conditions)
|
|
|
134 (ding)
|
|
|
135 (message "End of Buffer")
|
|
|
136 (sit-for 2)))
|
|
|
137 (error (if loop-function
|
|
|
138 (setq err conditions)
|
|
|
139 (ding)
|
|
|
140 (message "Error: %s"
|
|
|
141 (if (eq (car conditions) 'error)
|
|
|
142 (car (cdr conditions))
|
|
|
143 (prin1-to-string conditions)))
|
|
|
144 (sit-for 2))))
|
|
|
145 (ding))
|
|
0
|
146 (if loop-function (funcall loop-function loop-state err))))
|
|
72
|
147 ;; XEmacs - huh? It should be impossible to ever get here...
|
|
0
|
148 (ding nil 'alarm)
|
|
|
149 (throw return-tag nil))
|
|
|
150
|
|
|
151 ;; This function is like pop-to-buffer, sort of.
|
|
|
152 ;; The algorithm is
|
|
|
153 ;; If there is a window displaying buffer
|
|
|
154 ;; Select it
|
|
|
155 ;; Else if there is only one window
|
|
|
156 ;; Split it, selecting the window on the bottom with height being
|
|
|
157 ;; the lesser of max-height (if non-nil) and the number of lines in
|
|
|
158 ;; the buffer to be displayed subject to window-min-height constraint.
|
|
|
159 ;; Else
|
|
|
160 ;; Switch to buffer in the current window.
|
|
|
161 ;;
|
|
|
162 ;; Then if max-height is nil, and not all of the lines in the buffer
|
|
|
163 ;; are displayed, grab the whole frame.
|
|
|
164 ;;
|
|
|
165 ;; Returns selected window on buffer positioned at point-min.
|
|
|
166
|
|
|
167 (defun Electric-pop-up-window (buffer &optional max-height)
|
|
|
168 (let* ((win (or (get-buffer-window buffer) (selected-window)))
|
|
|
169 (buf (get-buffer buffer))
|
|
|
170 (one-window (one-window-p t))
|
|
|
171 (pop-up-windows t)
|
|
|
172 (target-height)
|
|
|
173 (lines))
|
|
|
174 (if (not buf)
|
|
|
175 (error "Buffer %s does not exist" buffer)
|
|
|
176 (save-excursion
|
|
|
177 (set-buffer buf)
|
|
|
178 (setq lines (count-lines (point-min) (point-max)))
|
|
|
179 (setq target-height
|
|
|
180 (min (max (if max-height (min max-height (1+ lines)) (1+ lines))
|
|
|
181 window-min-height)
|
|
|
182 (save-window-excursion
|
|
|
183 (delete-other-windows)
|
|
|
184 (1- (window-height (selected-window)))))))
|
|
|
185 (cond ((and (eq (window-buffer win) buf))
|
|
|
186 (select-window win))
|
|
|
187 (one-window
|
|
|
188 (goto-char (window-start win))
|
|
|
189 (pop-to-buffer buffer)
|
|
|
190 (setq win (selected-window))
|
|
|
191 (enlarge-window (- target-height (window-height win))))
|
|
|
192 (t
|
|
|
193 (switch-to-buffer buf)))
|
|
|
194 (if (and (not max-height)
|
|
|
195 (> target-height (window-height (selected-window))))
|
|
|
196 (progn (goto-char (window-start win))
|
|
|
197 (enlarge-window (- target-height (window-height win)))))
|
|
|
198 (goto-char (point-min))
|
|
|
199 win)))
|
|
|
200
|
|
72
|
201 (provide 'electric)
|
|
0
|
202
|
|
|
203 ;;; electric.el ends here
|
