;;; -*-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 "XEmacs" emacs-version)
	 (if (string-match "^19.[0-7][^0-9]" emacs-version)
	     'xemacs-19
	   'xemacs-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 on-frame)
  "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 on-frame)
	  (select-window parent)
	  (popper-show-output)
	  (sit-for 0)			;Allow display update
	  (funcall popper-pop-to-buffer buffer nil on-frame))
	(funcall popper-pop-to-buffer buffer other-window on-frame))))

;;;***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)