home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / epoch / epoch-pop.el < prev    next >
Encoding:
Text File  |  1992-05-11  |  8.7 KB  |  258 lines
  1. ;;; -*-Emacs-Lisp-*-
  2. ;;;%Header
  3. ;;; Shrink-wrapped temporary windows for GNU Emacs V2.11
  4. ;;; Copyright (C) 1990, 1991, 1992 Chris McConnell, ccm@cs.cmu.edu.
  5.  
  6. ;;; This file is part of GNU Emacs.
  7.  
  8. ;;; GNU Emacs is distributed in the hope that it will be useful,
  9. ;;; but WITHOUT ANY WARRANTY.  No author or distributor
  10. ;;; accepts responsibility to anyone for the consequences of using it
  11. ;;; or for whether it serves any particular purpose or works at all,
  12. ;;; unless he says so in writing.  Refer to the GNU Emacs General Public
  13. ;;; License for full details.
  14.  
  15. ;;; Everyone is granted permission to copy, modify and redistribute
  16. ;;; GNU Emacs, but only under the conditions described in the
  17. ;;; GNU Emacs General Public License.   A copy of this license is
  18. ;;; supposed to have been given to you along with GNU Emacs so you
  19. ;;; can know your rights and responsibilities.  It should be in a
  20. ;;; file named COPYING.  Among other things, the copyright notice
  21. ;;; and this notice must be preserved on all copies.
  22. ;;;
  23. ;;; DESCRIPTION: This file is a replacement for popper.el when running
  24. ;;; under EPOCH.  It provides a dedicated screen for displaying
  25. ;;; temporary text called the popper screen.  It will work with any
  26. ;;; function that uses temporary windows or that has been wrapped
  27. ;;; using popper-wrap.  The screen can be scrolled or buried from any
  28. ;;; other window.  
  29. ;;;
  30. ;;; When a buffer is displayed using the function
  31. ;;; with-output-to-temp-buffer, the text will be displayed in the
  32. ;;; popper window if the name of the buffer is in popper-pop-buffers
  33. ;;; or popper-pop-buffers is set to T and the name is not in
  34. ;;; popper-no-pop-buffers.  Many kinds of completion and help
  35. ;;; information are displayed this way.  In general any buffer with
  36. ;;; *'s around its name will be a temporary buffer.  Some commands
  37. ;;; like shell-command do not use with-output-to-temp-buffer even
  38. ;;; though you might like to have their output be temporary.  For
  39. ;;; commands like this, you can define a wrapper like this using the
  40. ;;; macro popper-wrap.
  41.  
  42. ;;; USAGE: Load this file, preferably after byte-compiling it.  If you
  43. ;;; do not define key bindings using popper-load-hook, the bindings
  44. ;;; will be:
  45. ;;; 
  46. ;;;  C-z 1   popper-bury-output
  47. ;;;  C-z v   popper-scroll-output
  48.  
  49. ;;; See %%User variables below for possible options.  Here is a sample
  50. ;;; load hook for your .emacs:
  51. ;;;
  52. ;;; (setq popper-load-hook 
  53. ;;;      '(lambda ()
  54. ;;;        ;; Define key bindings
  55. ;;;        (define-key global-map "\C-c1" 'popper-bury-output)
  56. ;;;        (define-key global-map "\C-cv" 'popper-scroll-output)))
  57. ;;; (require 'epoch-pop)
  58. (require 'epoch-util)
  59.  
  60. ;;;%Variables
  61. ;;;%%User
  62. (defvar popper-load-hook nil
  63.   "*List of functions to run when the popper module is loaded.")
  64.  
  65. ;;;
  66. (defvar popper-pop-buffers t
  67.   "*List of buffers to put in the popper window.  If it is T, all
  68. temporary buffers not in popper-no-pop-buffers will be put there.")
  69.  
  70. (defvar popper-no-pop-buffers nil
  71.   "*List of buffers to not put in the popper window when
  72. popper-pop-buffers is T.")
  73.  
  74. ;;;
  75. (defvar popper-screen-properties
  76.       '((icon-name . "** Popper Window **")
  77.     (title     . "** Popper Window **")
  78.     (font . "8x13")
  79.     (cursor-glyph . 58)   ; pointing hand
  80.     (reverse . nil)
  81.     (foreground . "black")
  82.     (background . "white")
  83.     (cursor-foreground . "black")
  84.     (geometry . "80x10+10+10")
  85.     )
  86.   "*Window properties for the popper screen.")
  87.  
  88. (defvar popper-mode-line-text nil
  89.   "*Minor mode text for mode line of popper buffers.  If nil, it will
  90. be set to a short help message on first use of popper.")
  91.  
  92. ;;;%%Internal
  93. (defvar popper-screen () "The screen being used as the popper window.")
  94.  
  95. (defvar popper-buffer nil
  96.   "Indicates buffer is a popper for minor-mode-alist.")
  97. (make-variable-buffer-local 'popper-buffer)
  98. (or (assq 'popper-buffer minor-mode-alist)
  99.     (setq minor-mode-alist
  100.       (cons '(popper-buffer popper-mode-line-text) minor-mode-alist)))
  101.  
  102. ;;; This should be in emacs, but it isn't.
  103. (defun popper-mem (item list &optional elt=)
  104.   "Test to see if ITEM is equal to an item in LIST.
  105. Option comparison function ELT= defaults to equal."
  106.   (let ((elt= (or elt= (function equal)))
  107.     (done nil))
  108.     (while (and list (not done))
  109.       (if (funcall elt= item (car list))
  110.       (setq done list)
  111.       (setq list (cdr list))))
  112.     done))
  113.  
  114. ;;;
  115. (defun popper-screen ()
  116.   "Return the popper screen, creating if necessary."
  117.   (if (and popper-screen (epoch::screen-information popper-screen))
  118.       popper-screen
  119.     ;; I would love to not focus here if I could figure out how
  120.     (setq popper-screen 
  121.       (create-screen nil popper-screen-properties))))
  122.  
  123. ;;;
  124. (defun popper-output-buffer ()
  125.   "Return the buffer being displayed in the popper window."
  126.   (if popper-screen
  127.       (window-buffer (epoch::selected-window popper-screen))))
  128.  
  129. ;;;
  130. (defun popper-bury-output (&optional no-error)
  131.   "Bury the popper output signalling an error if not there unless
  132. optional NO-ERROR is T."
  133.   (interactive)
  134.   (epoch::iconify-screen (popper-screen)))
  135.  
  136. ;;;
  137. (defun popper-scroll-output (&optional n)
  138.   "Scroll text of the popper window upward ARG lines ; or near full
  139. screen if no ARG.  When calling from a program, supply a number as
  140. argument or nil.  If the output window is not being displayed, it will
  141. be brought up."
  142.   (interactive "P")
  143.   (let* ((screen (popper-screen))
  144.      (window (epoch::selected-window screen)))
  145.     (save-screen-excursion
  146.      (epoch::map-screen screen)
  147.      (epoch::select-screen screen)
  148.      ;; This should not scroll unless the window was already up.
  149.      ;; Now if I could only find a way to sense that.
  150.      (select-window window)
  151.      (condition-case ()
  152.      (scroll-up n)
  153.        (error (if (null n)
  154.           (set-window-start (selected-window) 0)))))))
  155.  
  156. ;;;
  157. (defun popper-show-output (buffer)
  158.   (let* ((screen (popper-screen))
  159.      (window (epoch::selected-window screen)))
  160.     (save-screen-excursion
  161.      (epoch::select-screen screen)
  162.      (set-window-buffer window buffer)
  163.      (set-buffer buffer)
  164.      (or popper-mode-line-text
  165.      (setq popper-mode-line-text
  166.            (list
  167.         (format " %s bury, %s scroll" 
  168.             (where-is-internal 'popper-bury-output nil t)
  169.             (where-is-internal 'popper-scroll-output nil t)))))
  170.      (setq popper-buffer t)
  171.      (mapraised-screen screen))))
  172.  
  173. ;;;
  174. (defun popper-show (buffer)
  175.   "Function to display BUFFER in a popper window if it is in
  176. popper-pop-buffers or popper-pop-buffers is T and it is not in
  177. popper-no-pop-buffers."
  178.   (if (eq popper-pop-buffers t)
  179.       (if (popper-mem (buffer-name buffer) popper-no-pop-buffers)
  180.       (display-buffer buffer)
  181.       (popper-show-output buffer))
  182.       (if (popper-mem (buffer-name buffer) popper-pop-buffers))
  183.       (popper-show-output buffer)
  184.       (display-buffer buffer)))
  185.  
  186. ;;; %Wrappers
  187. (defun popper-unwrap (function)
  188.   "Remove the popper wrapper for NAME."
  189.   (let ((var (car (read-from-string (format "popper-%s" function)))))
  190.     (if (boundp var)
  191.     (progn (fset function (symbol-value var))
  192.            (makunbound var)))))
  193.  
  194. ;;;
  195. (defun popper-wrap (function buffer)
  196.   "Define a wrapper on FUNCTION so that BUFFER will be a pop up window."
  197.   (popper-unwrap function)
  198.   (let* ((var (car (read-from-string (format "popper-%s" function))))
  199.      (defn (symbol-function function))
  200.      arg-spec doc int)
  201.     (set var defn)
  202.     (if (consp defn)
  203.     (setq arg-spec (elt defn 1)
  204.           doc (elt defn 2)
  205.           int (elt defn 3))
  206.     (setq arg-spec (aref defn 0)
  207.           doc (and (> (length defn) 4) (aref defn 4))
  208.           int (and (> (length defn) 5) (list 'interactive (aref defn 5)))))
  209.     (fset function 
  210.       (append 
  211.        (list 'lambda arg-spec)
  212.        (if (numberp doc) (list (documentation function)))
  213.        (if (stringp doc) (list doc))
  214.        (if (eq (car int) 'interactive) (list int))
  215.        (list 
  216.         (list
  217.          'let '((shown nil))
  218.          (list 'save-window-excursion 
  219.            (cons 'funcall 
  220.              (cons 
  221.               var
  222.               (let ((args nil))
  223.                 (while arg-spec
  224.                   (if (not (eq (car arg-spec) '&optional))
  225.                   (setq args (cons (car arg-spec)
  226.                            args)))
  227.                   (setq arg-spec (cdr arg-spec)))
  228.                 (reverse args))))
  229.            (list 'setq 'shown (list 'get-buffer-window buffer)))
  230.          (list 'if 'shown
  231.            (list 'funcall 'temp-buffer-show-hook buffer))))))
  232.     (if (not (eq popper-pop-buffers t))
  233.     (let ((elt popper-pop-buffers))
  234.       (while (consp elt)
  235.         (if (string= (car elt) buffer) 
  236.         (setq elt t)
  237.         (setq elt (cdr elt))))
  238.       (if (not elt)
  239.           (setq popper-pop-buffers (cons buffer popper-pop-buffers)))))))
  240.  
  241. ;;; 
  242. (popper-wrap 'shell-command "*Shell Command Output*")
  243. (popper-wrap 'shell-command-on-region "*Shell Command Output*")
  244.  
  245. ;;;
  246. (setq temp-buffer-show-hook 'popper-show)
  247. (run-hooks 'popper-load-hook)
  248.  
  249. ;;; Default key bindings
  250. (if (not (where-is-internal 'popper-bury-output nil t))
  251.     (progn
  252.       (if (not (keymapp (lookup-key global-map "\C-z")))
  253.       (define-key global-map "\C-z" (make-keymap)))
  254.       (define-key global-map "\C-z1" 'popper-bury-output)
  255.       (define-key global-map "\C-zv" 'popper-scroll-output)))
  256.  
  257. (provide 'epoch-pop)
  258.