Mercurial > hg > xemacs-beta
comparison lisp/frame.el @ 428:3ecd8885ac67 r21-2-22
Import from CVS: tag r21-2-22
author | cvs |
---|---|
date | Mon, 13 Aug 2007 11:28:15 +0200 |
parents | |
children | 8de8e3f6228a |
comparison
equal
deleted
inserted
replaced
427:0a0253eac470 | 428:3ecd8885ac67 |
---|---|
1 ;;; frame.el --- multi-frame management independent of window systems. | |
2 | |
3 ;; Copyright (C) 1993-4, 1997 Free Software Foundation, Inc. | |
4 ;; Copyright (C) 1995, 1996 Ben Wing. | |
5 | |
6 ;; Maintainer: XEmacs Development Team | |
7 ;; Keywords: internal, 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: FSF 19.30. | |
27 | |
28 ;;; Commentary: | |
29 | |
30 ;; This file is dumped with XEmacs. | |
31 | |
32 ;;; Code: | |
33 | |
34 (defgroup frames nil | |
35 "Support for Emacs frames and window systems." | |
36 :group 'environment) | |
37 | |
38 ; No need for `frame-creation-function'. | |
39 | |
40 ;;; The initial value given here for this must ask for a minibuffer. | |
41 ;;; There must always exist a frame with a minibuffer, and after we | |
42 ;;; delete the terminal frame, this will be the only frame. | |
43 (defcustom initial-frame-plist '(minibuffer t) | |
44 "Plist of frame properties for creating the initial X window frame. | |
45 You can set this in your `.emacs' file; for example, | |
46 (setq initial-frame-plist '(top 1 left 1 width 80 height 55)) | |
47 Properties specified here supersede the values given in `default-frame-plist'. | |
48 The format of this can also be an alist for backward compatibility. | |
49 | |
50 If the value calls for a frame without a minibuffer, and you have not created | |
51 a minibuffer frame on your own, one is created according to | |
52 `minibuffer-frame-plist'. | |
53 | |
54 You can specify geometry-related options for just the initial frame | |
55 by setting this variable in your `.emacs' file; however, they won't | |
56 take effect until Emacs reads `.emacs', which happens after first creating | |
57 the frame. If you want the frame to have the proper geometry as soon | |
58 as it appears, you need to use this three-step process: | |
59 * Specify X resources to give the geometry you want. | |
60 * Set `default-frame-plist' to override these options so that they | |
61 don't affect subsequent frames. | |
62 * Set `initial-frame-plist' in a way that matches the X resources, | |
63 to override what you put in `default-frame-plist'." | |
64 :type 'plist | |
65 :group 'frames) | |
66 | |
67 (defcustom minibuffer-frame-plist '(width 80 height 2 menubar-visible-p nil | |
68 default-toolbar-visible-p nil) | |
69 "Plist of frame properties for initially creating a minibuffer frame. | |
70 You can set this in your `.emacs' file; for example, | |
71 (setq minibuffer-frame-plist '(top 1 left 1 width 80 height 2)) | |
72 Properties specified here supersede the values given in | |
73 `default-frame-plist'. | |
74 The format of this can also be an alist for backward compatibility." | |
75 :type 'plist | |
76 :group 'frames) | |
77 | |
78 (defcustom pop-up-frame-plist nil | |
79 "Plist of frame properties used when creating pop-up frames. | |
80 Pop-up frames are used for completions, help, and the like. | |
81 This variable can be set in your init file, like this: | |
82 (setq pop-up-frame-plist '(width 80 height 20)) | |
83 These supersede the values given in `default-frame-plist'. | |
84 The format of this can also be an alist for backward compatibility." | |
85 :type 'plist | |
86 :group 'frames) | |
87 | |
88 (setq pop-up-frame-function | |
89 (function (lambda () | |
90 (make-frame pop-up-frame-plist)))) | |
91 | |
92 (defcustom special-display-frame-plist '(height 14 width 80 unsplittable t) | |
93 "*Plist of frame properties used when creating special frames. | |
94 Special frames are used for buffers whose names are in | |
95 `special-display-buffer-names' and for buffers whose names match | |
96 one of the regular expressions in `special-display-regexps'. | |
97 This variable can be set in your init file, like this: | |
98 (setq special-display-frame-plist '(width 80 height 20)) | |
99 These supersede the values given in `default-frame-plist'. | |
100 The format of this can also be an alist for backward compatibility." | |
101 :type 'plist | |
102 :group 'frames) | |
103 | |
104 (defun safe-alist-to-plist (cruftiness) | |
105 (if (consp (car cruftiness)) | |
106 (alist-to-plist cruftiness) | |
107 cruftiness)) | |
108 | |
109 ;; Display BUFFER in its own frame, reusing an existing window if any. | |
110 ;; Return the window chosen. | |
111 ;; Currently we do not insist on selecting the window within its frame. | |
112 ;; If ARGS is a plist, use it as a list of frame property specs. | |
113 ;; #### Change, not compatible with FSF: This stuff is all so incredibly | |
114 ;; junky anyway that I doubt it makes any difference. | |
115 ;; If ARGS is a list whose car is t, | |
116 ;; use (cadr ARGS) as a function to do the work. | |
117 ;; Pass it BUFFER as first arg, and (cddr ARGS) gives the rest of the args. | |
118 (defun special-display-popup-frame (buffer &optional args) | |
119 ;; if we can't display simultaneous multiple frames, just return | |
120 ;; nil and let the normal behavior take over. | |
121 (and (device-on-window-system-p) | |
122 (if (and args (eq t (car args))) | |
123 (apply (cadr args) buffer (cddr args)) | |
124 (let ((window (get-buffer-window buffer t))) | |
125 (if window | |
126 ;; If we have a window already, make it visible. | |
127 (let ((frame (window-frame window))) | |
128 (make-frame-visible frame) | |
129 (raise-frame frame) | |
130 window) | |
131 ;; If no window yet, make one in a new frame. | |
132 (let ((frame | |
133 (make-frame (append (safe-alist-to-plist args) | |
134 (safe-alist-to-plist | |
135 special-display-frame-plist))))) | |
136 (set-window-buffer (frame-selected-window frame) buffer) | |
137 (set-window-dedicated-p (frame-selected-window frame) t) | |
138 (frame-selected-window frame))))))) | |
139 | |
140 (setq special-display-function 'special-display-popup-frame) | |
141 | |
142 ;;; Handle delete-frame events from the X server. | |
143 ;(defun handle-delete-frame (event) | |
144 ; (interactive "e") | |
145 ; (let ((frame (posn-window (event-start event))) | |
146 ; (i 0) | |
147 ; (tail (frame-list))) | |
148 ; (while tail | |
149 ; (and (frame-visible-p (car tail)) | |
150 ; (not (eq (car tail) frame)) | |
151 ; (setq i (1+ i))) | |
152 ; (setq tail (cdr tail))) | |
153 ; (if (> i 0) | |
154 ; (delete-frame frame t) | |
155 ; (kill-emacs)))) | |
156 | |
157 | |
158 ;;;; Arrangement of frames at startup | |
159 | |
160 ;;; 1) Load the window system startup file from the lisp library and read the | |
161 ;;; high-priority arguments (-q and the like). The window system startup | |
162 ;;; file should create any frames specified in the window system defaults. | |
163 ;;; | |
164 ;;; 2) If no frames have been opened, we open an initial text frame. | |
165 ;;; | |
166 ;;; 3) Once the init file is done, we apply any newly set properties | |
167 ;;; in initial-frame-plist to the frame. | |
168 | |
169 ;; These are now called explicitly at the proper times, | |
170 ;; since that is easier to understand. | |
171 ;; Actually using hooks within Emacs is bad for future maintenance. --rms. | |
172 ;; (add-hook 'before-init-hook 'frame-initialize) | |
173 ;; (add-hook 'window-setup-hook 'frame-notice-user-settings) | |
174 | |
175 ;;; If we create the initial frame, this is it. | |
176 (defvar frame-initial-frame nil) | |
177 | |
178 ;; Record the properties used in frame-initialize to make the initial frame. | |
179 (defvar frame-initial-frame-plist) | |
180 | |
181 (defvar frame-initial-geometry-arguments nil) | |
182 | |
183 (defun canonicalize-frame-plists () | |
184 (setq initial-frame-plist (safe-alist-to-plist initial-frame-plist)) | |
185 (setq default-frame-plist (safe-alist-to-plist default-frame-plist))) | |
186 | |
187 ;;; startup.el calls this function before loading the user's init | |
188 ;;; file - if there is no frame with a minibuffer open now, create | |
189 ;;; one to display messages while loading the init file. | |
190 (defun frame-initialize () | |
191 ;; In batch mode, we actually use the initial terminal device for output. | |
192 (canonicalize-frame-plists) | |
193 (if (not (noninteractive)) | |
194 (progn | |
195 ;; Don't call select-frame here - focus is a matter of WM policy. | |
196 | |
197 ;; If there is no frame with a minibuffer besides the terminal | |
198 ;; frame, then we need to create the opening frame. Make sure | |
199 ;; it has a minibuffer, but let initial-frame-plist omit the | |
200 ;; minibuffer spec. | |
201 (or (delq terminal-frame (minibuffer-frame-list)) | |
202 (progn | |
203 (setq frame-initial-frame-plist | |
204 (append initial-frame-plist default-frame-plist)) | |
205 ;; FSFmacs has scroll-bar junk here that we don't need. | |
206 (setq default-minibuffer-frame | |
207 (setq frame-initial-frame | |
208 (make-frame initial-frame-plist | |
209 (car (delq terminal-device | |
210 (device-list)))))) | |
211 ;; Delete any specifications for window geometry properties | |
212 ;; so that we won't reapply them in frame-notice-user-settings. | |
213 ;; It would be wrong to reapply them then, | |
214 ;; because that would override explicit user resizing. | |
215 (setq initial-frame-plist | |
216 (frame-remove-geometry-props initial-frame-plist)))) | |
217 ;; At this point, we know that we have a frame open, so we | |
218 ;; can delete the terminal device. | |
219 ;; (delete-device terminal-device) | |
220 ;; Do it the same way Fkill_emacs does it. -slb | |
221 (delete-console terminal-console) | |
222 (setq terminal-frame nil) | |
223 | |
224 ;; FSFmacs sets frame-creation-function here, but no need. | |
225 ))) | |
226 | |
227 ;;; startup.el calls this function after loading the user's init | |
228 ;;; file. Now default-frame-plist and initial-frame-plist contain | |
229 ;;; information to which we must react; do what needs to be done. | |
230 (defun frame-notice-user-settings () | |
231 | |
232 ;; FSFmacs has menu-bar junk here that we don't need. | |
233 | |
234 (canonicalize-frame-plists) | |
235 | |
236 ;; Creating and deleting frames may shift the selected frame around, | |
237 ;; and thus the current buffer. Protect against that. We don't | |
238 ;; want to use save-excursion here, because that may also try to set | |
239 ;; the buffer of the selected window, which fails when the selected | |
240 ;; window is the minibuffer. | |
241 (let ((old-buffer (current-buffer))) | |
242 | |
243 ;; If the initial frame is still around, apply initial-frame-plist | |
244 ;; and default-frame-plist to it. | |
245 (if (frame-live-p frame-initial-frame) | |
246 | |
247 ;; The initial frame we create above always has a minibuffer. | |
248 ;; If the user wants to remove it, or make it a minibuffer-only | |
249 ;; frame, then we'll have to delete the selected frame and make a | |
250 ;; new one; you can't remove or add a root window to/from an | |
251 ;; existing frame. | |
252 ;; | |
253 ;; NOTE: default-frame-plist was nil when we created the | |
254 ;; existing frame. We need to explicitly include | |
255 ;; default-frame-plist in the properties of the screen we | |
256 ;; create here, so that its new value, gleaned from the user's | |
257 ;; .emacs file, will be applied to the existing screen. | |
258 (if (not (eq (car | |
259 (or (and (lax-plist-member | |
260 initial-frame-plist 'minibuffer) | |
261 (list (lax-plist-get initial-frame-plist | |
262 'minibuffer))) | |
263 (and (lax-plist-member default-frame-plist | |
264 'minibuffer) | |
265 (list (lax-plist-get default-frame-plist | |
266 'minibuffer))) | |
267 '(t))) | |
268 t)) | |
269 ;; Create the new frame. | |
270 (let (props | |
271 ) | |
272 ;; If the frame isn't visible yet, wait till it is. | |
273 ;; If the user has to position the window, | |
274 ;; Emacs doesn't know its real position until | |
275 ;; the frame is seen to be visible. | |
276 | |
277 (if (frame-property frame-initial-frame 'initially-unmapped) | |
278 nil | |
279 (while (not (frame-visible-p frame-initial-frame)) | |
280 (sleep-for 1))) | |
281 (setq props (frame-properties frame-initial-frame)) | |
282 ;; Get rid of `name' unless it was specified explicitly before. | |
283 (or (lax-plist-member frame-initial-frame-plist 'name) | |
284 (setq props (lax-plist-remprop props 'name))) | |
285 (setq props (append initial-frame-plist default-frame-plist | |
286 props | |
287 nil)) | |
288 ;; Get rid of `reverse', because that was handled | |
289 ;; when we first made the frame. | |
290 (laxputf props 'reverse nil) | |
291 ;; Get rid of `window-id', otherwise make-frame will | |
292 ;; think we're trying to setup an external widget. | |
293 (laxremf props 'window-id) | |
294 (if (lax-plist-member frame-initial-geometry-arguments 'height) | |
295 (laxremf props 'height)) | |
296 (if (lax-plist-member frame-initial-geometry-arguments 'width) | |
297 (laxremf props 'width)) | |
298 (if (lax-plist-member frame-initial-geometry-arguments 'left) | |
299 (laxremf props 'left)) | |
300 (if (lax-plist-member frame-initial-geometry-arguments 'top) | |
301 (laxremf props 'top)) | |
302 | |
303 ;; Now create the replacement initial frame. | |
304 (make-frame | |
305 ;; Use the geometry args that created the existing | |
306 ;; frame, rather than the props we get for it. | |
307 (append '(user-size t user-position t) | |
308 frame-initial-geometry-arguments | |
309 props)) | |
310 ;; The initial frame, which we are about to delete, may be | |
311 ;; the only frame with a minibuffer. If it is, create a | |
312 ;; new one. | |
313 (or (delq frame-initial-frame (minibuffer-frame-list)) | |
314 (make-initial-minibuffer-frame nil)) | |
315 | |
316 ;; If the initial frame is serving as a surrogate | |
317 ;; minibuffer frame for any frames, we need to wean them | |
318 ;; onto a new frame. The default-minibuffer-frame | |
319 ;; variable must be handled similarly. | |
320 (let ((users-of-initial | |
321 (filtered-frame-list | |
322 #'(lambda (frame) | |
323 (and (not (eq frame frame-initial-frame)) | |
324 (eq (window-frame | |
325 (minibuffer-window frame)) | |
326 frame-initial-frame)))))) | |
327 (if (or users-of-initial | |
328 (eq default-minibuffer-frame frame-initial-frame)) | |
329 | |
330 ;; Choose an appropriate frame. Prefer frames which | |
331 ;; are only minibuffers. | |
332 (let* ((new-surrogate | |
333 (car | |
334 (or (filtered-frame-list | |
335 #'(lambda (frame) | |
336 (eq 'only | |
337 (frame-property frame 'minibuffer)))) | |
338 (minibuffer-frame-list)))) | |
339 (new-minibuffer (minibuffer-window new-surrogate))) | |
340 | |
341 (if (eq default-minibuffer-frame frame-initial-frame) | |
342 (setq default-minibuffer-frame new-surrogate)) | |
343 | |
344 ;; Wean the frames using frame-initial-frame as | |
345 ;; their minibuffer frame. | |
346 (mapcar | |
347 #' | |
348 (lambda (frame) | |
349 (set-frame-property frame 'minibuffer | |
350 new-minibuffer)) | |
351 users-of-initial)))) | |
352 | |
353 ;; Redirect events enqueued at this frame to the new frame. | |
354 ;; Is this a good idea? | |
355 ;; Probably not, since this whole redirect-frame-focus | |
356 ;; stuff is a load of trash, and so is this function we're in. | |
357 ;; --ben | |
358 ;(redirect-frame-focus frame-initial-frame new) | |
359 | |
360 ;; Finally, get rid of the old frame. | |
361 (delete-frame frame-initial-frame t)) | |
362 | |
363 ;; Otherwise, we don't need all that rigamarole; just apply | |
364 ;; the new properties. | |
365 (let (newprops allprops tail) | |
366 (setq allprops (append initial-frame-plist | |
367 default-frame-plist)) | |
368 (if (lax-plist-member frame-initial-geometry-arguments 'height) | |
369 (laxremf allprops 'height)) | |
370 (if (lax-plist-member frame-initial-geometry-arguments 'width) | |
371 (remf allprops 'width)) | |
372 (if (lax-plist-member frame-initial-geometry-arguments 'left) | |
373 (laxremf allprops 'left)) | |
374 (if (lax-plist-member frame-initial-geometry-arguments 'top) | |
375 (laxremf allprops 'top)) | |
376 (setq tail allprops) | |
377 ;; Find just the props that have changed since we first | |
378 ;; made this frame. Those are the ones actually set by | |
379 ;; the init file. For those props whose values we already knew | |
380 ;; (such as those spec'd by command line options) | |
381 ;; it is undesirable to specify the parm again | |
382 ;; once the user has seen the frame and been able to alter it | |
383 ;; manually. | |
384 (while tail | |
385 (let (newval oldval) | |
386 (setq oldval (lax-plist-get frame-initial-frame-plist | |
387 (car tail))) | |
388 (setq newval (lax-plist-get allprops (car tail))) | |
389 (or (eq oldval newval) | |
390 (laxputf newprops (car tail) newval))) | |
391 (setq tail (cddr tail))) | |
392 (set-frame-properties frame-initial-frame newprops) | |
393 ;silly FSFmacs junk | |
394 ;if (lax-plist-member newprops 'font) | |
395 ; (frame-update-faces frame-initial-frame)) | |
396 | |
397 ))) | |
398 | |
399 ;; Restore the original buffer. | |
400 (set-buffer old-buffer) | |
401 | |
402 ;; Make sure the initial frame can be GC'd if it is ever deleted. | |
403 ;; Make sure frame-notice-user-settings does nothing if called twice. | |
404 (setq frame-initial-frame nil))) | |
405 | |
406 (defun make-initial-minibuffer-frame (device) | |
407 (let ((props (append '(minibuffer only) | |
408 (safe-alist-to-plist minibuffer-frame-plist)))) | |
409 (make-frame props device))) | |
410 | |
411 | |
412 ;;;; Creation of additional frames, and other frame miscellanea | |
413 | |
414 (defun get-other-frame () | |
415 "Return some frame other than the selected frame, creating one if necessary." | |
416 (let* ((this (selected-frame)) | |
417 ;; search visible frames first | |
418 (next (next-frame this 'visible-nomini))) | |
419 ;; then search iconified frames | |
420 (if (eq this next) | |
421 (setq next (next-frame 'visible-iconic-nomini))) | |
422 (if (eq this next) | |
423 ;; otherwise, make a new frame | |
424 (make-frame) | |
425 next))) | |
426 | |
427 (defun next-multiframe-window () | |
428 "Select the next window, regardless of which frame it is on." | |
429 (interactive) | |
430 (select-window (next-window (selected-window) | |
431 (> (minibuffer-depth) 0) | |
432 t))) | |
433 | |
434 (defun previous-multiframe-window () | |
435 "Select the previous window, regardless of which frame it is on." | |
436 (interactive) | |
437 (select-window (previous-window (selected-window) | |
438 (> (minibuffer-depth) 0) | |
439 t))) | |
440 | |
441 (defun make-frame-on-device (type connection &optional props) | |
442 "Create a frame of type TYPE on CONNECTION. | |
443 TYPE should be a symbol naming the device type, i.e. one of | |
444 | |
445 x An X display. CONNECTION should be a standard display string | |
446 such as \"unix:0\", or nil for the display specified on the | |
447 command line or in the DISPLAY environment variable. Only if | |
448 support for X was compiled into XEmacs. | |
449 tty A standard TTY connection or terminal. CONNECTION should be | |
450 a TTY device name such as \"/dev/ttyp2\" (as determined by | |
451 the Unix command `tty') or nil for XEmacs' standard input | |
452 and output (usually the TTY in which XEmacs started). Only | |
453 if support for TTY's was compiled into XEmacs. | |
454 ns A connection to a machine running the NeXTstep windowing | |
455 system. Not currently implemented. | |
456 mswindows A connection to a machine running Microsoft Windows NT or | |
457 Windows 95/97. | |
458 pc A direct-write MS-DOS frame. Not currently implemented. | |
459 | |
460 PROPS should be a plist of properties, as in the call to `make-frame'. | |
461 | |
462 If a connection to CONNECTION already exists, it is reused; otherwise, | |
463 a new connection is opened." | |
464 (make-frame props (make-device type connection props))) | |
465 | |
466 ;; Alias, kept temporarily. | |
467 (defalias 'new-frame 'make-frame) | |
468 | |
469 ; FSFmacs has make-frame here. We have it in C, so no need for | |
470 ; frame-creation-function. | |
471 | |
472 (defun filtered-frame-list (predicate &optional device) | |
473 "Return a list of all live frames which satisfy PREDICATE. | |
474 If optional second arg DEVICE is non-nil, restrict the frames | |
475 returned to that device." | |
476 (let ((frames (if device (device-frame-list device) | |
477 (frame-list))) | |
478 good-frames) | |
479 (while (consp frames) | |
480 (if (funcall predicate (car frames)) | |
481 (setq good-frames (cons (car frames) good-frames))) | |
482 (setq frames (cdr frames))) | |
483 good-frames)) | |
484 | |
485 (defun minibuffer-frame-list (&optional device) | |
486 "Return a list of all frames with their own minibuffers. | |
487 If optional second arg DEVICE is non-nil, restrict the frames | |
488 returned to that device." | |
489 (filtered-frame-list | |
490 #'(lambda (frame) | |
491 (eq frame (window-frame (minibuffer-window frame)))) | |
492 device)) | |
493 | |
494 (defun frame-minibuffer-only-p (frame) | |
495 "Return non-nil if FRAME is a minibuffer-only frame." | |
496 (eq (frame-root-window frame) (minibuffer-window frame))) | |
497 | |
498 (defun frame-remove-geometry-props (plist) | |
499 "Return the property list PLIST, but with geometry specs removed. | |
500 This deletes all bindings in PLIST for `top', `left', `width', | |
501 `height', `user-size' and `user-position' properties. | |
502 Emacs uses this to avoid overriding explicit moves and resizings from | |
503 the user during startup." | |
504 (setq plist (canonicalize-lax-plist (copy-sequence plist))) | |
505 (mapcar #'(lambda (propname) | |
506 (if (lax-plist-member plist propname) | |
507 (progn | |
508 (setq frame-initial-geometry-arguments | |
509 (cons propname | |
510 (cons (lax-plist-get plist propname) | |
511 frame-initial-geometry-arguments))) | |
512 (setq plist (lax-plist-remprop plist propname))))) | |
513 '(height width top left user-size user-position)) | |
514 plist) | |
515 | |
516 (defun other-frame (arg) | |
517 "Select the ARG'th different visible frame, and raise it. | |
518 All frames are arranged in a cyclic order. | |
519 This command selects the frame ARG steps away in that order. | |
520 A negative ARG moves in the opposite order. | |
521 | |
522 This sets the window system focus, regardless of the value | |
523 of `focus-follows-mouse'." | |
524 (interactive "p") | |
525 (let ((frame (selected-frame))) | |
526 (while (> arg 0) | |
527 (setq frame (next-frame frame 'visible-nomini)) | |
528 (setq arg (1- arg))) | |
529 (while (< arg 0) | |
530 (setq frame (previous-frame frame 'visible-nomini)) | |
531 (setq arg (1+ arg))) | |
532 (raise-frame frame) | |
533 (focus-frame frame) | |
534 ;this is a bad idea; you should in general never warp the | |
535 ;pointer unless the user asks for this. Furthermore, | |
536 ;our version of `set-mouse-position' takes a window, | |
537 ;not a frame. | |
538 ;(set-mouse-position (selected-frame) (1- (frame-width)) 0) | |
539 ;some weird FSFmacs randomness | |
540 ;(if (fboundp 'unfocus-frame) | |
541 ; (unfocus-frame)))) | |
542 )) | |
543 | |
544 ;; XEmacs-added utility functions | |
545 | |
546 (defmacro save-selected-frame (&rest body) | |
547 "Execute forms in BODY, then restore the selected frame. | |
548 The value returned is the value of the last form in BODY." | |
549 (let ((old-frame (gensym "ssf"))) | |
550 `(let ((,old-frame (selected-frame))) | |
551 (unwind-protect | |
552 (progn ,@body) | |
553 (select-frame ,old-frame))))) | |
554 | |
555 (defmacro with-selected-frame (frame &rest body) | |
556 "Execute forms in BODY with FRAME as the selected frame. | |
557 The value returned is the value of the last form in BODY." | |
558 `(save-selected-frame | |
559 (select-frame ,frame) | |
560 ,@body)) | |
561 | |
562 ; this is in C in FSFmacs | |
563 (defun frame-list () | |
564 "Return a list of all frames on all devices/consoles." | |
565 ;; Lists are copies, so nconc is safe here. | |
566 (apply 'nconc (mapcar 'device-frame-list (device-list)))) | |
567 | |
568 (defun frame-type (&optional frame) | |
569 "Return the type of the specified frame (e.g. `x' or `tty'). | |
570 This is equivalent to the type of the frame's device. | |
571 Value is `tty' for a tty frame (a character-only terminal), | |
572 `x' for a frame that is an X window, | |
573 `ns' for a frame that is a NeXTstep window (not yet implemented), | |
574 `mswindows' for a frame that is a Windows NT or Windows 95/97 window, | |
575 `pc' for a frame that is a direct-write MS-DOS frame (not yet implemented), | |
576 `stream' for a stream frame (which acts like a stdio stream), and | |
577 `dead' for a deleted frame." | |
578 (or frame (setq frame (selected-frame))) | |
579 (if (not (frame-live-p frame)) 'dead | |
580 (device-type (frame-device frame)))) | |
581 | |
582 (defun device-or-frame-p (object) | |
583 "Return non-nil if OBJECT is a device or frame." | |
584 (or (devicep object) | |
585 (framep object))) | |
586 | |
587 (defun device-or-frame-type (device-or-frame) | |
588 "Return the type (e.g. `x' or `tty') of DEVICE-OR-FRAME. | |
589 DEVICE-OR-FRAME should be a device or a frame object. See `device-type' | |
590 for a description of the possible types." | |
591 (if (devicep device-or-frame) | |
592 (device-type device-or-frame) | |
593 (frame-type device-or-frame))) | |
594 | |
595 (defun fw-frame (obj) | |
596 "Given a frame or window, return the associated frame. | |
597 Return nil otherwise." | |
598 (cond ((windowp obj) (window-frame obj)) | |
599 ((framep obj) obj) | |
600 (t nil))) | |
601 | |
602 | |
603 ;;;; Frame configurations | |
604 | |
605 (defun current-frame-configuration () | |
606 "Return a list describing the positions and states of all frames. | |
607 Its car is `frame-configuration'. | |
608 Each element of the cdr is a list of the form (FRAME PLIST WINDOW-CONFIG), | |
609 where | |
610 FRAME is a frame object, | |
611 PLIST is a property list specifying some of FRAME's properties, and | |
612 WINDOW-CONFIG is a window configuration object for FRAME." | |
613 (cons 'frame-configuration | |
614 (mapcar (function | |
615 (lambda (frame) | |
616 (list frame | |
617 (frame-properties frame) | |
618 (current-window-configuration frame)))) | |
619 (frame-list)))) | |
620 | |
621 (defun set-frame-configuration (configuration &optional nodelete) | |
622 "Restore the frames to the state described by CONFIGURATION. | |
623 Each frame listed in CONFIGURATION has its position, size, window | |
624 configuration, and other properties set as specified in CONFIGURATION. | |
625 Ordinarily, this function deletes all existing frames not | |
626 listed in CONFIGURATION. But if optional second argument NODELETE | |
627 is given and non-nil, the unwanted frames are iconified instead." | |
628 (or (frame-configuration-p configuration) | |
629 (signal 'wrong-type-argument | |
630 (list 'frame-configuration-p configuration))) | |
631 (let ((config-plist (cdr configuration)) | |
632 frames-to-delete) | |
633 (mapc (lambda (frame) | |
634 (let ((properties (assq frame config-plist))) | |
635 (if properties | |
636 (progn | |
637 (set-frame-properties | |
638 frame | |
639 ;; Since we can't set a frame's minibuffer status, | |
640 ;; we might as well omit the parameter altogether. | |
641 (lax-plist-remprop (nth 1 properties) 'minibuffer)) | |
642 (set-window-configuration (nth 2 properties))) | |
643 (setq frames-to-delete (cons frame frames-to-delete))))) | |
644 (frame-list)) | |
645 (if nodelete | |
646 ;; Note: making frames invisible here was tried | |
647 ;; but led to some strange behavior--each time the frame | |
648 ;; was made visible again, the window manager asked afresh | |
649 ;; for where to put it. | |
650 (mapc 'iconify-frame frames-to-delete) | |
651 (mapc 'delete-frame frames-to-delete)))) | |
652 | |
653 ; this function is in subr.el in FSFmacs. | |
654 ; that's because they don't always include frame.el, while we do. | |
655 | |
656 (defun frame-configuration-p (object) | |
657 "Return non-nil if OBJECT seems to be a frame configuration. | |
658 Any list whose car is `frame-configuration' is assumed to be a frame | |
659 configuration." | |
660 (and (consp object) | |
661 (eq (car object) 'frame-configuration))) | |
662 | |
663 | |
664 ;; FSFmacs has functions `frame-width', `frame-height' here. | |
665 ;; We have them in C. | |
666 | |
667 ;; FSFmacs has weird functions `set-default-font', `set-background-color', | |
668 ;; `set-foreground-color' here. They don't do sensible things like | |
669 ;; set faces; instead they set frame properties (??!!) and call | |
670 ;; useless functions such as `frame-update-faces' and | |
671 ;; `frame-update-face-colors'. | |
672 | |
673 ;; FSFmacs has functions `set-cursor-color', `set-mouse-color', and | |
674 ;; `set-border-color', which refer to frame properties. | |
675 ;; #### We need to use specifiers here. | |
676 | |
677 ;(defun auto-raise-mode (arg) | |
678 ; "Toggle whether or not the selected frame should auto-raise. | |
679 ;With arg, turn auto-raise mode on if and only if arg is positive. | |
680 ;Note that this controls Emacs's own auto-raise feature. | |
681 ;Some window managers allow you to enable auto-raise for certain windows. | |
682 ;You can use that for Emacs windows if you wish, but if you do, | |
683 ;that is beyond the control of Emacs and this command has no effect on it." | |
684 ; (interactive "P") | |
685 ; (if (null arg) | |
686 ; (setq arg | |
687 ; (if (frame-property (selected-frame) 'auto-raise) | |
688 ; -1 1))) | |
689 ; (set-frame-property (selected-frame) 'auto-raise (> arg 0))) | |
690 | |
691 ;(defun auto-lower-mode (arg) | |
692 ; "Toggle whether or not the selected frame should auto-lower. | |
693 ;With arg, turn auto-lower mode on if and only if arg is positive. | |
694 ;Note that this controls Emacs's own auto-lower feature. | |
695 ;Some window managers allow you to enable auto-lower for certain windows. | |
696 ;You can use that for Emacs windows if you wish, but if you do, | |
697 ;that is beyond the control of Emacs and this command has no effect on it." | |
698 ; (interactive "P") | |
699 ; (if (null arg) | |
700 ; (setq arg | |
701 ; (if (frame-property (selected-frame) 'auto-lower) | |
702 ; -1 1))) | |
703 ; (set-frame-property (selected-frame) 'auto-lower (> arg 0))) | |
704 | |
705 ;; FSFmacs has silly functions `toggle-scroll-bar', | |
706 ;; `toggle-horizontal-scrollbar' | |
707 | |
708 ;;; Iconifying emacs. | |
709 ;;; | |
710 ;;; The function iconify-emacs replaces every non-iconified emacs window | |
711 ;;; with a *single* icon. Iconified emacs windows are left alone. When | |
712 ;;; emacs is in this globally-iconified state, de-iconifying any emacs icon | |
713 ;;; will uniconify all frames that were visible, and iconify all frames | |
714 ;;; that were not. This is done by temporarily changing the value of | |
715 ;;; `map-frame-hook' to `deiconify-emacs' (which should never be called | |
716 ;;; except from the map-frame-hook while emacs is iconified). | |
717 ;;; | |
718 ;;; The title of the icon representing all emacs frames is controlled by | |
719 ;;; the variable `icon-name'. This is done by temporarily changing the | |
720 ;;; value of `frame-icon-title-format'. Unfortunately, this changes the | |
721 ;;; titles of all emacs icons, not just the "big" icon. | |
722 ;;; | |
723 ;;; It would be nice if existing icons were removed and restored by | |
724 ;;; iconifying the emacs process, but I couldn't make that work yet. | |
725 | |
726 (defvar icon-name nil) ; set this at run time, not load time. | |
727 | |
728 (defvar iconification-data nil) | |
729 | |
730 (defun iconify-emacs () | |
731 "Replace every non-iconified FRAME with a *single* icon. | |
732 Iconified frames are left alone. When XEmacs is in this | |
733 globally-iconified state, de-iconifying any emacs icon will uniconify | |
734 all frames that were visible, and iconify all frames that were not." | |
735 (interactive) | |
736 (if iconification-data (error "already iconified?")) | |
737 (let* ((frames (frame-list)) | |
738 (rest frames) | |
739 (me (selected-frame)) | |
740 frame) | |
741 (while rest | |
742 (setq frame (car rest)) | |
743 (setcar rest (cons frame (frame-visible-p frame))) | |
744 ; (if (memq (cdr (car rest)) '(icon nil)) | |
745 ; (progn | |
746 ; (make-frame-visible frame) ; deiconify, and process the X event | |
747 ; (sleep-for 500 t) ; process X events; I really want to XSync() here | |
748 ; )) | |
749 (or (eq frame me) (make-frame-invisible frame)) | |
750 (setq rest (cdr rest))) | |
751 (or (boundp 'map-frame-hook) (setq map-frame-hook nil)) | |
752 (or icon-name | |
753 (setq icon-name (concat invocation-name " @ " (system-name)))) | |
754 (setq iconification-data | |
755 (list frame-icon-title-format map-frame-hook frames) | |
756 frame-icon-title-format icon-name | |
757 map-frame-hook 'deiconify-emacs) | |
758 (iconify-frame me))) | |
759 | |
760 | |
761 (defun deiconify-emacs (&optional ignore) | |
762 (or iconification-data (error "not iconified?")) | |
763 (setq frame-icon-title-format (car iconification-data) | |
764 map-frame-hook (car (cdr iconification-data)) | |
765 iconification-data (car (cdr (cdr iconification-data)))) | |
766 (while iconification-data | |
767 (let ((visibility (cdr (car iconification-data)))) | |
768 (cond (visibility ;; JV (Note non-nil means visible in XEmacs) | |
769 (make-frame-visible (car (car iconification-data)))) | |
770 ; (t ;; (eq visibility 'icon) ;; JV Not in XEmacs!!! | |
771 ; (make-frame-visible (car (car iconification-data))) | |
772 ; (sleep-for 500 t) ; process X events; I really want to XSync() here | |
773 ; (iconify-frame (car (car iconification-data)))) | |
774 ;; (t nil) | |
775 )) | |
776 (setq iconification-data (cdr iconification-data)))) | |
777 | |
778 (defun suspend-or-iconify-emacs () | |
779 "Call iconify-emacs if using a window system, otherwise call suspend-emacs." | |
780 (interactive) | |
781 (cond ((device-on-window-system-p) | |
782 (iconify-emacs)) | |
783 ((and (eq (device-type) 'tty) | |
784 (console-tty-controlling-process (selected-console))) | |
785 (suspend-console (selected-console))) | |
786 (t | |
787 (suspend-emacs)))) | |
788 | |
789 ;; This is quite a mouthful, but it should be descriptive, as it's | |
790 ;; bound to C-z. FSF takes the easy way out by binding C-z to | |
791 ;; different things depending on window-system. We can't do the same, | |
792 ;; because we allow simultaneous X and TTY consoles. | |
793 (defun suspend-emacs-or-iconify-frame () | |
794 "Iconify the selected frame if using a window system, otherwise suspend Emacs." | |
795 (interactive) | |
796 (cond ((device-on-window-system-p) | |
797 (iconify-frame)) | |
798 ((and (eq (frame-type) 'tty) | |
799 (console-tty-controlling-process (selected-console))) | |
800 (suspend-console (selected-console))) | |
801 (t | |
802 (suspend-emacs)))) | |
803 | |
804 | |
805 ;;; auto-raise and auto-lower | |
806 | |
807 (defcustom auto-raise-frame nil | |
808 "*If true, frames will be raised to the top when selected. | |
809 Under X, most ICCCM-compliant window managers will have an option to do this | |
810 for you, but this variable is provided in case you're using a broken WM." | |
811 :type 'boolean | |
812 :group 'frames) | |
813 | |
814 (defcustom auto-lower-frame nil | |
815 "*If true, frames will be lowered to the bottom when no longer selected. | |
816 Under X, most ICCCM-compliant window managers will have an option to do this | |
817 for you, but this variable is provided in case you're using a broken WM." | |
818 :type 'boolean | |
819 :group 'frames) | |
820 | |
821 (defun default-select-frame-hook () | |
822 "Implement the `auto-raise-frame' variable. | |
823 For use as the value of `select-frame-hook'." | |
824 (if auto-raise-frame (raise-frame (selected-frame)))) | |
825 | |
826 (defun default-deselect-frame-hook () | |
827 "Implement the `auto-lower-frame' variable. | |
828 For use as the value of `deselect-frame-hook'." | |
829 (if auto-lower-frame (lower-frame (selected-frame))) | |
830 (highlight-extent nil nil)) | |
831 | |
832 (or select-frame-hook | |
833 (add-hook 'select-frame-hook 'default-select-frame-hook)) | |
834 | |
835 (or deselect-frame-hook | |
836 (add-hook 'deselect-frame-hook 'default-deselect-frame-hook)) | |
837 | |
838 | |
839 ;;; Application-specific frame-management | |
840 | |
841 (defcustom get-frame-for-buffer-default-frame-name nil | |
842 "*The default frame to select; see doc of `get-frame-for-buffer'." | |
843 :type 'string | |
844 :group 'frames) | |
845 | |
846 (defcustom get-frame-for-buffer-default-instance-limit nil | |
847 "*The default instance limit for creating new frames; | |
848 see doc of `get-frame-for-buffer'." | |
849 :type 'integer | |
850 :group 'frames) | |
851 | |
852 (defun get-frame-name-for-buffer (buffer) | |
853 (let ((mode (and (get-buffer buffer) | |
854 (save-excursion (set-buffer buffer) | |
855 major-mode)))) | |
856 (or (get mode 'frame-name) | |
857 get-frame-for-buffer-default-frame-name))) | |
858 | |
859 (defun get-frame-for-buffer-make-new-frame (buffer &optional frame-name plist) | |
860 (let* ((fr (make-frame plist)) | |
861 (w (frame-root-window fr))) | |
862 ;; | |
863 ;; Make the one buffer being displayed in this newly created | |
864 ;; frame be the buffer of interest, instead of something | |
865 ;; random, so that it won't be shown in two-window mode. | |
866 ;; Avoid calling switch-to-buffer here, since that's something | |
867 ;; people might want to call this routine from. | |
868 ;; | |
869 ;; (If the root window doesn't have a buffer, then that means | |
870 ;; there is more than one window on the frame, which can only | |
871 ;; happen if the user has done something funny on the frame- | |
872 ;; creation-hook. If that's the case, leave it alone.) | |
873 ;; | |
874 (if (window-buffer w) | |
875 (set-window-buffer w buffer)) | |
876 fr)) | |
877 | |
878 (defcustom get-frame-for-buffer-default-to-current nil | |
879 "*When non-nil, `get-frame-for-buffer' will default to the selected frame." | |
880 :type 'boolean | |
881 :group 'frames) | |
882 | |
883 (defun get-frame-for-buffer-noselect (buffer | |
884 &optional not-this-window-p on-frame) | |
885 "Return a frame in which to display BUFFER. | |
886 This is a subroutine of `get-frame-for-buffer' (which see)." | |
887 (let (name limit) | |
888 (cond | |
889 ((or on-frame (eq (selected-window) (minibuffer-window))) | |
890 ;; don't switch frames if a frame was specified, or to list | |
891 ;; completions from the minibuffer, etc. | |
892 nil) | |
893 | |
894 ((setq name (get-frame-name-for-buffer buffer)) | |
895 ;; | |
896 ;; This buffer's mode expressed a preference for a frame of a particular | |
897 ;; name. That always takes priority. | |
898 ;; | |
899 (let ((limit (get name 'instance-limit)) | |
900 (defaults (get name 'frame-defaults)) | |
901 (matching-frames '()) | |
902 frames frame already-visible) | |
903 ;; Sort the list so that iconic frames will be found last. They | |
904 ;; will be used too, but mapped frames take precedence. And | |
905 ;; fully visible frames come before occluded frames. | |
906 ;; Hidden frames come after really visible ones | |
907 (setq frames | |
908 (sort (frame-list) | |
909 #'(lambda (s1 s2) | |
910 (cond ((frame-totally-visible-p s2) | |
911 nil) | |
912 ((not (frame-visible-p s2)) | |
913 (frame-visible-p s1)) | |
914 ((eq (frame-visible-p s2) 'hidden) | |
915 (eq (frame-visible-p s1) t )) | |
916 ((not (frame-totally-visible-p s2)) | |
917 (and (frame-visible-p s1) | |
918 (frame-totally-visible-p s1))))))) | |
919 ;; but the selected frame should come first, even if it's occluded, | |
920 ;; to minimize thrashing. | |
921 (setq frames (cons (selected-frame) | |
922 (delq (selected-frame) frames))) | |
923 | |
924 (setq name (symbol-name name)) | |
925 (while frames | |
926 (setq frame (car frames)) | |
927 (if (equal name (frame-name frame)) | |
928 (if (get-buffer-window buffer frame) | |
929 (setq already-visible frame | |
930 frames nil) | |
931 (setq matching-frames (cons frame matching-frames)))) | |
932 (setq frames (cdr frames))) | |
933 (cond (already-visible | |
934 already-visible) | |
935 ((or (null matching-frames) | |
936 (eq limit 0) ; means create with reckless abandon | |
937 (and limit (< (length matching-frames) limit))) | |
938 (get-frame-for-buffer-make-new-frame | |
939 buffer | |
940 name | |
941 (alist-to-plist (acons 'name name | |
942 (plist-to-alist defaults))))) | |
943 (t | |
944 ;; do not switch any of the window/buffer associations in an | |
945 ;; existing frame; this function only picks a frame; the | |
946 ;; determination of which windows on it get reused is up to | |
947 ;; display-buffer itself. | |
948 ;; (or (window-dedicated-p (selected-window)) | |
949 ;; (switch-to-buffer buffer)) | |
950 (car matching-frames))))) | |
951 | |
952 ((setq limit get-frame-for-buffer-default-instance-limit) | |
953 ;; | |
954 ;; This buffer's mode did not express a preference for a frame of a | |
955 ;; particular name, but the user wants a new frame rather than | |
956 ;; reusing the existing one. | |
957 (let* ((defname | |
958 (or (plist-get default-frame-plist 'name) | |
959 default-frame-name)) | |
960 (frames | |
961 (sort (filtered-frame-list #'(lambda (x) | |
962 (or (frame-visible-p x) | |
963 (frame-iconified-p x)))) | |
964 #'(lambda (s1 s2) | |
965 (cond ((and (frame-visible-p s1) | |
966 (not (frame-visible-p s2)))) | |
967 ((and (eq (frame-visible-p s1) t) | |
968 (eq (frame-visible-p s2) 'hidden))) | |
969 ((and (frame-visible-p s2) | |
970 (not (frame-visible-p s1))) | |
971 nil) | |
972 ((and (equal (frame-name s1) defname) | |
973 (not (equal (frame-name s2) defname)))) | |
974 ((and (equal (frame-name s2) defname) | |
975 (not (equal (frame-name s1) defname))) | |
976 nil) | |
977 ((frame-totally-visible-p s2) | |
978 nil) | |
979 (t)))))) | |
980 ;; put the selected frame last. The user wants a new frame, | |
981 ;; so don't reuse the existing one unless forced to. | |
982 (setq frames (append (delq (selected-frame) frames) (list frames))) | |
983 (if (or (eq limit 0) ; means create with reckless abandon | |
984 (< (length frames) limit)) | |
985 (get-frame-for-buffer-make-new-frame buffer) | |
986 (car frames)))) | |
987 | |
988 (not-this-window-p | |
989 (let ((w-list (windows-of-buffer buffer)) | |
990 f w | |
991 (first-choice nil) | |
992 (second-choice (if get-frame-for-buffer-default-to-current | |
993 (selected-frame) | |
994 nil)) | |
995 (last-resort nil)) | |
996 (while (and w-list (null first-choice)) | |
997 (setq w (car w-list) | |
998 f (window-frame w)) | |
999 (cond ((eq w (selected-window)) nil) | |
1000 ((not (frame-visible-p f)) | |
1001 (if (null last-resort) | |
1002 (setq last-resort f))) | |
1003 ((eq f (selected-frame)) | |
1004 (setq first-choice f)) | |
1005 ((null second-choice) | |
1006 (setq second-choice f))) | |
1007 (setq w-list (cdr w-list))) | |
1008 (or first-choice second-choice last-resort))) | |
1009 | |
1010 (get-frame-for-buffer-default-to-current (selected-frame)) | |
1011 | |
1012 (t | |
1013 ;; | |
1014 ;; This buffer's mode did not express a preference for a frame of a | |
1015 ;; particular name. So try to find a frame already displaying this | |
1016 ;; buffer. | |
1017 ;; | |
1018 (let ((w (or (get-buffer-window buffer nil) ; check current first | |
1019 (get-buffer-window buffer 'visible) ; then visible | |
1020 (get-buffer-window buffer 0)))) ; then iconic | |
1021 (cond ((null w) | |
1022 ;; It's not in any window - return nil, meaning no frame has | |
1023 ;; preference. | |
1024 nil) | |
1025 (t | |
1026 ;; Otherwise, return the frame of the buffer's window. | |
1027 (window-frame w)))))))) | |
1028 | |
1029 | |
1030 ;; The pre-display-buffer-function is called for effect, so this needs to | |
1031 ;; actually select the frame it wants. Fdisplay_buffer() takes notice of | |
1032 ;; changes to the selected frame. | |
1033 (defun get-frame-for-buffer (buffer &optional not-this-window-p on-frame) | |
1034 "Select and return a frame in which to display BUFFER. | |
1035 Normally, the buffer will simply be displayed in the selected frame. | |
1036 But if the symbol naming the major-mode of the buffer has a 'frame-name | |
1037 property (which should be a symbol), then the buffer will be displayed in | |
1038 a frame of that name. If there is no frame of that name, then one is | |
1039 created. | |
1040 | |
1041 If the major-mode doesn't have a 'frame-name property, then the frame | |
1042 named by `get-frame-for-buffer-default-frame-name' will be used. If | |
1043 that is nil (the default) then the currently selected frame will used. | |
1044 | |
1045 If the frame-name symbol has an 'instance-limit property (an integer) | |
1046 then each time a buffer of the mode in question is displayed, a new frame | |
1047 with that name will be created, until there are `instance-limit' of them. | |
1048 If instance-limit is 0, then a new frame will be created each time. | |
1049 | |
1050 If a buffer is already displayed in a frame, then `instance-limit' is | |
1051 ignored, and that frame is used. | |
1052 | |
1053 If the frame-name symbol has a 'frame-defaults property, then that is | |
1054 prepended to the `default-frame-plist' when creating a frame for the | |
1055 first time. | |
1056 | |
1057 This function may be used as the value of `pre-display-buffer-function', | |
1058 to cause the display-buffer function and its callers to exhibit the above | |
1059 behavior." | |
1060 (let ((frame (get-frame-for-buffer-noselect | |
1061 buffer not-this-window-p on-frame))) | |
1062 (if (not (eq frame (selected-frame))) | |
1063 frame | |
1064 (select-frame frame) | |
1065 (or (frame-visible-p frame) | |
1066 ;; If the frame was already visible, just focus on it. | |
1067 ;; If it wasn't visible (it was just created, or it used | |
1068 ;; to be iconified) then uniconify, raise, etc. | |
1069 (make-frame-visible frame)) | |
1070 frame))) | |
1071 | |
1072 (defun frames-of-buffer (&optional buffer visible-only) | |
1073 "Return list of frames that BUFFER is currently being displayed on. | |
1074 If the buffer is being displayed on the currently selected frame, that frame | |
1075 is first in the list. VISIBLE-ONLY will only list non-iconified frames." | |
1076 (let ((list (windows-of-buffer buffer)) | |
1077 (cur-frame (selected-frame)) | |
1078 next-frame frames save-frame) | |
1079 | |
1080 (while list | |
1081 (if (memq (setq next-frame (window-frame (car list))) | |
1082 frames) | |
1083 nil | |
1084 (if (eq cur-frame next-frame) | |
1085 (setq save-frame next-frame) | |
1086 (and | |
1087 (or (not visible-only) | |
1088 (frame-visible-p next-frame)) | |
1089 (setq frames (append frames (list next-frame)))))) | |
1090 (setq list (cdr list))) | |
1091 | |
1092 (if save-frame | |
1093 (append (list save-frame) frames) | |
1094 frames))) | |
1095 | |
1096 (defcustom temp-buffer-shrink-to-fit nil | |
1097 "*When non-nil resize temporary output buffers to minimize blank lines." | |
1098 :type 'boolean | |
1099 :group 'frames) | |
1100 | |
1101 (defcustom temp-buffer-max-height .5 | |
1102 "*Proportion of frame to use for temp windows." | |
1103 :type 'number | |
1104 :group 'frames) | |
1105 | |
1106 (defun show-temp-buffer-in-current-frame (buffer) | |
1107 "For use as the value of temp-buffer-show-function: | |
1108 always displays the buffer in the selected frame, regardless of the behavior | |
1109 that would otherwise be introduced by the `pre-display-buffer-function', which | |
1110 is normally set to `get-frame-for-buffer' (which see)." | |
1111 (let ((pre-display-buffer-function nil)) ; turn it off, whatever it is | |
1112 (let ((window (display-buffer buffer))) | |
1113 (if (not (eq (last-nonminibuf-frame) (window-frame window))) | |
1114 ;; only the pre-display-buffer-function should ever do this. | |
1115 (error "display-buffer switched frames on its own!!")) | |
1116 (setq minibuffer-scroll-window window) | |
1117 (set-window-start window 1) ; obeys narrowing | |
1118 (set-window-point window 1) | |
1119 (when temp-buffer-shrink-to-fit | |
1120 (let* ((temp-window-size (round (* temp-buffer-max-height | |
1121 (frame-height (window-frame window))))) | |
1122 (size (window-displayed-height window))) | |
1123 (when (< size temp-window-size) | |
1124 (enlarge-window (- temp-window-size size) nil window))) | |
1125 (shrink-window-if-larger-than-buffer window)) | |
1126 nil))) | |
1127 | |
1128 (setq pre-display-buffer-function 'get-frame-for-buffer) | |
1129 (setq temp-buffer-show-function 'show-temp-buffer-in-current-frame) | |
1130 | |
1131 | |
1132 ;; from Bob Weiner <bweiner@pts.mot.com>, modified by Ben Wing | |
1133 (defun delete-other-frames (&optional frame) | |
1134 "Delete all but FRAME (or the selected frame)." | |
1135 (interactive) | |
1136 (mapc 'delete-frame (delq (or frame (selected-frame)) (frame-list)))) | |
1137 | |
1138 ;; By adding primitives to directly access the window hierarchy, | |
1139 ;; we can move many functions into Lisp. We do it this way | |
1140 ;; because the implementations are simpler in Lisp, and because | |
1141 ;; new functions like this can be added without requiring C | |
1142 ;; additions. | |
1143 | |
1144 (defun frame-utmost-window-2 (window position left-right-p major-end-p | |
1145 minor-end-p) | |
1146 ;; LEFT-RIGHT-P means we're looking for the leftmost or rightmost | |
1147 ;; window, instead of the highest or lowest. In this case, we | |
1148 ;; say that the "major axis" goes left-to-right instead of top-to- | |
1149 ;; bottom. The "minor axis" always goes perpendicularly. | |
1150 ;; | |
1151 ;; If MAJOR-END-P is t, we're looking for a windows that abut the | |
1152 ;; end (i.e. right or bottom) of the major axis, instead of the | |
1153 ;; start. | |
1154 ;; | |
1155 ;; If MINOR-END-P is t, then we want to start counting from the | |
1156 ;; end of the minor axis instead of the beginning. | |
1157 ;; | |
1158 ;; Here's the general idea: Imagine we're trying to count the number | |
1159 ;; of windows that abut the top; call this function foo(). So, we | |
1160 ;; start with the root window. If this is a vertical combination | |
1161 ;; window, then foo() applied to the root window is the same as | |
1162 ;; foo() applied to the first child. If the root is a horizontal | |
1163 ;; combination window, then foo() applied to the root is the | |
1164 ;; same as the sum of foo() applied to each of the children. | |
1165 ;; Otherwise, the root window is a leaf window, and foo() is 1. | |
1166 ;; Now it's clear that, each time foo() encounters a leaf window, | |
1167 ;; it's encountering a different window that abuts the top. | |
1168 ;; With a little examining, you can see that foo encounters the | |
1169 ;; top-abutting windows in order from left to right. We can | |
1170 ;; modify foo() to return the nth top-abutting window by simply | |
1171 ;; keeping a global variable that is decremented each time | |
1172 ;; foo() encounters a leaf window and would return 1. If the | |
1173 ;; global counter gets to zero, we've encountered the window | |
1174 ;; we were looking for, so we exit right away using a `throw'. | |
1175 ;; Otherwise, we make sure that all normal paths return nil. | |
1176 | |
1177 (let (child) | |
1178 (cond ((setq child (if left-right-p | |
1179 (window-first-hchild window) | |
1180 (window-first-vchild window))) | |
1181 (if major-end-p | |
1182 (while (window-next-child child) | |
1183 (setq child (window-next-child child)))) | |
1184 (frame-utmost-window-2 child position left-right-p major-end-p | |
1185 minor-end-p)) | |
1186 ((setq child (if left-right-p | |
1187 (window-first-vchild window) | |
1188 (window-first-hchild window))) | |
1189 (if minor-end-p | |
1190 (while (window-next-child child) | |
1191 (setq child (window-next-child child)))) | |
1192 (while child | |
1193 (frame-utmost-window-2 child position left-right-p major-end-p | |
1194 minor-end-p) | |
1195 (setq child (if minor-end-p | |
1196 (window-previous-child child) | |
1197 (window-next-child child)))) | |
1198 nil) | |
1199 (t | |
1200 (setcar position (1- (car position))) | |
1201 (if (= (car position) 0) | |
1202 (throw 'fhw-exit window) | |
1203 nil))))) | |
1204 | |
1205 (defun frame-utmost-window-1 (frame position left-right-p major-end-p) | |
1206 (let (minor-end-p) | |
1207 (or frame (setq frame (selected-frame))) | |
1208 (or position (setq position 0)) | |
1209 (if (>= position 0) | |
1210 (setq position (1+ position)) | |
1211 (setq minor-end-p t) | |
1212 (setq position (- position))) | |
1213 (catch 'fhw-exit | |
1214 ;; we use a cons here as a simple form of call-by-reference. | |
1215 ;; scheme has "boxes" for the same purpose. | |
1216 (frame-utmost-window-2 (frame-root-window frame) (list position) | |
1217 left-right-p major-end-p minor-end-p)))) | |
1218 | |
1219 | |
1220 (defun frame-highest-window (&optional frame position) | |
1221 "Return the highest window on FRAME which is at POSITION. | |
1222 If omitted, FRAME defaults to the currently selected frame. | |
1223 POSITION is used to distinguish between multiple windows that abut | |
1224 the top of the frame: 0 means the leftmost window abutting the | |
1225 top of the frame, 1 the next-leftmost, etc. POSITION can also | |
1226 be less than zero: -1 means the rightmost window abutting the | |
1227 top of the frame, -2 the next-rightmost, etc. | |
1228 If omitted, POSITION defaults to 0, i.e. the leftmost highest window. | |
1229 If there is no window at the given POSITION, return nil." | |
1230 (frame-utmost-window-1 frame position nil nil)) | |
1231 | |
1232 (defun frame-lowest-window (&optional frame position) | |
1233 "Return the lowest window on FRAME which is at POSITION. | |
1234 If omitted, FRAME defaults to the currently selected frame. | |
1235 POSITION is used to distinguish between multiple windows that abut | |
1236 the bottom of the frame: 0 means the leftmost window abutting the | |
1237 bottom of the frame, 1 the next-leftmost, etc. POSITION can also | |
1238 be less than zero: -1 means the rightmost window abutting the | |
1239 bottom of the frame, -2 the next-rightmost, etc. | |
1240 If omitted, POSITION defaults to 0, i.e. the leftmost lowest window. | |
1241 If there is no window at the given POSITION, return nil." | |
1242 (frame-utmost-window-1 frame position nil t)) | |
1243 | |
1244 (defun frame-leftmost-window (&optional frame position) | |
1245 "Return the leftmost window on FRAME which is at POSITION. | |
1246 If omitted, FRAME defaults to the currently selected frame. | |
1247 POSITION is used to distinguish between multiple windows that abut | |
1248 the left edge of the frame: 0 means the highest window abutting the | |
1249 left edge of the frame, 1 the next-highest, etc. POSITION can also | |
1250 be less than zero: -1 means the lowest window abutting the | |
1251 left edge of the frame, -2 the next-lowest, etc. | |
1252 If omitted, POSITION defaults to 0, i.e. the highest leftmost window. | |
1253 If there is no window at the given POSITION, return nil." | |
1254 (frame-utmost-window-1 frame position t nil)) | |
1255 | |
1256 (defun frame-rightmost-window (&optional frame position) | |
1257 "Return the rightmost window on FRAME which is at POSITION. | |
1258 If omitted, FRAME defaults to the currently selected frame. | |
1259 POSITION is used to distinguish between multiple windows that abut | |
1260 the right edge of the frame: 0 means the highest window abutting the | |
1261 right edge of the frame, 1 the next-highest, etc. POSITION can also | |
1262 be less than zero: -1 means the lowest window abutting the | |
1263 right edge of the frame, -2 the next-lowest, etc. | |
1264 If omitted, POSITION defaults to 0, i.e. the highest rightmost window. | |
1265 If there is no window at the given POSITION, return nil." | |
1266 (frame-utmost-window-1 frame position t t)) | |
1267 | |
1268 | |
1269 | |
1270 ;; frame properties. | |
1271 | |
1272 (defun set-frame-property (frame prop val) | |
1273 "Set property PROP of FRAME to VAL. See `set-frame-properties'." | |
1274 (set-frame-properties frame (list prop val))) | |
1275 | |
1276 (defun frame-height (&optional frame) | |
1277 "Return number of lines available for display on FRAME." | |
1278 (frame-property frame 'height)) | |
1279 | |
1280 (defun frame-width (&optional frame) | |
1281 "Return number of columns available for display on FRAME." | |
1282 (frame-property frame 'width)) | |
1283 | |
1284 (put 'cursor-color 'frame-property-alias [text-cursor background]) | |
1285 (put 'modeline 'frame-property-alias 'has-modeline-p) | |
1286 | |
1287 | |
1288 (provide 'frame) | |
1289 | |
1290 ;;; frame.el ends here |