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