;;; -*-Emacs-Lisp-*-
;;; %Header
;;; Shrink-wrapped temporary windows for GNU Emacs Rcs_Info: 2.40 $
;;; Copyright (C) 1990, 1991, 1992 Chris McConnell, ccm@cs.cmu.edu.
;;; Thanks to Ken Laprade for suggestions and patches.
;;; This file is part of GNU Emacs.
;;; GNU Emacs is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY. No author or distributor
;;; accepts responsibility to anyone for the consequences of using it
;;; or for whether it serves any particular purpose or works at all,
;;; unless he says so in writing. Refer to the GNU Emacs General Public
;;; License for full details.
;;; Everyone is granted permission to copy, modify and redistribute
;;; GNU Emacs, but only under the conditions described in the
;;; GNU Emacs General Public License. A copy of this license is
;;; supposed to have been given to you along with GNU Emacs so you
;;; can know your rights and responsibilities. It should be in a
;;; file named COPYING. Among other things, the copyright notice
;;; and this notice must be preserved on all copies.
;;; DESCRIPTION: This module provides a single shrink-wrapped window
;;; for displaying temporary text called the popper window. At any
;;; time there is only one popper window on the screen. If there is
;;; an entry for the buffer being displayed on popper-min-heights, the
;;; size of the window will be from that entry. If the buffer is
;;; empty, the size of the window will be popper-empty-min. Otherwise
;;; its size will be the minimum of the number of lines of text being
;;; displayed and half the number of lines in the currently selected
;;; window when the popper window was created. It will work with any
;;; function that uses temporary windows or that has been wrapped with
;;; popper-wrap. The window can be scrolled or buried from any other
;;; window.
;;;
;;; When a buffer is displayed using the function
;;; with-output-to-temp-buffer, the text will be displayed in the
;;; popper window if the name of the buffer is in popper-pop-buffers
;;; or popper-pop-buffers is set to T and the name is not in
;;; popper-no-pop-buffers. If you have a buffer with a process, you
;;; can cause it to automatically scroll by setting
;;; popper-scroll-buffers to t or to a list of buffer names to scroll.
;;; Many kinds of completion and help information are displayed this
;;; way. In general any buffer with *'s around its name will be a
;;; temporary buffer. Some commands like shell-command do not use
;;; with-output-to-temp-buffer even though you might like to have
;;; their output be temporary. For commands like this, you can define
;;; a wrapper like this using the function popper-wrap.
;;;
;;; If popper-use-message-buffer if non-nil then popper output that is
;;; one line or less will be displayed in the minibuffer.
;;;
;;; The default binding for C-x o is changed so that when a buffer is
;;; displayed in a popper window, it will be skipped if it is in
;;; popper-buffers-to-skip or popper-buffers-to-skip is T and it is
;;; not in popper-buffers-no-skip.
;;; USAGE: Load this file, preferably after byte-compiling it. If you
;;; do not define key bindings using popper-load-hook, the bindings
;;; will be:
;;;
;;; C-z 1 popper-bury-output
;;; C-z v popper-scroll-output
;;; C-z g popper-grow-output
;;; C-z b popper-switch
;;; C-x o popper-other-window (C-u to select popper window)
;;; See %%User variables below for possible options. Here is a sample
;;; load hook for your .emacs:
;;;
;;; (setq popper-load-hook
;;; '(lambda ()
;;; (setq popper-pop-buffers t) ; Make popper pop everything temporary - Hooray!
;;; (setq popper-buffers-to-skip t)
;;; ;; Define key bindings
;;; (define-key global-map "\C-c1" 'popper-bury-output)
;;; (define-key global-map "\C-cv" 'popper-scroll-output)
;;; (define-key global-map "\C-cg" 'popper-grow-output)
;;; (define-key global-map "\C-cb" 'popper-switch)
;;; ;; Make *Manual windows default to 10 lines
;;; (setq popper-min-heights
;;; (cons (cons "^\\*Manual" 10) popper-min-heights)
;;; ;; Don't skip over *Buffer List*
;;; popper-buffers-no-skip (cons "*Buffer List*"
;;; popper-buffers-no-skip))))
;;; This is an example that will not work in your .emacs
;;; ;; Make command's output buffer a popper window even though
;;; ;; it does not use with-output-to-temp-buffer
;;; (popper-wrap 'command "*Command Output*")))
;;; (require 'popper)
;;; WARNING: This package redefines the function split-window and
;;; pop-to-buffer so that the popper window is buried before calling
;;; the old definition.
;;;%Globals
;;;%%User variables
(defvar popper-load-hook nil
"List of functions to run when the popper module is loaded.")
;;;
;;; Sun Jun 27 23:18:45 1993 -- Ivan
;;;
;;; Made this default to nil. Just because we require the popper doesn't mean we should lose.
;;;
(defvar popper-pop-buffers nil
"*List of buffers to put in the shrink-wrapped pop-up window.
If it is T, all temporary buffers will be put in the pop-up window.")
(defvar popper-use-message-buffer t
"*If non-nil makes output to popper-buffers that is one line or less
go to the minibuffer.")
(defvar popper-no-pop-buffers nil
"*If popper-pop-buffers is T, these buffers will not be put into the
pop-up window.")
(defvar popper-buffers-to-skip popper-pop-buffers
"*\\[popper-other-window] will skip over these buffers when they are
used in a temporary window. If it is T, all popper windows will be
skipped except those in popper-buffers-no-skip.")
(defvar popper-buffers-no-skip nil
"*\\[popper-other-window] will not skip these buffers when they are
used in a popper window if popper-buffers-to-skip is T.")
(defvar popper-eat-newlines t
"*Boolean for eating trailing newlines in popper buffers.")
(defvar popper-scroll-buffers t
"*If set to T or a list of buffer names, cause buffers with
associated processes to scroll automatically.")
;;; By default, this is set to 2 so that a window can be one line big.
;;; The number of lines in the popper window plus the mode line will
;;; never be less than this value. (In fact no window will be less
;;; than this value.)
(setq window-min-height 2)
;;;
(defvar popper-empty-min '(50)
"*Minimum number of lines to display for an empty popper buffer. If
it is a list, it is an integer percentage 0-100 of the available space.")
;;;
(defvar popper-min-heights '(("^\\*compilation\\*" . (50)))
"*List of cons where each the car is a regular expression pattern to
match a buffer name and the cdr is the minimum number of lines to
allow when popping buffers that match the regular expression. If the
number is a list, it is interpreted as the percentage of available
space 0-100 to use for the window.")
(defvar popper-mode-line-text nil
"*Minor mode text for mode line of popper buffers. If nil, it will
be set to a short help message on first use of popper.")
;;;%%Internal variables
(defvar popper-output-buffers nil
"LIFO list of buffers displayed in the popper window.")
(defvar popper-last-output-window nil
"The window that last popped up an output window.")
(defvar popper-buffer nil
"Indicates buffer is a popper for minor-mode-alist.")
(make-variable-buffer-local 'popper-buffer)
(or (assq 'popper-buffer minor-mode-alist)
(setq minor-mode-alist
(cons '(popper-buffer popper-mode-line-text) minor-mode-alist)))
(defconst popper-emacs-version-id
(cond ((string-match "Lucid" emacs-version)
(if (string-match "^19.[0-7][^0-9]" emacs-version)
'lucid-19
'lucid-19-new))
((string-match "^19" emacs-version)
'fsf-19)
(t 'fsf-18))
"What version of emacs we are running. ")
;;;%Utils
;;; This should be in emacs, but it isn't.
(defun popper-mem (item list &optional elt=)
"Test to see if ITEM is equal to an item in LIST.
Option comparison function ELT= defaults to equal."
(let ((elt= (or elt= (function equal)))
(done nil))
(while (and list (not done))
(if (funcall elt= item (car list))
(setq done list)
(setq list (cdr list))))
done))
;;;
(defun popper-select (&optional window)
"Select WINDOW and its buffer. WINDOW defaults to selected-window."
(setq window (or window (selected-window)))
(select-window window)
(set-buffer (window-buffer window)))
;;;
(defun popper-first-buffer ()
"Remove killed buffers and return the first buffer on
popper-output-buffers."
(while (and popper-output-buffers
(null (buffer-name (car popper-output-buffers))))
(setq popper-output-buffers (cdr popper-output-buffers)))
(let ((buffers popper-output-buffers))
(while (cdr buffers)
(if (buffer-name (car (cdr buffers)))
(setq buffers (cdr buffers))
(rplacd buffers (cdr (cdr buffers))))))
(car popper-output-buffers))
;;;
(defun popper-output-buffer ()
"Return the buffer being displayed in the popper window."
(popper-first-buffer)
(if (not (eq (selected-window) (next-window)))
(let ((buffers popper-output-buffers)
(done nil))
(while (and buffers (not done))
(let* ((buffer (car buffers))
(window (if (buffer-name buffer) (get-buffer-window buffer))))
(if window
(setq done buffer)
(save-excursion
(set-buffer (car buffers)) (setq popper-buffer nil))
(setq buffers (cdr buffers)))))
(if done (setq popper-output-buffers buffers))
done)))
;;;
(defun popper-parent ()
"Return the parent of the popper window."
(let ((output (popper-output-buffer)))
(if output (next-window (get-buffer-window output) 'no))))
;;;
(defun popper-window-heights (window)
"Return a list of the heights of all of the windows following WINDOW."
(let ((heights nil))
(select-window window)
(while (progn
(select-window (next-window (selected-window) 'no))
(not (eq (selected-window) window)))
(setq heights (cons (window-height (selected-window)) heights)))
(reverse heights)))
;;;
(defun popper-min-height ()
"Return the minimum height to use for the buffer in the current
window. This is either an entry from popper-min-heights,
popper-empty-min if the buffer is empty or window-min-height."
(let ((buffer (buffer-name))
(pat popper-min-heights)
min)
(while pat
(if (string-match (car (car pat)) buffer)
(setq min (cdr (car pat))
pat nil)
(setq pat (cdr pat))))
(if (not min)
(setq min
(if (= (point-min) (point-max))
popper-empty-min
window-min-height)))
(if (consp min)
;; Floating percentage
(/ (* (+ (window-height) (window-height (next-window)))
(car min))
100)
min)))
;;;
(defvar popper-original-filter nil
"Original process filter.")
(make-variable-buffer-local 'popper-original-filter)
(defun popper-scroll-filter (process output)
"Scroll and keep last point in window."
(let* ((old (selected-window))
(buffer (process-buffer process))
(window (get-buffer-window buffer))
*w)
(save-excursion
(set-buffer buffer)
(if popper-original-filter
(funcall popper-original-filter process output)
(goto-char (process-mark process))
(insert output)
(set-marker (process-mark process) (point))))
(if (and window)
(progn
(setq *w window)
(select-window window)
(goto-char (point-max))
(move-to-window-line nil)
(select-window old)))))
;;;
(defun popper-show-output (&optional buffer size)
"Bring the output window up showing optional BUFFER in window of
SIZE. If SIZE is not specified, then shrink the window. Finally
select the original window."
(let* ((window (selected-window))
(old-buffer (window-buffer window))
(buffer (get-buffer-create
(or buffer (popper-first-buffer)
(error "No popper buffers"))))
start parent
(min-height (+ window-min-height (or size window-min-height)))
(text-lines (save-excursion
(set-buffer buffer)
(count-lines (point-min) (point-max)))))
(if (and (= text-lines 1) popper-use-message-buffer)
(message
(save-excursion
(set-buffer buffer) (buffer-substring (point-min) (point-max))))
(setq popper-last-output-window window)
(if (eq buffer old-buffer)
(popper-shrink-window)
(if (eq window (minibuffer-window))
(let* ((parent (popper-parent)))
(popper-bury-output t)
(select-window (setq window (or parent (previous-window)))))
(if (not (eq old-buffer (popper-output-buffer)))
(popper-bury-output t)))
(if (< (window-height window) min-height)
(enlarge-window (- min-height (window-height window))))
(setq start (window-start window))
(split-window nil size)
(set-window-buffer window buffer)
(set-buffer buffer)
(setq popper-buffer t)
(or popper-mode-line-text
(setq popper-mode-line-text
(list (format
" %s bury, %s scroll"
(key-description
(if (eq popper-emacs-version-id 'fsf-19)
(where-is-internal
'popper-bury-output nil nil t)
(where-is-internal 'popper-bury-output nil t)))
(key-description
(if (eq popper-emacs-version-id 'fsf-19)
(where-is-internal
'popper-scroll-output nil nil t)
(where-is-internal 'popper-scroll-output
nil t)))))))
(setq popper-output-buffers
(cons buffer (delq buffer popper-output-buffers)))
(if (not size) (popper-shrink-window))
(setq parent (next-window window 'no))
(popper-select parent)
;; Move the window so that top lines get covered unless it would
;; cover point in which case point is at top of window
(save-excursion
(set-window-start parent start)
(move-to-window-line (window-height window))
(set-window-start parent (point)))
(let ((point (save-excursion (beginning-of-line) (point))))
(if (not (pos-visible-in-window-p point))
(set-window-start (selected-window) point)))
(if (eq popper-last-output-window (minibuffer-window))
(select-window (minibuffer-window)))
(set-buffer old-buffer)))))
;;;
(defun popper-shrink-window ()
"Shrink the current window if larger than its buffer unless it has
an entry in popper-min-heights or it is empty in which case
popper-empty-min is used."
(let* ((window (selected-window))
(window-lines (1- (window-height window))))
(set-buffer (window-buffer window))
(let ((buffer-read-only nil)
(buffer-modified-p (buffer-modified-p)))
(save-excursion
;; Delete trailing blank lines
(if popper-eat-newlines
(progn
(goto-char (point-max))
(skip-chars-backward "\n")
(if (< (point) (point-max))
(delete-region (1+ (point)) (point-max)))))
(goto-char (point-min))
;; Delete leading blank lines
(if (looking-at "\n+") (replace-match ""))
(set-buffer-modified-p buffer-modified-p)))
;; Keep scrolling process pop-ups
(let ((process (get-buffer-process (current-buffer))))
(if (and process (or (eq popper-scroll-buffers t)
(memq (buffer-name (current-buffer))
popper-scroll-buffers)))
(progn
(while (not (marker-position (process-mark process)))
(accept-process-output))
(goto-char (point-max))
;; (set-marker (process-mark process) (point))
(insert ? )
(set-mark (point))
(setq popper-original-filter (process-filter process))
(set-process-filter process 'popper-scroll-filter)
)))
(enlarge-window (- (max (1+ (save-excursion
(goto-char (point-min))
(vertical-motion window-lines)))
(1- (popper-min-height)))
window-lines))))
;;;
(defun popper-show (buffer)
"Function to display BUFFER in a popper window if it is in
popper-pop-buffers or popper-pop-buffers is T and it is not in
popper-no-pop-buffers."
(let ((name (if (bufferp buffer) (buffer-name buffer) buffer)))
(if (eq popper-pop-buffers t)
(if (not (popper-mem name popper-no-pop-buffers))
(popper-show-output buffer)
(display-buffer buffer))
(if (popper-mem name popper-pop-buffers)
(popper-show-output buffer)
(display-buffer buffer))))
(setq minibuffer-scroll-window (get-buffer-window buffer)))
;;;%Commands
(defun popper-bury-output (&optional no-error)
"Bury the popper output signalling an error if not there unless
optional NO-ERROR is T."
(interactive)
(let ((buffer (popper-output-buffer)))
(if buffer
(let* ((old (current-buffer))
(old-window (selected-window))
(output (get-buffer-window buffer))
(start (window-height output))
(parent (next-window output 'no))
(height (window-height output))
(heights (popper-window-heights output)))
(bury-buffer buffer)
(delete-window output)
(popper-select parent)
(while heights
(enlarge-window (- (+ height (car heights)) (window-height)))
(if start
(condition-case () (scroll-down start) (error nil)))
(select-window (next-window (selected-window) 'no))
(setq height 0 start nil)
(setq heights (cdr heights)))
(set-buffer old)
(if (not (eq old-window output))
(select-window old-window)))
(if (not no-error) (popper-show-output)))))
;;;
(defun popper-scroll-output (&optional n)
"Scroll text of the popper window upward ARG lines ; or near full
screen if no ARG. When calling from a program, supply a number as
argument or nil. If the output window is not being displayed, it will
be brought up."
(interactive "P")
(let ((buffer (popper-output-buffer)))
(if buffer
(let ((window (selected-window)))
(unwind-protect
(progn (select-window (get-buffer-window buffer))
(condition-case ()
(scroll-up n)
(error
(if (or (null n) (and (numberp n) (> n 0)))
(set-window-start (selected-window) (point-min))
(while (not (pos-visible-in-window-p (point-max)))
(scroll-up nil))))))
(select-window window)))
(popper-show-output))))
;;;
(defun popper-grow-output (&optional n)
"Grow the popper window by ARG (default 1) lines. If the popper
window is not being shown, it will be brought up."
(interactive "p")
(let ((buffer (popper-output-buffer)))
(if buffer
(let ((old-buffer (current-buffer))
(window (selected-window)))
(select-window (get-buffer-window buffer))
(enlarge-window n)
(popper-select (next-window (selected-window) 'no))
(save-excursion
(if (< n 0)
(condition-case () (scroll-up n) (error nil))
(move-to-window-line n)
(set-window-start (selected-window) (point))))
(select-window window)
(set-buffer old-buffer))
(popper-show-output))))
;;;
(defun popper-switch (buffer)
"Switch the popper window to BUFFER."
(interactive
(list (read-buffer
"Popper buffer "
(car (if (popper-output-buffer)
(cdr popper-output-buffers)
popper-output-buffers))
t)))
(if buffer (popper-show buffer)))
;;;%Redefinitions
;;;***Redefine split-window to bury popper window first***
(defvar popper-split-window (symbol-function 'split-window)
"Original definition of split-window.")
(defun split-window (&optional window size hor-flag)
"Split WINDOW, putting SIZE lines in the first of the pair.
WINDOW defaults to selected one and SIZE to half its size.
If optional third arg HOR-FLAG is non-nil, split side by side
and put SIZE columns in the first of the pair."
(let ((parent (popper-parent)))
(if (eq parent (selected-window))
(let* ((pop-size (window-height
(get-buffer-window (popper-output-buffer))))
(size (if size (+ size pop-size))))
(popper-bury-output)
(prog1
(funcall popper-split-window window size hor-flag)
(popper-show-output nil pop-size)))
(funcall popper-split-window window size hor-flag))))
;;; ***Redefine pop-to-buffer to skip output windows***
(defvar popper-pop-to-buffer (symbol-function 'pop-to-buffer)
"Original pop to buffer function.")
(defun pop-to-buffer (buffer &optional other-window)
"Select buffer BUFFER in some window, preferably a different one.
If pop-up-windows is non-nil, windows can be split to do this.
If second arg OTHER-WINDOW is non-nil, insist on finding another
window even if BUFFER is already visible in the selected window."
(let ((parent (popper-parent)))
(if (and parent
(not (eq (get-buffer buffer) (popper-output-buffer))))
(progn
(popper-bury-output)
(funcall popper-pop-to-buffer buffer other-window)
(select-window parent)
(popper-show-output)
(sit-for 0) ;Allow display update
(funcall popper-pop-to-buffer buffer))
(funcall popper-pop-to-buffer buffer other-window))))
;;;***Redefine other-window to skip popper buffers***
(defun popper-other-window (arg)
"Select the arg'th other window. If arg is a C-u prefix, the popper
window will be selected. Otherwise, windows that contain buffers in
popper-buffers-to-skip will be skipped or if popper-buffers-to-skip is
T those that are not in popper-buffers-no-skip."
(interactive "P")
(if (consp arg)
(let* ((buffer (popper-output-buffer))
(window (and buffer (get-buffer-window buffer))))
(if window (select-window window)))
(setq arg (if (eq arg '-) -1 (or arg 1)))
(other-window arg)
(if (eq popper-buffers-to-skip t)
(if (and (not (popper-mem (buffer-name (current-buffer))
popper-buffers-no-skip))
(eq (popper-output-buffer) (current-buffer)))
(other-window arg))
(if (popper-mem (buffer-name (current-buffer))
popper-buffers-to-skip)
(other-window arg)))))
(define-key ctl-x-map "o" 'popper-other-window)
(require 'advice)
(ad-start-advice)
(defun foobar-break (shown)
(message "IN FOOBAR-BREAK")
(sleep-for 1))
;;;
(defmacro popper-wrap (function buffer)
"Define a wrapper on FUNCTION so that BUFFER will be a pop up window."
(let ((name (intern (concat "popper-wrapper-" (symbol-name function)))))
(list 'progn
(list 'defadvice function
(list 'around name 'activate)
(list 'let '((shown nil))
(list 'save-window-excursion
'ad-do-it
(list 'setq 'shown
(list 'get-buffer-window buffer)))
(list 'if 'shown
(list 'funcall
(if (string-match "^18" emacs-version)
'temp-buffer-show-hook
'temp-buffer-show-function)
buffer))))
(list 'if
'(not (eq popper-pop-buffers t))
(list 'let '((elt popper-pop-buffers))
(list 'while '(consp elt)
(list 'if (list 'string= '(car elt) buffer)
'(setq elt t)
'(setq elt (cdr elt))))
(list 'if '(not elt)
(list 'setq
'popper-pop-buffers
(list 'cons buffer
'popper-pop-buffers))))))))
;;;
(popper-wrap shell-command "*Shell Command Output*")
(popper-wrap shell-command-on-region "*Shell Command Output*")
;;;
(if (string-match "^18" emacs-version)
(setq temp-buffer-show-hook 'popper-show)
(setq temp-buffer-show-function 'popper-show))
(run-hooks 'popper-load-hook)
;;; Default key bindings
(if (not (where-is-internal 'popper-bury-output nil t))
(progn
(if (not (keymapp (lookup-key global-map "\C-z")))
(define-key global-map "\C-z" (make-keymap)))
(define-key global-map "\C-z1" 'popper-bury-output)
(define-key global-map "\C-zv" 'popper-scroll-output)
(define-key global-map "\C-zg" 'popper-grow-output)
(define-key global-map "\C-zb" 'popper-switch)))
(provide 'popper)