Mercurial > hg > xemacs-beta

comparison lisp/window-xemacs.el @ 209:41ff10fd062f r20-4b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-4b3
author cvs
date Mon, 13 Aug 2007 10:04:58 +0200
parents
children 0e522484dd2a
comparison
equal deleted inserted replaced
208:f427b8ec4379 209:41ff10fd062f
1 ;;; window-xemacs.el --- XEmacs window commands aside from those written in C.
2
3 ;; Copyright (C) 1985, 1989, 1993-94, 1997 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995, 1996 Ben Wing.
5
6 ;; Maintainer: XEmacs Development Team
7 ;; Keywords: frames, extensions, dumped
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
23 ;; Free Software Foundation, 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
25
26 ;;; Synched up with: Not synched.
27
28 ;;; Commentary:
29
30 ;; This file is dumped with XEmacs.
31
32 ;; slb - 5/29/97
33 ;; Split apart from window.el in order to keep that file better in synch
34 ;; with Emacs.
35
36 ;;; Code:
37
38 (defun backward-other-window (arg &optional all-frames device)
39 "Select the ARG'th different window on this frame, going backwards.
40 This is just like calling `other-window' with the arg negated."
41 (interactive "p")
42 (other-window (- arg) all-frames device))
43
44 (defun windows-of-buffer (&optional buffer)
45 "Returns a list of windows that have BUFFER in them.
46 If BUFFER is not specified, the current buffer will be used."
47 (or (bufferp buffer)
48 (if (stringp buffer)
49 (setq buffer (or (get-buffer buffer)
50 (get-file-buffer buffer)))
51 (setq buffer (current-buffer))))
52 (let* ((firstwin (next-window nil nil t))
53 (wind firstwin)
54 (done nil)
55 window-list)
56 (while (not done)
57 (if (eq (window-buffer wind) buffer)
58 (setq window-list (append window-list (list wind))))
59 (setq wind (next-window wind nil t))
60 (setq done (eq wind firstwin)))
61 window-list))
62
63 (defun buffer-in-multiple-windows-p (&optional buffer)
64 "Return t if BUFFER is in multiple windows.
65 If BUFFER is not specified, the current buffer will be used."
66 (setq buffer (or buffer
67 (get-buffer buffer)
68 (get-file-buffer buffer)
69 (current-buffer)))
70 (> (length (windows-of-buffer buffer)) 1))
71
72 (defun window-list (&optional frame minibuf window)
73 "Return a list of windows on FRAME, beginning with WINDOW.
74 FRAME and WINDOW default to the selected ones.
75 Optional second arg MINIBUF t means count the minibuffer window
76 even if not active. If MINIBUF is neither t nor nil it means
77 not to count the minibuffer even if it is active."
78 (setq window (or window (selected-window))
79 frame (or frame (selected-frame)))
80 (if (not (eq (window-frame window) frame))
81 (error "Window must be on frame."))
82 (let ((current-frame (selected-frame))
83 list)
84 (unwind-protect
85 (save-window-excursion
86 (select-frame frame)
87 (walk-windows
88 (function (lambda (cur-window)
89 (if (not (eq window cur-window))
90 (setq list (cons cur-window list)))))
91 minibuf)
92 (setq list (cons window list)))
93 (select-frame current-frame))))
94
95 ;; We used to have set-window-dedicated-p as an obsolete version
96 ;; of set-window-buffer-dedicated, but it really makes more sense
97 ;; this way.
98
99 (make-obsolete 'set-window-buffer-dedicated 'set-window-dedicated-p)
100 (defun set-window-buffer-dedicated (window buffer)
101 "Make WINDOW display BUFFER and be dedicated to that buffer.
102 Then Emacs will not automatically change which buffer appears in WINDOW.
103 If BUFFER is nil, make WINDOW not be dedicated (but don't change which
104 buffer appears in it currently)."
105 (if (bufferp buffer)
106 (set-window-buffer window (get-buffer-create buffer)))
107 (set-window-dedicated-p window (not (null buffer))))
108
109
110 ;; The window-config stack is stored as a list in frame property
111 ;; 'window-config-stack, with the most recent element at the front.
112 ;; When you pop off an element, the popped off element gets put at the
113 ;; front of frame property 'window-config-unpop-stack, so you can
114 ;; retrieve it using unpop-window-configuration.
115
116 (defcustom window-config-stack-max 16
117 "*Maximum size of window configuration stack.
118 Start discarding off end if it gets this big."
119 :type 'integer
120 :group 'windows)
121
122 (defun window-config-stack (&optional frame)
123 (or frame (setq frame (selected-frame)))
124 (let ((stack (frame-property frame 'window-config-stack)))
125 (if stack
126 (set-undoable-stack-max stack window-config-stack-max)
127 (progn
128 (setq stack (make-undoable-stack window-config-stack-max))
129 (set-frame-property frame 'window-config-stack stack)))
130 stack))
131
132 (defun push-window-configuration (&optional config)
133 "Push the current window configuration onto the window-config stack.
134 If CONFIG is specified, push it instead of the current window configuration.
135 Each frame has its own window-config stack."
136 (interactive)
137 (let ((wc (or config (current-window-configuration)))
138 (stack (window-config-stack)))
139 (if (or (= 0 (undoable-stack-a-length stack))
140 (not (equal (undoable-stack-a-top stack) wc)))
141 (progn
142 (undoable-stack-push stack wc)
143 ;; kludge.
144 (if (featurep 'toolbar)
145 (set-specifier-dirty-flag default-toolbar))))))
146
147 (defun pop-window-configuration ()
148 "Pop the top window configuration off the window-config stack and set it.
149 Before setting the new window configuration, the current window configuration
150 is pushed onto the \"unpop\" stack.
151 `unpop-window-configuration' undoes what this function does.
152 Each frame has its own window-config and \"unpop\" stack."
153 (interactive)
154 (let ((stack (window-config-stack))
155 (wc (current-window-configuration))
156 popped)
157 (condition-case nil
158 (progn
159 (setq popped (undoable-stack-pop stack))
160 (while (equal popped wc)
161 (setq popped (undoable-stack-pop stack)))
162 (undoable-stack-push stack wc)
163 (undoable-stack-undo stack)
164 (set-window-configuration popped)
165 ;; probably not necessary:
166 (if (featurep 'toolbar)
167 (set-specifier-dirty-flag default-toolbar))
168 popped)
169 (trunc-stack-bottom
170 (error "Bottom of window config stack")))))
171
172 (defun unpop-window-configuration ()
173 "Undo the effect of the most recent `pop-window-configuration'.
174 This does exactly the inverse of what `pop-window-configuration' does:
175 i.e. it pops a window configuration off of the \"unpop\" stack and
176 pushes the current window configuration onto the window-config stack.
177 Each frame has its own window-config and \"unpop\" stack."
178 (interactive)
179 (let ((stack (window-config-stack))
180 (wc (current-window-configuration))
181 popped)
182 (condition-case nil
183 (progn
184 (setq popped
185 (progn
186 (undoable-stack-redo stack)
187 (undoable-stack-pop stack)))
188 (while (equal popped wc)
189 (setq popped
190 (progn
191 (undoable-stack-redo stack)
192 (undoable-stack-pop stack))))
193 (undoable-stack-push stack wc)
194 (set-window-configuration popped)
195 ;; probably not necessary:
196 (if (featurep 'toolbar)
197 (set-specifier-dirty-flag default-toolbar))
198 popped)
199 (trunc-stack-bottom
200 (error "Top of window config stack")))))
201
202
203 ;;;;;;;;;;;;; display-buffer, moved here from C. Hallelujah.
204
205 (defvar display-buffer-function nil
206 "If non-nil, function to call to handle `display-buffer'.
207 It will receive three args: the same as those to `display-buffer'.")
208
209 (defvar pre-display-buffer-function nil
210 "If non-nil, function that will be called from `display-buffer'
211 as the first action. It will receive three args: the same as those
212 to `display-buffer'.
213 This function may be used to select an appropriate frame for the buffer,
214 for example. See also the variable `display-buffer-function', which may
215 be used to completely replace the `display-buffer' function.
216 If the return value of this function is non-nil, it should be a frame,
217 and that frame will be used to display the buffer.")
218
219 (defcustom pop-up-frames nil
220 "*Non-nil means `display-buffer' should make a separate frame."
221 :type 'boolean
222 :group 'frames)
223
224 (defvar pop-up-frame-function nil
225 "Function to call to handle automatic new frame creation.
226 It is called with no arguments and should return a newly created frame.
227
228 A typical value might be `(lambda () (new-frame pop-up-frame-alist))'
229 where `pop-up-frame-alist' would hold the default frame parameters.")
230
231 (defcustom special-display-buffer-names nil
232 "*List of buffer names that should have their own special frames.
233 Displaying a buffer whose name is in this list makes a special frame for it
234 using `special-display-function'.
235
236 An element of the list can be a cons cell instead of just a string.
237 Then the car should be a buffer name, and the cdr specifies frame
238 parameters for creating the frame for that buffer.
239 More precisely, the cdr is passed as the second argument to
240 the function found in `special-display-function', when making that frame.
241 See also `special-display-regexps'."
242 :type '(repeat (choice :value ""
243 (string :tag "Name")
244 (cons :menu-tag "Properties"
245 :value ("" . nil)
246 (string :tag "Name")
247 (repeat :tag "Properties"
248 (group :inline t
249 (symbol :tag "Property")
250 (sexp :tag "Value"))))))
251 :group 'frames)
252
253 (defcustom special-display-regexps nil
254 "*List of regexps saying which buffers should have their own special frames.
255 If a buffer name matches one of these regexps, it gets its own frame.
256 Displaying a buffer whose name is in this list makes a special frame for it
257 using `special-display-function'.
258
259 An element of the list can be a cons cell instead of just a string.
260 Then the car should be the regexp, and the cdr specifies frame
261 parameters for creating the frame for buffers that match.
262 More precisely, the cdr is passed as the second argument to
263 the function found in `special-display-function', when making that frame.
264 See also `special-display-buffer-names'."
265 :type '(repeat (choice :value ""
266 regexp
267 (cons :menu-tag "Properties"
268 :value ("" . nil)
269 regexp
270 (repeat :tag "Properties"
271 (group :inline t
272 (symbol :tag "Property")
273 (sexp :tag "Value"))))))
274 :group 'frames)
275
276 (defvar special-display-function nil
277 "Function to call to make a new frame for a special buffer.
278 It is called with two arguments, the buffer and optional buffer specific
279 data, and should return a window displaying that buffer.
280 The default value makes a separate frame for the buffer,
281 using `special-display-frame-alist' to specify the frame parameters.
282
283 A buffer is special if its is listed in `special-display-buffer-names'
284 or matches a regexp in `special-display-regexps'.")
285
286 (defcustom same-window-buffer-names nil
287 "*List of buffer names that should appear in the selected window.
288 Displaying one of these buffers using `display-buffer' or `pop-to-buffer'
289 switches to it in the selected window, rather than making it appear
290 in some other window.
291
292 An element of the list can be a cons cell instead of just a string.
293 Then the car must be a string, which specifies the buffer name.
294 This is for compatibility with `special-display-buffer-names';
295 the cdr of the cons cell is ignored.
296
297 See also `same-window-regexps'."
298 :type '(repeat (string :tag "Name"))
299 :group 'windows)
300
301 (defcustom same-window-regexps nil
302 "*List of regexps saying which buffers should appear in the selected window.
303 If a buffer name matches one of these regexps, then displaying it
304 using `display-buffer' or `pop-to-buffer' switches to it
305 in the selected window, rather than making it appear in some other window.
306
307 An element of the list can be a cons cell instead of just a string.
308 Then the car must be a string, which specifies the buffer name.
309 This is for compatibility with `special-display-buffer-names';
310 the cdr of the cons cell is ignored.
311
312 See also `same-window-buffer-names'."
313 :type '(repeat regexp)
314 :group 'windows)
315
316 (defcustom pop-up-windows t
317 "*Non-nil means display-buffer should make new windows."
318 :type 'boolean
319 :group 'windows)
320
321 (defcustom split-height-threshold 500
322 "*display-buffer would prefer to split the largest window if this large.
323 If there is only one window, it is split regardless of this value."
324 :type 'integer
325 :group 'windows)
326
327 (defcustom split-width-threshold 500
328 "*display-buffer would prefer to split the largest window if this large.
329 If there is only one window, it is split regardless of this value."
330 :type 'integer
331 :group 'windows)
332
333 ;; Deiconify the frame containing the window WINDOW, then return WINDOW.
334
335 (defun display-buffer-1 (window)
336 (if (frame-iconified-p (window-frame window))
337 (make-frame-visible (window-frame window)))
338 window)
339
340 ;; Can you believe that all of this crap was formerly in C?
341 ;; Praise Jesus that it's not there any more.
342
343 (defun display-buffer (buffer &optional not-this-window-p override-frame)
344 "Make BUFFER appear in some window on the current frame, but don't select it.
345 BUFFER can be a buffer or a buffer name.
346 If BUFFER is shown already in some window in the current frame,
347 just uses that one, unless the window is the selected window and
348 NOT-THIS-WINDOW-P is non-nil (interactively, with prefix arg).
349
350 If BUFFER has a dedicated frame, display on that frame instead of
351 the current frame, unless OVERRIDE-FRAME is non-nil.
352
353 If OVERRIDE-FRAME is non-nil, display on that frame instead of
354 the current frame (or the dedicated frame).
355
356 If `pop-up-windows' is non-nil, always use the
357 current frame and create a new window regardless of whether the
358 buffer has a dedicated frame, and regardless of whether
359 OVERRIDE-FRAME was specified.
360
361 If `pop-up-frames' is non-nil, make a new frame if no window shows BUFFER.
362
363 Returns the window displaying BUFFER."
364 (interactive "BDisplay buffer:\nP")
365
366 (let ((wconfig (current-window-configuration))
367 (result
368 ;; We just simulate a `return' in C. This function is way ugly
369 ;; and does `returns' all over the place and there's no sense
370 ;; in trying to rewrite it to be more Lispy.
371 (catch 'done
372 (let (window old-frame target-frame explicit-frame)
373 (setq old-frame (or (last-nonminibuf-frame) (selected-frame)))
374 (setq buffer (get-buffer buffer))
375 (check-argument-type 'bufferp buffer)
376
377 (setq explicit-frame
378 (if pre-display-buffer-function
379 (funcall pre-display-buffer-function buffer
380 not-this-window-p
381 override-frame)))
382
383 ;; Give the user the ability to completely reimplement
384 ;; this function via the `display-buffer-function'.
385 (if display-buffer-function
386 (throw 'done
387 (funcall display-buffer-function buffer
388 not-this-window-p
389 override-frame)))
390
391 ;; If the buffer has a dedicated frame, that takes
392 ;; precedence over the current frame, and over what the
393 ;; pre-display-buffer-function did.
394 (let ((dedi (buffer-dedicated-frame buffer)))
395 (if (frame-live-p dedi) (setq explicit-frame dedi)))
396
397 ;; if override-frame is supplied, that takes precedence over
398 ;; everything. This is gonna look bad if the
399 ;; pre-display-buffer-function raised some other frame
400 ;; already.
401 (if override-frame
402 (progn
403 (check-argument-type 'frame-live-p override-frame)
404 (setq explicit-frame override-frame)))
405
406 (setq target-frame
407 (or explicit-frame
408 (last-nonminibuf-frame)
409 (selected-frame)))
410
411 ;; If we have switched frames, then set not-this-window-p
412 ;; to false. Switching frames means that selected-window
413 ;; is no longer the same as it was on entry -- it's the
414 ;; selected-window of target_frame instead of old_frame,
415 ;; so it's a fine candidate for display.
416 (if (not (eq old-frame target-frame))
417 (setq not-this-window-p nil))
418
419 ;; if it's in the selected window, and that's ok, then we're done.
420 (if (and (not not-this-window-p)
421 (eq buffer (window-buffer (selected-window))))
422 (throw 'done (display-buffer-1 (selected-window))))
423
424 ;; See if the user has specified this buffer should appear
425 ;; in the selected window.
426
427 (if not-this-window-p
428 nil
429
430 (if (or (member (buffer-name buffer) same-window-buffer-names)
431 (assoc (buffer-name buffer) same-window-buffer-names))
432 (progn
433 (switch-to-buffer buffer)
434 (throw 'done (display-buffer-1 (selected-window)))))
435
436 (let ((tem same-window-regexps))
437 (while tem
438 (let ((car (car tem)))
439 (if (or
440 (and (stringp car)
441 (string-match car (buffer-name buffer)))
442 (and (consp car) (stringp (car car))
443 (string-match (car car) (buffer-name buffer))))
444 (progn
445 (switch-to-buffer buffer)
446 (throw 'done (display-buffer-1
447 (selected-window))))))
448 (setq tem (cdr tem)))))
449
450 ;; If pop-up-frames, look for a window showing BUFFER on
451 ;; any visible or iconified frame. Otherwise search only
452 ;; the current frame.
453 (if (and (not explicit-frame)
454 (or pop-up-frames (not (last-nonminibuf-frame))))
455 (setq target-frame 0))
456
457 ;; Otherwise, find some window that it's already in, and
458 ;; return that, unless that window is the selected window
459 ;; and that isn't ok. What a contorted mess!
460 (setq window (get-buffer-window buffer target-frame))
461 (if (and window
462 (or (not not-this-window-p)
463 (not (eq window (selected-window)))))
464 (throw 'done (display-buffer-1 window)))
465
466 ;; Certain buffer names get special handling.
467 (if special-display-function
468 (progn
469 (if (member (buffer-name buffer)
470 special-display-buffer-names)
471 (throw 'done (funcall special-display-function buffer)))
472
473 (let ((tem (assoc (buffer-name buffer)
474 special-display-buffer-names)))
475 (if tem
476 (throw 'done (funcall special-display-function
477 buffer (cdr tem)))))
478
479 (let ((tem special-display-regexps))
480 (while tem
481 (let ((car (car tem)))
482 (if (and (stringp car)
483 (string-match car (buffer-name buffer)))
484 (throw 'done
485 (funcall special-display-function buffer)))
486 (if (and (consp car)
487 (stringp (car car))
488 (string-match (car car)
489 (buffer-name buffer)))
490 (throw 'done (funcall
491 special-display-function buffer
492 (cdr car)))))
493 (setq tem (cdr tem))))))
494
495 ;; If there are no frames open that have more than a minibuffer,
496 ;; we need to create a new frame.
497 (if (or pop-up-frames
498 (null (last-nonminibuf-frame)))
499 (progn
500 (setq window (frame-selected-window
501 (funcall pop-up-frame-function)))
502 (set-window-buffer window buffer)
503 (throw 'done (display-buffer-1 window))))
504
505 ;; Otherwise, make it be in some window, splitting if
506 ;; appropriate/possible. Do not split a window if we are
507 ;; displaying the buffer in a different frame than that which
508 ;; was current when we were called. (It is already in a
509 ;; different window by virtue of being in another frame.)
510 (if (or (and pop-up-windows (eq target-frame old-frame))
511 (eq 'only (frame-property (selected-frame) 'minibuffer))
512 ;; If the current frame is a special display frame,
513 ;; don't try to reuse its windows.
514 (window-dedicated-p (frame-root-window (selected-frame))))
515 (progn
516 (if (eq 'only (frame-property (selected-frame) 'minibuffer))
517 (setq target-frame (last-nonminibuf-frame)))
518
519 ;; Don't try to create a window if would get an error with
520 ;; height.
521 (if (< split-height-threshold (* 2 window-min-height))
522 (setq split-height-threshold (* 2 window-min-height)))
523
524 ;; Same with width.
525 (if (< split-width-threshold (* 2 window-min-width))
526 (setq split-width-threshold (* 2 window-min-width)))
527
528 ;; If the frame we would try to split cannot be split,
529 ;; try other frames.
530 (if (frame-property (if (null target-frame)
531 (selected-frame)
532 (last-nonminibuf-frame))
533 'unsplittable)
534 (setq window
535 ;; Try visible frames first.
536 (or (get-largest-window 'visible)
537 ;; If that didn't work, try iconified frames.
538 (get-largest-window 0)
539 (get-largest-window t)))
540 (setq window (get-largest-window target-frame)))
541
542 ;; If we got a tall enough full-width window that
543 ;; can be split, split it.
544 (if (and window
545 (not (frame-property (window-frame window)
546 'unsplittable))
547 (>= (window-height window) split-height-threshold)
548 (or (>= (window-width window)
549 split-width-threshold)
550 (and (window-leftmost-p window)
551 (window-rightmost-p window))))
552 (setq window (split-window window))
553 (let (upper
554 ;; lower
555 other)
556 (setq window (get-lru-window target-frame))
557 ;; If the LRU window is selected, and big enough,
558 ;; and can be split, split it.
559 (if (and window
560 (not (frame-property (window-frame window)
561 'unsplittable))
562 (or (eq window (selected-window))
563 (not (window-parent window)))
564 (>= (window-height window)
565 (* 2 window-min-height)))
566 (setq window (split-window window)))
567 ;; If get-lru-window returned nil, try other approaches.
568 ;; Try visible frames first.
569 (or window
570 (setq window (or (get-largest-window 'visible)
571 ;; If that didn't work, try
572 ;; iconified frames.
573 (get-largest-window 0)
574 ;; Try invisible frames.
575 (get-largest-window t)
576 ;; As a last resort, make
577 ;; a new frame.
578 (frame-selected-window
579 (funcall
580 pop-up-frame-function)))))
581 ;; If window appears above or below another,
582 ;; even out their heights.
583 (if (window-previous-child window)
584 (setq other (window-previous-child window)
585 ;; lower window
586 upper other))
587 (if (window-next-child window)
588 (setq other (window-next-child window)
589 ;; lower other
590 upper window))
591 ;; Check that OTHER and WINDOW are vertically arrayed.
592 (if (and other
593 (not (= (nth 1 (window-pixel-edges other))
594 (nth 1 (window-pixel-edges window))))
595 (> (window-pixel-height other)
596 (window-pixel-height window)))
597 (enlarge-window (- (/ (+ (window-height other)
598 (window-height window))
599 2)
600 (window-height upper))
601 nil upper)))))
602
603 (setq window (get-lru-window target-frame)))
604
605 ;; Bring the window's previous buffer to the top of the MRU chain.
606 (if (window-buffer window)
607 (save-excursion
608 (save-selected-window
609 (select-window window)
610 (record-buffer (window-buffer window)))))
611
612 (set-window-buffer window buffer)
613
614 (display-buffer-1 window)))))
615 (or (equal wconfig (current-window-configuration))
616 (push-window-configuration wconfig))
617 result))
618
619 ;;; window-xemacs.el ends here