1#| -*-Scheme-*-
2
3Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6    Institute of Technology
7
8This file is part of MIT/GNU Scheme.
9
10MIT/GNU Scheme is free software; you can redistribute it and/or modify
11it under the terms of the GNU General Public License as published by
12the Free Software Foundation; either version 2 of the License, or (at
13your option) any later version.
14
15MIT/GNU Scheme is distributed in the hope that it will be useful, but
16WITHOUT ANY WARRANTY; without even the implied warranty of
17MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18General Public License for more details.
19
20You should have received a copy of the GNU General Public License
21along with MIT/GNU Scheme; if not, write to the Free Software
22Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23USA.
24
25|#
26
27;;;; Buffer Commands
28
29(declare (usual-integrations))
30
31(define (prompt-for-select-buffer prompt)
32  (lambda ()
33    (list
34     (buffer-name
35      (prompt-for-buffer prompt (previous-buffer))))))
36
37(define-command switch-to-buffer
38  "Select buffer with specified name.
39If the variable select-buffer-create is true,
40specifying a non-existent buffer will cause it to be created."
41  (prompt-for-select-buffer "Switch to buffer")
42  (lambda (buffer)
43    (select-buffer (find-buffer buffer #t))))
44
45(define-command switch-to-buffer-other-window
46  "Select buffer in another window."
47  (prompt-for-select-buffer "Switch to buffer in other window")
48  (lambda (buffer)
49    (select-buffer-other-window (find-buffer buffer #t))))
50
51(define-command switch-to-buffer-other-frame
52  "Select buffer in another frame."
53  (prompt-for-select-buffer "Switch to buffer in other frame")
54  (lambda (buffer)
55    (select-buffer-other-screen (find-buffer buffer #t))))
56(define edwin-command$switch-to-buffer-other-screen
57  edwin-command$switch-to-buffer-other-frame)
58
59(define-command create-buffer
60  "Create a new buffer with a given name, and select it."
61  "sCreate buffer"
62  (lambda (name)
63    (select-buffer (new-buffer name))))
64
65(define-command create-buffer-other-frame
66  "Create a new buffer with a given name, and select it in another frame."
67  "sCreate buffer in other frame"
68  (lambda (name)
69    (select-buffer-other-screen (new-buffer name))))
70(define edwin-command$create-buffer-other-screen
71  edwin-command$create-buffer-other-frame)
72
73(define-command insert-buffer
74  "Insert the contents of a specified buffer at point."
75  "bInsert buffer"
76  (lambda (buffer)
77    (let ((point (mark-right-inserting (current-point))))
78      (region-insert-string!
79       point
80       (region->string (buffer-region (find-buffer buffer #t))))
81      (push-current-mark! (current-point))
82      (set-current-point! point))))
83
84(define-command twiddle-buffers
85  "Select previous buffer."
86  ()
87  (lambda ()
88    (let ((buffer (previous-buffer)))
89      (if buffer
90	  (select-buffer buffer)
91	  (editor-error "No previous buffer to select")))))
92
93(define-command bury-buffer
94  "Put current buffer at the end of the list of all buffers.
95There it is the least likely candidate for other-buffer to return;
96thus, the least likely buffer for \\[switch-to-buffer] to select by default."
97  ()
98  (lambda ()
99    (let ((buffer (current-buffer))
100	  (previous (previous-buffer)))
101      (if previous
102	  (begin
103	    (select-buffer previous)
104	    (bury-buffer buffer))))))
105
106(define-command rename-buffer
107  "Change the name of the current buffer.
108Reads the new name in the echo area."
109  "sRename buffer (to new name)"
110  (lambda (name)
111    (if (find-buffer name)
112	(editor-error "Buffer named " name " already exists"))
113    (rename-buffer (current-buffer) name)))
114
115(define-command kill-buffer
116  "One arg, a string or a buffer.  Get rid of the specified buffer."
117  "bKill buffer"
118  (lambda (buffer)
119    (kill-buffer-interactive (find-buffer buffer #t))))
120
121(define (kill-buffer-interactive buffer)
122  (if (not (other-buffer buffer)) (editor-error "Only one buffer"))
123  (save-buffer-changes buffer)
124  (if (for-all? (ref-variable kill-buffer-query-procedures buffer)
125	(lambda (procedure)
126	  (procedure buffer)))
127      (kill-buffer buffer)
128      (message "Buffer not killed.")))
129
130(define (kill-buffer-query-modified buffer)
131  (or (not (and (buffer-pathname buffer)
132		(buffer-modified? buffer)
133		(buffer-writeable? buffer)))
134      (prompt-for-yes-or-no?
135       (string-append "Buffer "
136		      (buffer-name buffer)
137		      " modified; kill anyway"))))
138
139(define (kill-buffer-query-process buffer)
140  (or (not (get-buffer-process buffer))
141      (prompt-for-yes-or-no?
142       (string-append "Buffer "
143		      (buffer-name buffer)
144		      " has an active process; kill anyway"))))
145
146(define-variable kill-buffer-query-procedures
147  "List of procedures called to query before killing a buffer.
148Each procedure is called with one argument, the buffer being killed.
149If any procedure returns #f, the buffer is not killed."
150  (list kill-buffer-query-modified kill-buffer-query-process)
151  (lambda (object) (and (list? object) (for-all? object procedure?))))
152
153(define-command kill-some-buffers
154  "For each buffer, ask whether to kill it."
155  ()
156  (lambda ()
157    (kill-some-buffers true)))
158
159(define (kill-some-buffers prompt?)
160  (for-each (lambda (buffer)
161	      (if (and (not (minibuffer? buffer))
162		       (or (not prompt?)
163			   (prompt-for-confirmation?
164			    (string-append "Kill buffer '"
165					   (buffer-name buffer)
166					   "'"))))
167		  (if (other-buffer buffer)
168		      (kill-buffer-interactive buffer)
169		      (let ((dummy (new-buffer "*Dummy*")))
170			(kill-buffer-interactive buffer)
171			(create-buffer initial-buffer-name)
172			(kill-buffer dummy)))))
173	    (buffer-list)))
174
175(define-command normal-mode
176  "Choose the major mode for this buffer automatically.
177Also sets up any specified local variables of the file.
178Uses the visited file name, the -*- line, and the local variables spec."
179  ()
180  (lambda ()
181    (normal-mode (current-buffer) false)))
182
183(define-command toggle-mode-lock
184  "Change whether this buffer has its major mode locked.
185When locked, the buffer's major mode may not be changed."
186  ()
187  (lambda ()
188    (let ((buffer (current-buffer)))
189      (if (buffer-get buffer 'MAJOR-MODE-LOCKED)
190	  (begin
191	    (buffer-remove! buffer 'MAJOR-MODE-LOCKED)
192	    (message "Major mode unlocked"))
193	  (begin
194	    (buffer-put! buffer 'MAJOR-MODE-LOCKED true)
195	    (message "Major mode locked"))))))
196
197(define-command not-modified
198  "Pretend that this buffer hasn't been altered."
199  ()
200  (lambda ()
201    (buffer-not-modified! (current-buffer))))
202
203(define-command toggle-read-only
204  "Change whether this buffer is visiting its file read-only."
205  ()
206  (lambda ()
207    (let ((buffer (current-buffer)))
208      (if (buffer-writeable? buffer)
209	  (set-buffer-read-only! buffer)
210	  (set-buffer-writeable! buffer)))))
211
212(define-command no-toggle-read-only
213  "Display warning indicating that this buffer may not be modified."
214  ()
215  (lambda ()
216    (editor-failure "This buffer may not be modified.")))
217
218(define (save-buffer-changes buffer)
219  (if (and (buffer-pathname buffer)
220	   (buffer-modified? buffer)
221	   (buffer-writeable? buffer)
222	   (prompt-for-yes-or-no?
223	    (string-append "Buffer "
224			   (buffer-name buffer)
225			   " contains changes.  Write them out")))
226      (write-buffer-interactive buffer false)))
227
228(define (new-buffer name)
229  (create-buffer (new-buffer-name name)))
230
231(define (new-buffer-name name)
232  (if (find-buffer name)
233      (let search-loop ((n 2))
234	(let ((new-name (string-append name "<" (write-to-string n) ">")))
235	  (if (find-buffer new-name)
236	      (search-loop (1+ n))
237	      new-name)))
238      name))
239
240(define (pop-up-temporary-buffer name properties initialization)
241  (let ((buffer (temporary-buffer name)))
242    (let ((window (pop-up-buffer buffer #f)))
243      (initialization buffer window)
244      (set-buffer-point! buffer (buffer-start buffer))
245      (buffer-not-modified! buffer)
246      (if (memq 'READ-ONLY properties)
247	  (set-buffer-read-only! buffer))
248      (if (and window (memq 'SHRINK-WINDOW properties))
249	  (shrink-window-if-larger-than-buffer window))
250      (if (and (memq 'FLUSH-ON-SPACE properties)
251	       (not (typein-window? (current-window))))
252	  (begin
253	    (message "Hit space to flush.")
254	    (reset-command-prompt!)
255	    (let ((char (keyboard-peek)))
256	      (if (eqv? #\space char)
257		  (begin
258		    (keyboard-read)
259		    (kill-pop-up-buffer #f))))
260	    (clear-message))))))
261
262(define (string->temporary-buffer string name properties)
263  (pop-up-temporary-buffer name properties
264    (lambda (buffer window)
265      window
266      (insert-string string (buffer-point buffer)))))
267
268(define (call-with-output-to-temporary-buffer name properties procedure)
269  (pop-up-temporary-buffer name properties
270    (lambda (buffer window)
271      window
272      (call-with-output-mark (buffer-point buffer) procedure))))
273
274(define (with-output-to-temporary-buffer name properties thunk)
275  (call-with-output-to-temporary-buffer name properties
276    (lambda (port)
277      (with-output-to-port port thunk))))
278
279(define (call-with-temporary-buffer name procedure)
280  (let ((buffer))
281    (dynamic-wind (lambda ()
282		    (set! buffer (temporary-buffer name)))
283		  (lambda ()
284		    (procedure buffer))
285		  (lambda ()
286		    (kill-buffer buffer)
287		    (set! buffer)
288		    unspecific))))
289
290(define (temporary-buffer name)
291  (let ((buffer (find-or-create-buffer name)))
292    (buffer-reset! buffer)
293    buffer))
294
295(define (prompt-for-buffer prompt default-buffer . options)
296  (let ((name
297	 (apply prompt-for-buffer-name prompt default-buffer
298		'REQUIRE-MATCH? (not (ref-variable select-buffer-create))
299		options)))
300    (or (find-buffer name)
301	(let loop ((hooks (ref-variable select-buffer-not-found-hooks)))
302	  (cond ((null? hooks)
303		 (let ((buffer (create-buffer name)))
304		   (temporary-message "(New Buffer)")
305		   buffer))
306		((let ((result ((car hooks) name)))
307		   (and (buffer? result)
308			result)))
309		(else
310		 (loop (cdr hooks))))))))
311
312(define-variable select-buffer-create
313  "If true, buffer selection commands may create new buffers."
314  true
315  boolean?)
316
317(define-variable select-buffer-not-found-hooks
318  "List of procedures to be called for select-buffer on nonexistent buffer.
319These procedures are called as soon as the error is detected.
320The procedures are called in the order given,
321until one of them returns a buffer.
322This variable has no effect if select-buffer-create is false."
323  '()
324  list?)
325
326(define (prompt-for-existing-buffer prompt default-buffer . options)
327  (find-buffer (apply prompt-for-buffer-name prompt default-buffer
328		      'REQUIRE-MATCH? #t
329		      options)
330	       #t))
331
332(define (prompt-for-buffer-name prompt default-buffer . options)
333  (apply prompt-for-string-table-name
334	 prompt
335	 (and default-buffer (buffer-name default-buffer))
336	 (buffer-names)
337	 'DEFAULT-TYPE (if default-buffer 'VISIBLE-DEFAULT 'NO-DEFAULT)
338	 options))