![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to electric.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / lisp|
Return to electric.el CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / lisp |
1.1 root 1: ;; electric -- Window maker and Command loop for `electric' modes.
2: ;; adapted by shane after mly
3:
4: ;; Copyright (C) 1985 Richard M. Stallman and K. Shane Hartman
5:
6: ;; This file is part of GNU Emacs.
7:
8: ;; GNU Emacs is distributed in the hope that it will be useful,
9: ;; but WITHOUT ANY WARRANTY. No author or distributor
10: ;; accepts responsibility to anyone for the consequences of using it
11: ;; or for whether it serves any particular purpose or works at all,
12: ;; unless he says so in writing. Refer to the GNU Emacs General Public
13: ;; License for full details.
14:
15: ;; Everyone is granted permission to copy, modify and redistribute
16: ;; GNU Emacs, but only under the conditions described in the
17: ;; GNU Emacs General Public License. A copy of this license is
18: ;; supposed to have been given to you along with GNU Emacs so you
19: ;; can know your rights and responsibilities. It should be in a
20: ;; file named COPYING. Among other things, the copyright notice
21: ;; and this notice must be preserved on all copies.
22:
23:
24: (provide 'electric) ; zaaaaaaap
25:
26: ;; This loop is the guts for non-standard modes which retain control
27: ;; until some event occurs. It is a `do-forever', the only way out is to
28: ;; throw. It assumes that you have set up the keymap, window, and
29: ;; everything else: all it does is read commands and execute them -
30: ;; providing error messages should one occur (if there is no loop
31: ;; function - which see). The required argument is a tag which should
32: ;; expect a value of nil if the user decides to punt. The user is
33: ;; offered a chance to flush the loop by typing Space as the very first
34: ;; character. Thereafter Space is just a normal character. The
35: ;; second argument is a prompt string (defaults to "->"). Given third
36: ;; argument non-nil, it INHIBITS quitting unless the user types C-g at
37: ;; toplevel. This is so user can do things like C-u C-g and not get
38: ;; thrown out. Fourth argument, if non-nil, should be a function of two
39: ;; arguments which is called after every command is executed. The fifth
40: ;; argument, if provided, is the state variable for the function. If the
41: ;; loop-function gets an error, the loop will abort WITHOUT throwing
42: ;; (moral: use unwind-protect around call to this function for any
43: ;; critical stuff). The second argument for the loop function is the
44: ;; conditions for any error that occurred or nil if none.
45:
46: (defun Electric-command-loop (return-tag &optional prompt inhibit-quit
47: loop-function loop-state)
48: (if (not prompt) (setq prompt "->"))
49: (message "<<< Type Space to flush >>>")
50: (let ((cmd (read-char))
51: (err))
52: (if (memq cmd '(?\ ?\C-g))
53: (throw return-tag nil)
54: (setq unread-command-char cmd cmd nil))
55: (while t
56: (setq cmd (read-key-sequence prompt))
57: (setq last-command-char (aref cmd (1- (length cmd)))
58: this-command (key-binding cmd)
59: cmd this-command)
60: (if (or (prog1 quit-flag (setq quit-flag nil))
61: (= last-input-char ?\C-g))
62: (progn (setq unread-command-char -1
63: prefix-arg nil)
64: ;; If it wasn't cancelling a prefix character, then quit.
65: (if (or (= (length (this-command-keys)) 1)
66: (not inhibit-quit)); safety
67: (progn (ding)
68: (message "Quit")
69: (throw return-tag nil))
70: (setq cmd nil))))
71: (setq current-prefix-arg prefix-arg)
72: (if cmd
73: (condition-case conditions
74: (progn (command-execute cmd)
75: (if (or (prog1 quit-flag (setq quit-flag nil))
76: (= last-input-char ?\C-g))
77: (progn (setq unread-command-char -1)
78: (if (not inhibit-quit)
79: (progn (ding)
80: (message "Quit")
81: (throw return-tag nil))
82: (ding)))))
83: (buffer-read-only (if loop-function
84: (setq err conditions)
85: (ding)
86: (message "Buffer is read-only")
87: (sit-for 2)))
88: (beginning-of-buffer (if loop-function
89: (setq err conditions)
90: (ding)
91: (message "Beginning of Buffer")
92: (sit-for 2)))
93: (end-of-buffer (if loop-function
94: (setq err conditions)
95: (ding)
96: (message "End of Buffer")
97: (sit-for 2)))
98: (error (if loop-function
99: (setq err conditions)
100: (ding)
101: (message "%s" (or (car (cdr conditions)) "Huh?"))
102: (sit-for 2))))
103: (ding))
104: (if loop-function (funcall loop-function loop-state err))))
105: (ding)
106: (throw return-tag nil))
107:
108: ;; This function is like pop-to-buffer, sort of.
109: ;; The algorithm is
110: ;; If there is a window displaying buffer
111: ;; Select it
112: ;; Else if there is only one window
113: ;; Split it, selecting the window on the bottom with height being
114: ;; the lesser of max-height (if non-nil) and the number of lines in
115: ;; the buffer to be displayed subject to window-min-height constraint.
116: ;; Else
117: ;; Switch to buffer in the current window.
118: ;;
119: ;; Then if max-height is nil, and not all of the lines in the buffer
120: ;; are displayed, grab the whole screen.
121: ;;
122: ;; Returns selected window on buffer positioned at point-min.
123:
124: (defun Electric-pop-up-window (buffer &optional max-height)
125: (let* ((win (or (get-buffer-window buffer) (selected-window)))
126: (buf (get-buffer buffer))
127: (one-window (eq win (next-window)))
128: (pop-up-windows t)
129: (target-height)
130: (lines))
131: (if (not buf)
132: (error "Buffer %s does not exist" buffer)
133: (save-excursion
134: (set-buffer buf)
135: (setq lines (count-lines (point-min) (point-max)))
136: (setq target-height
137: (min (max (if max-height (min max-height (1+ lines)) (1+ lines))
138: window-min-height)
139: (save-window-excursion
140: (delete-other-windows)
141: (1- (window-height (selected-window)))))))
142: (cond ((and (eq (window-buffer win) buf))
143: (select-window win))
144: (one-window
145: (goto-char (window-start win))
146: (pop-to-buffer buffer)
147: (setq win (selected-window))
148: (enlarge-window (- target-height (window-height win))))
149: (t
150: (switch-to-buffer buf)))
151: (if (and (not max-height)
152: (> target-height (window-height (selected-window))))
153: (progn (goto-char (window-start win))
154: (enlarge-window (- target-height (window-height win)))))
155: (goto-char (point-min))
156: win)))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.