1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
|
;; electric -- Window maker and Command loop for `electric' modes.
;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
;; Principal author K. Shane Hartman
;; This file is part of GNU Emacs.
;; GNU Emacs 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 1, or (at your option)
;; any later version.
;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
; zaaaaaaap
;; perhaps this should be in subr.el...
(defun shrink-window-if-larger-than-buffer (window)
(save-excursion
(set-buffer (window-buffer window))
(let ((w (selected-window)) ;save-window-excursion can't win
(buffer-file-name buffer-file-name)
(p (point))
(n 0)
(window-min-height 0)
(buffer-read-only nil)
(modified (buffer-modified-p))
(buffer (current-buffer)))
(unwind-protect
(progn
(select-window window)
(goto-char (point-min))
(while (pos-visible-in-window-p (point-max))
;; defeat file locking... don't try this at home, kids!
(setq buffer-file-name nil)
(insert ?\n) (setq n (1+ n)))
(if (> n 0) (shrink-window (1- n))))
(delete-region (point-min) (point))
(set-buffer-modified-p modified)
(goto-char p)
(select-window w)
;; Make sure we unbind buffer-read-only
;; with the proper current buffer.
(set-buffer buffer)))))
;; This loop is the guts for non-standard modes which retain control
;; until some event occurs. It is a `do-forever', the only way out is to
;; throw. It assumes that you have set up the keymap, window, and
;; everything else: all it does is read commands and execute them -
;; providing error messages should one occur (if there is no loop
;; function - which see). The required argument is a tag which should
;; expect a value of nil if the user decides to punt. The
;; second argument is a prompt string (defaults to "->"). Given third
;; argument non-nil, it INHIBITS quitting unless the user types C-g at
;; toplevel. This is so user can do things like C-u C-g and not get
;; thrown out. Fourth argument, if non-nil, should be a function of two
;; arguments which is called after every command is executed. The fifth
;; argument, if provided, is the state variable for the function. If the
;; loop-function gets an error, the loop will abort WITHOUT throwing
;; (moral: use unwind-protect around call to this function for any
;; critical stuff). The second argument for the loop function is the
;; conditions for any error that occurred or nil if none.
(defun Electric-command-loop (return-tag
&optional prompt inhibit-quit
loop-function loop-state)
(if (not prompt) (setq prompt "->"))
(let (cmd (err nil))
(while t
(setq cmd (read-key-sequence (if (stringp prompt)
prompt (funcall prompt))))
(setq last-command-char (aref cmd (1- (length cmd)))
this-command (key-binding cmd)
cmd this-command)
(if (or (prog1 quit-flag (setq quit-flag nil))
(= last-input-char ?\C-g))
(progn (setq unread-command-char -1
prefix-arg nil)
;; If it wasn't cancelling a prefix character, then quit.
(if (or (= (length (this-command-keys)) 1)
(not inhibit-quit)) ; safety
(progn (ding)
(message "Quit")
(throw return-tag nil))
(setq cmd nil))))
(setq current-prefix-arg prefix-arg)
(if cmd
(condition-case conditions
(progn (command-execute cmd)
(if (or (prog1 quit-flag (setq quit-flag nil))
(= last-input-char ?\C-g))
(progn (setq unread-command-char -1)
(if (not inhibit-quit)
(progn (ding)
(message "Quit")
(throw return-tag nil))
(ding)))))
(buffer-read-only (if loop-function
(setq err conditions)
(ding)
(message "Buffer is read-only")
(sit-for 2)))
(beginning-of-buffer (if loop-function
(setq err conditions)
(ding)
(message "Beginning of Buffer")
(sit-for 2)))
(end-of-buffer (if loop-function
(setq err conditions)
(ding)
(message "End of Buffer")
(sit-for 2)))
(error (if loop-function
(setq err conditions)
(ding)
(message "Error: %s"
(if (eq (car conditions) 'error)
(car (cdr conditions))
(prin1-to-string conditions)))
(sit-for 2))))
(ding))
(if loop-function (funcall loop-function loop-state err))))
(ding)
(throw return-tag nil))
;; This function is like pop-to-buffer, sort of.
;; The algorithm is
;; If there is a window displaying buffer
;; Select it
;; Else if there is only one window
;; Split it, selecting the window on the bottom with height being
;; the lesser of max-height (if non-nil) and the number of lines in
;; the buffer to be displayed subject to window-min-height constraint.
;; Else
;; Switch to buffer in the current window.
;;
;; Then if max-height is nil, and not all of the lines in the buffer
;; are displayed, grab the whole screen.
;;
;; Returns selected window on buffer positioned at point-min.
(defun Electric-pop-up-window (buffer &optional max-height)
(let* ((win (or (get-buffer-window buffer) (selected-window)))
(buf (get-buffer buffer))
(one-window (one-window-p t))
(pop-up-windows t)
(target-height)
(lines))
(if (not buf)
(error "Buffer %s does not exist" buffer)
(save-excursion
(set-buffer buf)
(setq lines (count-lines (point-min) (point-max)))
(setq target-height
(min (max (if max-height (min max-height (1+ lines)) (1+ lines))
window-min-height)
(save-window-excursion
(delete-other-windows)
(1- (window-height (selected-window)))))))
(cond ((and (eq (window-buffer win) buf))
(select-window win))
(one-window
(goto-char (window-start win))
(pop-to-buffer buffer)
(setq win (selected-window))
(enlarge-window (- target-height (window-height win))))
(t
(switch-to-buffer buf)))
(if (and (not max-height)
(> target-height (window-height (selected-window))))
(progn (goto-char (window-start win))
(enlarge-window (- target-height (window-height win)))))
(goto-char (point-min))
win)))
(provide 'electric)
|
