1 ;;; winner.el --- Restore old window configurations
3 ;; Copyright (C) 1997, 1998, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006 Free Software Foundation. Inc.
6 ;; Author: Ivar Rummelhoff <ivarru@math.uio.no>
7 ;; Created: 27 Feb 1997
8 ;; Time-stamp: <2006-02-06 15:13:57 ttn>
9 ;; Keywords: convenience frames
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 2, or (at your option)
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs; see the file COPYING. If not, write to the
25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
26 ;; Boston, MA 02110-1301, USA.
30 ;; Winner mode is a global minor mode that records the changes in the
31 ;; window configuration (i.e. how the frames are partitioned into
32 ;; windows) so that the changes can be "undone" using the command
33 ;; `winner-undo'. By default this one is bound to the key sequence
34 ;; ctrl-c left. If you change your mind (while undoing), you can
35 ;; press ctrl-c right (calling `winner-redo'). Even though it uses
36 ;; some features of Emacs20.3, winner.el should also work with
37 ;; Emacs19.34 and XEmacs20, provided that the installed version of
38 ;; custom is not obsolete.
40 ;; Winner mode was improved August 1998.
41 ;; Further improvements February 2002.
49 (defmacro winner-active-region
()
50 (if (fboundp 'region-active-p
)
54 (defsetf winner-active-region
() (store)
55 (if (fboundp 'zmacs-activate-region
)
56 `(if ,store
(zmacs-activate-region)
57 (zmacs-deactivate-region))
58 `(setq mark-active
,store
)))
60 (defalias 'winner-edges
61 (if (featurep 'xemacs
) 'window-pixel-edges
'window-edges
))
62 (defalias 'winner-window-list
63 (if (featurep 'xemacs
)
64 (lambda () (delq (minibuffer-window) (window-list nil
0)))
65 (lambda () (window-list nil
0))))
69 (unless (fboundp 'defgroup
)
70 (defmacro defgroup
(&rest rest
)))
73 "Restoring window configurations."
76 (unless (fboundp 'defcustom
)
77 (defmacro defcustom
(symbol &optional initvalue docs
&rest rest
)
78 (list 'defvar symbol initvalue docs
)))
81 (defcustom winner-mode nil
83 Setting this variable directly does not take effect;
84 use either \\[customize] or the function `winner-mode'."
85 :set
#'(lambda (symbol value
) (funcall symbol
(or value
0)))
86 :initialize
'custom-initialize-default
91 (defcustom winner-dont-bind-my-keys nil
92 "If non-nil: Do not use `winner-mode-map' in Winner mode."
96 (defcustom winner-ring-size
200
97 "Maximum number of stored window configurations per frame."
101 (defcustom winner-boring-buffers
'("*Completions*")
102 "`winner-undo' will not restore windows displaying any of these buffers.
103 You may want to include buffer names such as *Help*, *Apropos*,
104 *Buffer List*, *info* and *Compile-Log*."
105 :type
'(repeat string
)
112 ;;;; Saving old configurations (internal variables and subroutines)
115 ;;; Current configuration
117 ;; List the windows according to their edges.
118 (defun winner-sorted-window-list ()
119 (sort (winner-window-list)
121 (loop for a in
(winner-edges x
)
122 for b in
(winner-edges y
)
124 finally return
(< a b
)))))
126 (defun winner-win-data ()
127 ;; Essential properties of the windows in the selected frame.
128 (loop for win in
(winner-sorted-window-list)
129 collect
(cons (winner-edges win
) (window-buffer win
))))
131 ;; This variable is updated with the current window configuration
132 ;; every time it changes.
133 (defvar winner-currents nil
)
135 ;; The current configuration (+ the buffers involved).
136 (defsubst winner-conf
()
137 (cons (current-window-configuration)
141 ;; Save current configuration.
142 ;; (Called below by `winner-save-old-configurations').
143 (defun winner-remember ()
144 (let ((entry (assq (selected-frame) winner-currents
)))
145 (if entry
(setcdr entry
(winner-conf))
146 (push (cons (selected-frame) (winner-conf))
149 ;; Consult `winner-currents'.
150 (defun winner-configuration (&optional frame
)
151 (or (cdr (assq (or frame
(selected-frame)) winner-currents
))
152 (letf (((selected-frame) frame
))
157 ;;; Saved configurations
159 ;; This variable contains the window cofiguration rings.
160 ;; The key in this alist is the frame.
161 (defvar winner-ring-alist nil
)
163 ;; Find the right ring. If it does not exist, create one.
164 (defsubst winner-ring
(frame)
165 (or (cdr (assq frame winner-ring-alist
))
166 (let ((ring (make-ring winner-ring-size
)))
167 (ring-insert ring
(winner-configuration frame
))
168 (push (cons frame ring
) winner-ring-alist
)
172 ;; If the same command is called several times in a row,
173 ;; we only save one window configuration.
174 (defvar winner-last-command nil
)
176 ;; Frames affected by the previous command.
177 (defvar winner-last-frames nil
)
180 (defsubst winner-equal
(a b
)
181 "Check whether two Winner configurations (as produced by
182 `winner-conf') are equal."
183 (equal (cdr a
) (cdr b
)))
186 ;; Save the current window configuration, if it has changed.
187 ;; If so return frame, otherwise return nil.
188 (defun winner-insert-if-new (frame)
189 (unless (or (memq frame winner-last-frames
)
190 (eq this-command
'winner-redo
))
191 (let ((conf (winner-configuration frame
))
192 (ring (winner-ring frame
)))
193 (when (and (not (ring-empty-p ring
))
194 (winner-equal conf
(ring-ref ring
0)))
195 ;; When the previous configuration was very similar,
196 ;; keep only the latest.
197 (ring-remove ring
0))
198 (ring-insert ring conf
)
199 (push frame winner-last-frames
)
206 ;; Frames affected by the current command.
207 (defvar winner-modified-list nil
)
209 ;; Called whenever the window configuration changes
210 ;; (a `window-configuration-change-hook').
211 (defun winner-change-fun ()
212 (unless (or (memq (selected-frame) winner-modified-list
)
213 (/= 0 (minibuffer-depth)))
214 (push (selected-frame) winner-modified-list
)))
216 ;; A `post-command-hook' for emacsen with
217 ;; `window-configuration-change-hook'.
218 (defun winner-save-old-configurations ()
219 (when (zerop (minibuffer-depth))
220 (unless (eq this-command winner-last-command
)
221 (setq winner-last-frames nil
)
222 (setq winner-last-command this-command
))
223 (dolist (frame winner-modified-list
)
224 (winner-insert-if-new frame
))
225 (setq winner-modified-list nil
)
228 ;; A `minibuffer-setup-hook'.
229 (defun winner-save-unconditionally ()
230 (unless (eq this-command winner-last-command
)
231 (setq winner-last-frames nil
)
232 (setq winner-last-command this-command
))
233 (winner-insert-if-new (selected-frame))
236 ;; A `post-command-hook' for other emacsen.
237 ;; Also called by `winner-undo' before "undoing".
238 (defun winner-save-conditionally ()
239 (when (zerop (minibuffer-depth))
240 (winner-save-unconditionally)))
245 ;;;; Restoring configurations
247 ;; Works almost as `set-window-configuration',
248 ;; but does not change the contents or the size of the minibuffer,
249 ;; and tries to preserve the selected window.
250 (defun winner-set-conf (winconf)
251 (let* ((miniwin (minibuffer-window))
252 (chosen (selected-window))
253 (minisize (window-height miniwin
)))
254 (letf (((window-buffer miniwin
))
255 ((window-point miniwin
)))
256 (set-window-configuration winconf
))
258 ((window-live-p chosen
) (select-window chosen
))
259 ((window-minibuffer-p (selected-window))
261 (when (/= minisize
(window-height miniwin
))
262 (letf (((selected-window) miniwin
) )
263 (setf (window-height) minisize
)))))
267 (defvar winner-point-alist nil
)
268 ;; `set-window-configuration' restores old points and marks. This is
269 ;; not what we want, so we make a list of the "real" (i.e. new) points
270 ;; and marks before undoing window configurations.
272 ;; Format of entries: (buffer (mark . mark-active) (window . point) ..)
274 (defun winner-make-point-alist ()
275 (letf (((current-buffer)))
277 for win in
(winner-window-list)
279 (or (assq (window-buffer win
) alist
)
280 (car (push (list (set-buffer (window-buffer win
))
281 (cons (mark t
) (winner-active-region)))
283 do
(push (cons win
(window-point win
))
285 finally return alist
)))
287 (defun winner-get-point (buf win
)
288 ;; Consult (and possibly extend) `winner-point-alist'.
289 ;; Returns nil iff buf no longer exists.
290 (when (buffer-name buf
)
291 (let ((entry (assq buf winner-point-alist
)))
294 (or (cdr (assq win
(cddr entry
)))
295 (cdr (assq nil
(cddr entry
)))
296 (letf (((current-buffer) buf
))
297 (push (cons nil
(point)) (cddr entry
))
299 (t (letf (((current-buffer) buf
))
301 (cons (mark t
) (winner-active-region))
307 ;; Make sure point does not end up in the minibuffer and delete
308 ;; windows displaying dead or boring buffers
309 ;; (c.f. `winner-boring-buffers'). Return nil iff all the windows
310 ;; should be deleted. Preserve correct points and marks.
311 (defun winner-set (conf)
312 ;; For the format of `conf', see `winner-conf'.
315 ;; Possibly update `winner-point-alist'
316 (loop for buf in
(mapcar 'cdr
(cdr conf
))
317 for pos
= (winner-get-point buf nil
)
318 if
(and pos
(not (memq buf buffers
)))
319 do
(push buf buffers
)
321 (winner-set-conf (car conf
))
322 (let (xwins) ; to be deleted
325 (dolist (win (winner-sorted-window-list))
326 (unless (and (pop alive
)
327 (setf (window-point win
)
328 (winner-get-point (window-buffer win
) win
))
329 (not (member (buffer-name (window-buffer win
))
330 winner-boring-buffers
)))
331 (push win xwins
))) ; delete this window
334 (letf (((current-buffer)))
335 (loop for buf in buffers
336 for entry
= (cadr (assq buf winner-point-alist
))
337 do
(progn (set-buffer buf
)
338 (set-mark (car entry
))
339 (setf (winner-active-region) (cdr entry
)))))
340 ;; Delete windows, whose buffers are dead or boring.
341 ;; Return t if this is still a possible configuration.
344 (mapc 'delete-window
(cdr xwins
)) ; delete all but one
345 (unless (one-window-p t
)
346 (delete-window (car xwins
))
351 ;;;; Winner mode (a minor mode)
353 (defcustom winner-mode-hook nil
354 "Functions to run whenever Winner mode is turned on."
358 (defcustom winner-mode-leave-hook nil
359 "Functions to run whenever Winner mode is turned off."
363 (defvar winner-mode-map
364 (let ((map (make-sparse-keymap)))
365 (define-key map
[(control c
) left
] 'winner-undo
)
366 (define-key map
[(control c
) right
] 'winner-redo
)
368 "Keymap for Winner mode.")
370 ;; Check if `window-configuration-change-hook' is working.
371 (defun winner-hook-installed-p ()
372 (save-window-excursion
373 (let ((winner-var nil
)
374 (window-configuration-change-hook
375 '((lambda () (setq winner-var t
)))))
381 (defun winner-mode (&optional arg
)
383 With arg, turn Winner mode on if and only if arg is positive."
385 (let ((on-p (if arg
(> (prefix-numeric-value arg
) 0)
392 ((winner-hook-installed-p)
393 (add-hook 'window-configuration-change-hook
'winner-change-fun
)
394 (add-hook 'post-command-hook
'winner-save-old-configurations
))
395 (t (add-hook 'post-command-hook
'winner-save-conditionally
)))
396 (add-hook 'minibuffer-setup-hook
'winner-save-unconditionally
)
397 (setq winner-modified-list
(frame-list))
398 (winner-save-old-configurations)
399 (run-hooks 'winner-mode-hook
)
400 (when (interactive-p) (message "Winner mode enabled")))
403 (setq winner-mode nil
)
404 (remove-hook 'window-configuration-change-hook
'winner-change-fun
)
405 (remove-hook 'post-command-hook
'winner-save-old-configurations
)
406 (remove-hook 'post-command-hook
'winner-save-conditionally
)
407 (remove-hook 'minibuffer-setup-hook
'winner-save-unconditionally
)
408 (run-hooks 'winner-mode-leave-hook
)
409 (when (interactive-p) (message "Winner mode disabled"))))))
411 ;; Inspired by undo (simple.el)
413 (defvar winner-undo-frame nil
)
415 (defvar winner-pending-undo-ring nil
416 "The ring currently used by `winner-undo'.")
417 (defvar winner-undo-counter nil
)
418 (defvar winner-undone-data nil
) ; There confs have been passed.
420 (defun winner-undo ()
421 "Switch back to an earlier window configuration saved by Winner mode.
422 In other words, \"undo\" changes in window configuration."
425 ((not winner-mode
) (error "Winner mode is turned off"))
426 (t (unless (and (eq last-command
'winner-undo
)
427 (eq winner-undo-frame
(selected-frame)))
428 (winner-save-conditionally) ; current configuration->stack
429 (setq winner-undo-frame
(selected-frame))
430 (setq winner-point-alist
(winner-make-point-alist))
431 (setq winner-pending-undo-ring
(winner-ring (selected-frame)))
432 (setq winner-undo-counter
0)
433 (setq winner-undone-data
(list (winner-win-data))))
434 (incf winner-undo-counter
) ; starting at 1
435 (when (and (winner-undo-this)
436 (not (window-minibuffer-p (selected-window))))
437 (message "Winner undo (%d / %d)"
439 (1- (ring-length winner-pending-undo-ring
)))))))
444 (defun winner-undo-this () ; The heart of winner undo.
447 ((>= winner-undo-counter
(ring-length winner-pending-undo-ring
))
448 (message "No further window configuration undo information")
451 ((and ; If possible configuration
452 (winner-set (ring-ref winner-pending-undo-ring
453 winner-undo-counter
))
454 ; .. and new configuration
455 (let ((data (winner-win-data)))
456 (and (not (member data winner-undone-data
))
457 (push data winner-undone-data
))))
458 (return t
)) ; .. then everything is fine.
459 (t ;; Otherwise, discharge it (and try the next one).
460 (ring-remove winner-pending-undo-ring winner-undo-counter
)))))
463 (defun winner-redo () ; If you change your mind.
464 "Restore a more recent window configuration saved by Winner mode."
467 ((eq last-command
'winner-undo
)
469 (if (zerop (minibuffer-depth))
470 (ring-remove winner-pending-undo-ring
0)
471 (ring-ref winner-pending-undo-ring
0)))
472 (unless (eq (selected-window) (minibuffer-window))
473 (message "Winner undid undo")))
474 (t (error "Previous command was not a `winner-undo'"))))
476 ;;; To be evaluated when the package is loaded:
478 (unless (or (assq 'winner-mode minor-mode-map-alist
)
479 winner-dont-bind-my-keys
)
480 (push (cons 'winner-mode winner-mode-map
)
481 minor-mode-map-alist
))
484 ;; arch-tag: 686d1c1b-010e-42ca-a192-b5685112418f
485 ;;; winner.el ends here