null+****@clear*****
null+****@clear*****
Sat Jun 9 20:24:49 JST 2012
yuta yamada 2012-06-09 20:24:49 +0900 (Sat, 09 Jun 2012)
New Revision: f47399b736c0e7eb81b7f5aaccff643577f9c216
Log:
Update newest popup.el and popwin.el
Modified files:
popup.el
popwin.el
Modified: popup.el (+132 -83)
===================================================================
--- popup.el 2012-06-09 17:28:51 +0900 (f61b8c8)
+++ popup.el 2012-06-09 20:24:49 +0900 (1a0db18)
@@ -1,10 +1,10 @@
;;; popup.el --- Visual Popup User Interface
-;; Copyright (C) 2009, 2010, 2011 Tomohiro Matsuyama
+;; Copyright (C) 2009, 2010, 2011, 2012 Tomohiro Matsuyama
;; Author: Tomohiro Matsuyama <tomo****@cx4a*****>
;; Keywords: lisp
-;; Version: 0.4
+;; Version: 0.5
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@@ -28,8 +28,7 @@
;;; Code:
-(eval-when-compile
- (require 'cl))
+(require 'cl)
@@ -39,12 +38,17 @@
"Use the optimized column computation routine.
If there is a problem, please set it nil.")
-(defmacro popup-aif (test-form then-form &rest else-forms)
- "Anaphoric if. Temporary variable `it' is the result of
-TEST-FORM."
+(defmacro popup-aif (test then &rest else)
+ "Anaphoric if."
(declare (indent 2))
- `(let ((it ,test-form))
- (if it ,then-form , at else-forms)))
+ `(let ((it ,test))
+ (if it ,then , at else)))
+
+(defmacro popup-awhen (test &rest body)
+ "Anaphoric when."
+ (declare (indent 1))
+ `(let ((it ,test))
+ (when it , at body)))
(defun popup-x-to-string (x)
"Convert any object to string effeciently.
@@ -231,11 +235,11 @@ buffer."
"Background character for scroll-bar.")
(defstruct popup
- point row column width height min-height direction overlays
+ point row column width height min-height direction overlays keymap
parent depth
- face selection-face
+ face mouse-face selection-face
margin-left margin-right margin-left-cancel scroll-bar symbol
- cursor offset scroll-top current-height list newlines
+ cursor offset scroll-top current-height list padding
pattern original-list)
(defun popup-item-propertize (item &rest properties)
@@ -257,7 +261,8 @@ ITEM is not string."
(defun* popup-make-item (name
&key
value
- popup-face
+ face
+ mouse-face
selection-face
sublist
document
@@ -267,7 +272,8 @@ ITEM is not string."
`popup-item-propertize'."
(popup-item-propertize name
'value value
- 'popup-face popup-face
+ 'popup-face face
+ 'popup-mouse-face mouse-face
'selection-face selection-face
'document document
'symbol symbol
@@ -276,7 +282,8 @@ ITEM is not string."
(defsubst popup-item-value (item) (popup-item-property item 'value))
(defsubst popup-item-value-or-self (item) (or (popup-item-value item) item))
-(defsubst popup-item-popup-face (item) (popup-item-property item 'popup-face))
+(defsubst popup-item-face (item) (popup-item-property item 'popup-face))
+(defsubst popup-item-mouse-face (item) (popup-item-property item 'popup-mouse-face))
(defsubst popup-item-selection-face (item) (popup-item-property item 'selection-face))
(defsubst popup-item-document (item) (popup-item-property item 'document))
(defsubst popup-item-summary (item) (popup-item-property item 'summary))
@@ -360,7 +367,7 @@ usual."
(and (eq (overlay-get overlay 'display) nil)
(eq (overlay-get overlay 'after-string) nil))))
-(defun* popup-set-line-item (popup line &key item face margin-left margin-right scroll-bar-char symbol summary)
+(defun* popup-set-line-item (popup line &key item face mouse-face margin-left margin-right scroll-bar-char symbol summary keymap)
(let* ((overlay (popup-line-overlay popup line))
(content (popup-create-line-string popup (popup-x-to-string item)
:margin-left margin-left
@@ -371,18 +378,22 @@ usual."
(prefix (overlay-get overlay 'prefix))
(postfix (overlay-get overlay 'postfix))
end)
+ (put-text-property 0 (length content) 'popup-item item content)
+ (put-text-property 0 (length content) 'keymap keymap content)
;; Overlap face properties
- (if (get-text-property start 'face content)
- (setq start (next-single-property-change start 'face content)))
+ (when (get-text-property start 'face content)
+ (setq start (next-single-property-change start 'face content)))
(while (and start (setq end (next-single-property-change start 'face content)))
(put-text-property start end 'face face content)
(setq start (next-single-property-change end 'face content)))
- (if start
- (put-text-property start (length content) 'face face content))
+ (when start
+ (put-text-property start (length content) 'face face content))
+ (when mouse-face
+ (put-text-property 0 (length content) 'mouse-face mouse-face content))
(unless (overlay-get overlay 'dangle)
(overlay-put overlay 'display (concat prefix (substring content 0 1)))
(setq prefix nil
- content (concat (substring content 1))))
+ content (substring content 1)))
(overlay-put overlay
'after-string
(concat prefix
@@ -440,13 +451,15 @@ number at the point."
min-height
around
(face 'popup-face)
+ mouse-face
(selection-face face)
scroll-bar
margin-left
margin-right
symbol
parent
- parent-offset)
+ parent-offset
+ keymap)
"Create a popup instance at POINT with WIDTH and HEIGHT.
MIN-HEIGHT is a minimal height of the popup. The default value is
@@ -474,7 +487,9 @@ SYMBOL is a single character which indicates a kind of the item.
PARENT is a parent popup instance. If PARENT is omitted, the
popup will be a root instance.
-PARENT-OFFSET is a row offset from the parent popup."
+PARENT-OFFSET is a row offset from the parent popup.
+
+KEYMAP is a keymap that will be put on the popup contents."
(or margin-left (setq margin-left 0))
(or margin-right (setq margin-right 0))
(unless point
@@ -508,13 +523,15 @@ PARENT-OFFSET is a row offset from the parent popup."
;; Calculate direction
(popup-calculate-direction height row)))
(depth (if parent (1+ (popup-depth parent)) 0))
- (newlines (max 0 (+ (- height (count-lines point (point-max))) (if around 1 0))))
+ padding
current-column)
- ;; Case: no newlines at the end of the buffer
- (when (> newlines 0)
+ ;; Case: no room to put overlays
+ (when (eobp)
(popup-save-buffer-state
- (goto-char (point-max))
- (insert (make-string newlines ?\n))))
+ (let ((begin (point)))
+ (insert " ")
+ (setq padding (make-overlay begin (point)))
+ (overlay-put padding 'evaporate t))))
;; Case: the popup overflows
(if overflow
@@ -539,11 +556,11 @@ PARENT-OFFSET is a row offset from the parent popup."
(setq margin-left-cancel t))
(dotimes (i height)
- (let (overlay begin w (dangle t) (prefix "") (postfix ""))
+ (let (overlay begin w bottom (dangle t) (prefix "") (postfix ""))
(when around
- (popup-vertical-motion column direction))
- (setq around t
- current-column (popup-current-physical-column))
+ (setq bottom (zerop (popup-vertical-motion column direction))))
+ (setq around t)
+ (setq current-column (if bottom 0 (popup-current-physical-column)))
(when (> current-column column)
(backward-char)
@@ -551,7 +568,8 @@ PARENT-OFFSET is a row offset from the parent popup."
(when (< current-column column)
;; Extend short buffer lines by popup prefix (line of spaces)
(setq prefix (make-string
- (+ (if (= current-column 0)
+ (+ (if (and (not bottom)
+ (= current-column 0))
(- window-hscroll (current-column))
0)
(- column current-column))
@@ -559,6 +577,8 @@ PARENT-OFFSET is a row offset from the parent popup."
(setq begin (point))
(setq w (+ popup-width (length prefix)))
+ (when bottom
+ (setq prefix (concat "\n" prefix)))
(while (and (not (eolp)) (> w 0))
(setq dangle nil)
(decf w (char-width (char-after)))
@@ -566,6 +586,7 @@ PARENT-OFFSET is a row offset from the parent popup."
(if (< w 0)
(setq postfix (make-string (- w) ? )))
+
(setq overlay (make-overlay begin (point)))
(overlay-put overlay 'window window)
(overlay-put overlay 'dangle dangle)
@@ -588,6 +609,7 @@ PARENT-OFFSET is a row offset from the parent popup."
:parent parent
:depth depth
:face face
+ :mouse-face mouse-face
:selection-face selection-face
:margin-left margin-left
:margin-right margin-right
@@ -599,8 +621,9 @@ PARENT-OFFSET is a row offset from the parent popup."
:scroll-top 0
:current-height 0
:list nil
- :newlines newlines
- :overlays overlays)))
+ :padding padding
+ :overlays overlays
+ :keymap keymap)))
(push it popup-instances)
it))))
@@ -611,14 +634,10 @@ PARENT-OFFSET is a row offset from the parent popup."
(mapc 'delete-overlay (popup-overlays popup))
(setf (popup-overlays popup) nil)
(setq popup-instances (delq popup popup-instances))
- ;; Restore newlines state
- (let ((newlines (popup-newlines popup)))
- (when (> newlines 0)
+ (let ((padding (popup-padding popup)))
+ (when (overlayp padding)
(popup-save-buffer-state
- (goto-char (point-max))
- (dotimes (i newlines)
- (if (= (char-before) ?\n)
- (delete-char -1)))))))
+ (delete-region (overlay-start padding) (overlay-end padding))))))
nil)
(defun popup-draw (popup)
@@ -626,6 +645,7 @@ PARENT-OFFSET is a row offset from the parent popup."
(loop with height = (popup-height popup)
with min-height = (popup-min-height popup)
with popup-face = (popup-face popup)
+ with mouse-face = (popup-mouse-face popup)
with selection-face = (popup-selection-face popup)
with list = (popup-list popup)
with length = (length list)
@@ -638,6 +658,7 @@ PARENT-OFFSET is a row offset from the parent popup."
with cursor = (popup-cursor popup)
with scroll-top = (popup-scroll-top popup)
with offset = (popup-offset popup)
+ with keymap = (popup-keymap popup)
for o from offset
for i from scroll-top
while (< o height)
@@ -645,11 +666,12 @@ PARENT-OFFSET is a row offset from the parent popup."
for page-index = (* thum-size (/ o thum-size))
for face = (if (= i cursor)
(or (popup-item-selection-face item) selection-face)
- (or (popup-item-popup-face item) popup-face))
+ (or (popup-item-face item) popup-face))
for empty-char = (propertize " " 'face face)
for scroll-bar-char = (if scroll-bar
(cond
- ((<= page-size 1)
+ ((and (not (eq scroll-bar :always))
+ (<= page-size 1))
empty-char)
((and (> page-size 1)
(>= cursor (* page-index page-size))
@@ -668,11 +690,13 @@ PARENT-OFFSET is a row offset from the parent popup."
(popup-set-line-item popup o
:item item
:face face
+ :mouse-face mouse-face
:margin-left margin-left
:margin-right margin-right
:scroll-bar-char scroll-bar-char
:symbol sym
- :summary summary)
+ :summary summary
+ :keymap keymap)
finally
;; Remember current height
@@ -989,6 +1013,11 @@ PROMPT is a prompt string when reading events during event loop."
"Face for popup menu."
:group 'popup)
+(defface popup-menu-mouse-face
+ '((t (:background "blue" :foreground "white")))
+ "Face for popup menu."
+ :group 'popup)
+
(defface popup-menu-selection-face
'((t (:background "steelblue" :foreground "white")))
"Face for popup menu selection."
@@ -1030,6 +1059,14 @@ PROMPT is a prompt string when reading events during event loop."
:parent-offset parent-offset
args)))))
+(defun popup-menu-item-of-mouse-event (event)
+ (when (and (consp event)
+ (memq (first event) '(mouse-1 mouse-2 mouse-3 mouse-4 mouse-5)))
+ (let* ((position (second event))
+ (object (elt position 4)))
+ (when (consp object)
+ (get-text-property (cdr object) 'popup-item (car object))))))
+
(defun popup-menu-read-key-sequence (keymap &optional prompt timeout)
(catch 'timeout
(let ((timer (and timeout
@@ -1080,46 +1117,52 @@ PROMPT is a prompt string when reading events during event loop."
:help-delay help-delay)
(keyboard-quit))
(setq key (popup-menu-read-key-sequence keymap prompt help-delay))
- (if (null key)
- (unless (funcall popup-menu-show-quick-help-function menu nil :prompt prompt)
- (clear-this-command-keys)
- (push (read-event prompt) unread-command-events))
- (if (eq (lookup-key (current-global-map) key) 'keyboard-quit)
- (keyboard-quit))
- (setq binding (lookup-key keymap key))
- (cond
- ((eq binding 'popup-close)
- (if (popup-parent menu)
- (return)))
- ((memq binding '(popup-select popup-open))
- (let* ((item (popup-selected-item menu))
- (sublist (popup-item-sublist item)))
- (if sublist
- (popup-aif (popup-cascade-menu sublist
+ (setq binding (lookup-key keymap key))
+ (cond
+ ((or (null key) (zerop (length key)))
+ (unless (funcall popup-menu-show-quick-help-function menu nil :prompt prompt)
+ (clear-this-command-keys)
+ (push (read-event prompt) unread-command-events)))
+ ((eq (lookup-key (current-global-map) key) 'keyboard-quit)
+ (keyboard-quit)
+ (return))
+ ((eq binding 'popup-close)
+ (if (popup-parent menu)
+ (return)))
+ ((memq binding '(popup-select popup-open))
+ (let* ((item (or (popup-menu-item-of-mouse-event (elt key 0))
+ (popup-selected-item menu)))
+ (index (position item (popup-list menu)))
+ (sublist (popup-item-sublist item)))
+ (unless index (return))
+ (if sublist
+ (popup-aif (let (popup-use-optimized-column-computation)
+ (popup-cascade-menu sublist
:around nil
- :parent menu
:margin-left (popup-margin-left menu)
:margin-right (popup-margin-right menu)
- :scroll-bar (popup-scroll-bar menu))
- (and it (return it)))
- (if (eq binding 'popup-select)
- (return (popup-item-value-or-self item))))))
- ((eq binding 'popup-next)
- (popup-next menu))
- ((eq binding 'popup-previous)
- (popup-previous menu))
- ((eq binding 'popup-help)
- (popup-menu-show-help menu))
- ((eq binding 'popup-isearch)
- (popup-isearch menu
- :cursor-color isearch-cursor-color
- :keymap isearch-keymap
- :callback isearch-callback
- :help-delay help-delay))
- ((commandp binding)
- (call-interactively binding))
- (t
- (funcall fallback key (key-binding key))))))))
+ :scroll-bar (popup-scroll-bar menu)
+ :parent menu
+ :parent-offset index))
+ (and it (return it)))
+ (if (eq binding 'popup-select)
+ (return (popup-item-value-or-self item))))))
+ ((eq binding 'popup-next)
+ (popup-next menu))
+ ((eq binding 'popup-previous)
+ (popup-previous menu))
+ ((eq binding 'popup-help)
+ (popup-menu-show-help menu))
+ ((eq binding 'popup-isearch)
+ (popup-isearch menu
+ :cursor-color isearch-cursor-color
+ :keymap isearch-keymap
+ :callback isearch-callback
+ :help-delay help-delay))
+ ((commandp binding)
+ (call-interactively binding))
+ (t
+ (funcall fallback key (key-binding key)))))))
(defun* popup-menu* (list
&key
@@ -1188,12 +1231,14 @@ isearch canceled. The arguments is whole filtered list of items."
(setq menu (popup-create point width height
:around around
:face 'popup-menu-face
+ :mouse-face 'popup-menu-mouse-face
:selection-face 'popup-menu-selection-face
:margin-left margin-left
:margin-right margin-right
:scroll-bar scroll-bar
:symbol symbol
- :parent parent))
+ :parent parent
+ :parent-offset parent-offset))
(unwind-protect
(progn
(popup-set-list menu list)
@@ -1243,6 +1288,10 @@ the sub menu."
(define-key map (kbd "\C-?") 'popup-help)
(define-key map "\C-s" 'popup-isearch)
+
+ (define-key map [mouse-1] 'popup-select)
+ (define-key map [mouse-4] 'popup-previous)
+ (define-key map [mouse-5] 'popup-next)
map))
(provide 'popup)
Modified: popwin.el (+364 -162)
===================================================================
--- popwin.el 2012-06-09 17:28:51 +0900 (a360c64)
+++ popwin.el 2012-06-09 20:24:49 +0900 (fddea8b)
@@ -1,6 +1,6 @@
;;; popwin.el --- Popup Window Manager.
-;; Copyright (C) 2011 Tomohiro Matsuyama
+;; Copyright (C) 2011, 2012 Tomohiro Matsuyama
;; Author: Tomohiro Matsuyama <tomo****@cx4a*****>
;; Keywords: convenience
@@ -41,17 +41,6 @@
;; how to display such buffers. See docstring of
;; `popwin:special-display-config' for more information.
;;
-;; Instead of a recommended way, you can also use popwin by setting
-;; `special-display-function' like:
-;;
-;; (require 'popwin)
-;; (setq special-display-function
-;; 'popwin:special-display-popup-window)
-;;
-;; In this case, you need to change `special-display-buffer-names' or
-;; `special-display-regexps' so that popwin takes care of such
-;; buffers.
-;;
;; The default width/height/position of popup window can be changed by
;; setting `popwin:popup-window-width', `popwin:popup-window-height',
;; and `popwin:popup-window-position'. You can also change the
@@ -62,18 +51,34 @@
(eval-when-compile (require 'cl))
-(defgroup popwin nil
- "Popup Window Manager."
- :group 'convenience
- :prefix "popwin:")
-
-;;; Common
-
-(defmacro popwin:save-selected-window (&rest body)
- "Evaluate BODY saving the selected window."
- `(with-selected-window (selected-window) , at body))
+;;; Utility
+
+(defun popwin:listify (object)
+ "Return a singleton list of OBJECT if OBJECT is an atom,
+otherwise OBJECT itself."
+ (if (atom object) (list object) object))
+
+(defun popwin:subsitute-in-tree (map tree)
+ (if (consp tree)
+ (cons (popwin:subsitute-in-tree map (car tree))
+ (popwin:subsitute-in-tree map (cdr tree)))
+ (or (cdr (assq tree map)) tree)))
+
+(defun popwin:get-buffer (buffer-or-name &optional if-not-found)
+ "Return a buffer named BUFFER-OR-NAME or BUFFER-OR-NAME itself
+if BUFFER-OR-NAME is a buffer. If BUFFER-OR-NAME is a string and
+such a buffer named BUFFER-OR-NAME not found, a new buffer will
+be returned when IF-NOT-FOUND is :create, or an error reported
+when IF-NOT-FOUND is :error. The default of value of IF-NOT-FOUND
+is :error."
+ (ecase (or if-not-found :error)
+ (:create
+ (get-buffer-create buffer-or-name))
+ (:error
+ (or (get-buffer buffer-or-name)
+ (error "No buffer named %s" buffer-or-name)))))
(defun popwin:switch-to-buffer (buffer-or-name &optional norecord)
"Call `switch-to-buffer' forcing BUFFER-OF-NAME be displayed in
@@ -83,6 +88,21 @@ the selected window."
(switch-to-buffer buffer-or-name norecord t)
(switch-to-buffer buffer-or-name norecord))))
+(defun popwin:buried-buffer-p (buffer)
+ "Return t if BUFFER might be thought of as a buried buffer."
+ (eq (car (last (buffer-list))) buffer))
+
+(defun popwin:window-deletable-p (window)
+ "Return t if WINDOW is deletable, meaning that WINDOW is alive
+and not a minibuffer's window, plus there is two or more windows."
+ (and (window-live-p window)
+ (not (window-minibuffer-p window))
+ (not (one-window-p))))
+
+(defmacro popwin:save-selected-window (&rest body)
+ "Evaluate BODY saving the selected window."
+ `(with-selected-window (selected-window) , at body))
+
(defun popwin:last-selected-window ()
"Return currently selected window or lastly selected window if
minibuffer window is selected."
@@ -90,32 +110,40 @@ minibuffer window is selected."
(minibuffer-selected-window)
(selected-window)))
-(defun popwin:buried-buffer-p (buffer)
- "Return t if BUFFER might be thought of as a buried buffer."
- (eq (car (last (buffer-list))) buffer))
+
-(defun popwin:called-interactively-p ()
- (with-no-warnings
- (if (>= emacs-major-version 23)
- (called-interactively-p 'any)
- (called-interactively-p))))
+;;; Common
-(defvar popwin:empty-buffer nil
- "Marker buffer of indicating a window of the buffer is being a
-popup window.")
+(defvar popwin:debug nil)
-(defun popwin:empty-buffer ()
- (if (buffer-live-p popwin:empty-buffer)
- popwin:empty-buffer
- (setq popwin:empty-buffer
- (get-buffer-create " *popwin-empty*"))))
+(defvar popwin:dummy-buffer nil)
+
+(defun popwin:dummy-buffer ()
+ (if (buffer-live-p popwin:dummy-buffer)
+ popwin:dummy-buffer
+ (setq popwin:dummy-buffer (get-buffer-create " *popwin-dummy*"))))
+
+(defun popwin:kill-dummy-buffer ()
+ (when (buffer-live-p popwin:dummy-buffer)
+ (kill-buffer popwin:dummy-buffer))
+ (setq popwin:dummy-buffer nil))
+
+(defun popwin:window-point (window)
+ (if (eq window (selected-window))
+ (with-current-buffer (window-buffer window) (point))
+ (window-point window)))
+
+(defun popwin:set-window-point (window point)
+ "Forcely set window-point."
+ (with-current-buffer (popwin:dummy-buffer)
+ (set-window-point window point)))
(defun popwin:window-trailing-edge-adjustable-p (window)
"Return t if a trailing edge of WINDOW is adjustable."
(let ((next-window (next-window window)))
(and (not (eq next-window (frame-first-window)))
(not (eq (window-buffer next-window)
- (popwin:empty-buffer))))))
+ (popwin:dummy-buffer))))))
(defun* popwin:adjust-window-edges (window
edges
@@ -138,7 +166,9 @@ HFACTOR, and vertical factor VFACTOR."
(defun popwin:window-config-tree-1 (node)
(if (windowp node)
(list 'window
+ node
(window-buffer node)
+ (popwin:window-point node)
(window-edges node)
(eq (selected-window) node))
(destructuring-bind (dir edges . windows) node
@@ -154,24 +184,25 @@ with persistent representations."
(defun popwin:replicate-window-config (window node hfactor vfactor)
"Replicate NODE of window configuration on WINDOW with
-horizontal factor HFACTOR, and vertical factor VFACTOR."
+horizontal factor HFACTOR, and vertical factor VFACTOR. The
+return value is a association list of mapping from old-window to
+new-window."
(if (eq (car node) 'window)
- (destructuring-bind (buffer edges selected)
+ (destructuring-bind (old-win buffer point edges selected)
(cdr node)
(popwin:adjust-window-edges window edges hfactor vfactor)
(with-selected-window window
(popwin:switch-to-buffer buffer t))
+ (popwin:set-window-point window point)
(when selected
- (select-window window)))
+ (select-window window))
+ `((,old-win . ,window)))
(destructuring-bind (dir edges . windows) node
(loop while windows
- for w1 = (pop windows) then w2
- for w2 = (pop windows)
- do
- (let ((new-window (split-window window nil (not dir))))
- (popwin:replicate-window-config window w1 hfactor vfactor)
- (popwin:replicate-window-config new-window w2 hfactor vfactor)
- (setq window new-window))))))
+ for sub-node = (pop windows)
+ for win = window then next-win
+ for next-win = (and windows (split-window win nil (not dir)))
+ append (popwin:replicate-window-config win sub-node hfactor vfactor)))))
(defun popwin:restore-window-outline (node outline)
"Restore window outline accoding to the structures of NODE
@@ -181,8 +212,10 @@ which is a node of `window-tree' and OUTLINE which is a node of
((and (windowp node)
(eq (car outline) 'window))
;; same window
- (let ((edges (nth 2 outline)))
- (popwin:adjust-window-edges node edges)))
+ (let ((point (nth 3 outline))
+ (edges (nth 4 outline)))
+ (popwin:adjust-window-edges node edges)
+ (popwin:set-window-point node point)))
((or (windowp node)
(not (eq (car node) (car outline))))
;; different structure
@@ -199,11 +232,11 @@ which is a node of `window-tree' and OUTLINE which is a node of
(defun popwin:position-horizontal-p (position)
"Return t if POSITION is hozirontal."
- (memq position '(left right)))
+ (and (memq position '(left :left right :right)) t))
(defun popwin:position-vertical-p (position)
"Return t if POSITION is vertical."
- (memq position '(top bottom)))
+ (and (memq position '(top :top bottom :bottom)) t))
(defun popwin:create-popup-window-1 (window size position)
"Create a new window with SIZE at POSITION of WINDOW. The
@@ -226,7 +259,7 @@ return value is a list of a master window and the popup window."
(defun* popwin:create-popup-window (&optional (size 15) (position 'bottom) (adjust t))
"Create a popup window with SIZE on the frame. If SIZE
-isinteger, the size of the popup window will be SIZE. If SIZE is
+is integer, the size of the popup window will be SIZE. If SIZE is
float, the size of popup window will be a multiplier of SIZE and
frame-size. can be an integer and a float. If ADJUST is t, all of
windows will be adjusted to fit the frame. POSITION must be one
@@ -257,14 +290,19 @@ window-configuration."
(popwin:create-popup-window-1 root-win size position)
;; Mark popup-win being a popup window.
(with-selected-window popup-win
- (popwin:switch-to-buffer (popwin:empty-buffer) t))
- (popwin:replicate-window-config master-win root hfactor vfactor)
- (list master-win popup-win)))))
+ (popwin:switch-to-buffer (popwin:dummy-buffer) t))
+ (let ((win-map (popwin:replicate-window-config master-win root hfactor vfactor)))
+ (list master-win popup-win win-map))))))
;;; Common User Interface
+(defgroup popwin nil
+ "Popup Window Manager."
+ :group 'convenience
+ :prefix "popwin:")
+
(defcustom popwin:popup-window-position 'bottom
"Default popup window position. This must be one of (left top right
bottom)."
@@ -293,12 +331,15 @@ frame when a popup window is shown."
:type 'boolean
:group 'popwin)
+(defvar popwin:context-stack nil)
+
(defvar popwin:popup-window nil
"Main popup window instance.")
(defvar popwin:popup-buffer nil
"Buffer of currently shown in the popup window.")
+;; Deprecated
(defvar popwin:master-window nil
"Master window of a popup window.")
@@ -309,6 +350,10 @@ the popup window.")
(defvar popwin:selected-window nil
"Last selected window when the popup window is shown.")
+(defvar popwin:popup-window-dedicated-p nil
+ "Non-nil means the popup window is dedicated to the original
+popup buffer.")
+
(defvar popwin:popup-window-stuck-p nil
"Non-nil means the popup window has been stuck.")
@@ -316,16 +361,73 @@ the popup window.")
"Original window outline which is obtained by
`popwin:window-config-tree'.")
+(defvar popwin:window-map nil
+ "Mapping from old windows to new windows.")
+
(defvar popwin:close-popup-window-timer nil
"Timer of closing the popup window.")
(defvar popwin:close-popup-window-timer-interval 0.01
"Interval of `popwin:close-popup-window-timer'.")
+(defvar popwin:before-popup-hook nil)
+
+(defvar popwin:after-popup-hook nil)
+
+(symbol-macrolet ((context-vars '(popwin:popup-window
+ popwin:popup-buffer
+ popwin:master-window
+ popwin:focus-window
+ popwin:selected-window
+ popwin:popup-window-dedicated-p
+ popwin:popup-window-stuck-p
+ popwin:window-outline
+ popwin:window-map)))
+ (defun popwin:valid-context-p (context)
+ (window-live-p (plist-get context 'popwin:popup-window)))
+
+ (defun popwin:current-context ()
+ (loop for var in context-vars
+ collect var
+ collect (symbol-value var)))
+
+ (defun popwin:use-context (context)
+ (loop for var = (pop context)
+ for val = (pop context)
+ while var
+ do (set var val)))
+
+ (defun popwin:push-context ()
+ (push (popwin:current-context) popwin:context-stack))
+
+ (defun popwin:pop-context ()
+ (popwin:use-context (pop popwin:context-stack)))
+
+ (defun* popwin:find-context-for-buffer (buffer &key valid-only)
+ (loop with stack = popwin:context-stack
+ for context = (pop stack)
+ while context
+ if (and (eq buffer (plist-get context 'popwin:popup-buffer))
+ (or (not valid-only)
+ (popwin:valid-context-p context)))
+ return (list context stack))))
+
(defun popwin:popup-window-live-p ()
"Return t if `popwin:popup-window' is alive."
(window-live-p popwin:popup-window))
+(defun* popwin:update-window-reference (symbol
+ &key
+ (map popwin:window-map)
+ safe
+ recursive)
+ (unless (and safe (not (boundp symbol)))
+ (let ((value (symbol-value symbol)))
+ (set symbol
+ (if recursive
+ (popwin:subsitute-in-tree map value)
+ (or (cdr (assq value map)) value))))))
+
(defun popwin:start-close-popup-window-timer ()
(or popwin:close-popup-window-timer
(setq popwin:close-popup-window-timer
@@ -340,67 +442,94 @@ the popup window.")
(defun popwin:close-popup-window-timer ()
(condition-case var
- (popwin:close-popup-window-if-necessary
- (popwin:should-close-popup-window-p))
- (error (message "popwin:close-popup-window-timer: error: %s" var))))
+ (popwin:close-popup-window-if-necessary)
+ (error
+ (message "popwin:close-popup-window-timer: error: %s" var)
+ (when popwin:debug (backtrace)))))
(defun popwin:close-popup-window (&optional keep-selected)
"Close the popup window and restore to the previous window
configuration. If KEEP-SELECTED is non-nil, the lastly selected
window will not be selected."
(interactive)
- (unwind-protect
- (when popwin:popup-window
- (popwin:stop-close-popup-window-timer)
- (when (and (popwin:popup-window-live-p)
- (window-live-p popwin:master-window))
- (delete-window popwin:popup-window))
- (popwin:restore-window-outline (car (window-tree))
- popwin:window-outline)
- (when (and (not keep-selected)
- (window-live-p popwin:selected-window))
- (select-window popwin:selected-window)))
- (setq popwin:popup-buffer nil
- popwin:popup-window nil
- popwin:focus-window nil
- popwin:selected-window nil
- popwin:popup-window-stuck-p nil
- popwin:window-outline nil)))
-
-(defun popwin:should-close-popup-window-p ()
- "Return t if popwin should close the popup window
-immediately. It might be useful if this is customizable
-function."
- (and popwin:popup-window
- (or (and (eq last-command 'keyboard-quit)
- (eq last-command-event ?\C-g))
- (not (buffer-live-p popwin:popup-buffer))
- (popwin:buried-buffer-p popwin:popup-buffer))))
-
-(defun popwin:close-popup-window-if-necessary (&optional force)
- "Close the popup window if another window has been selected. If
-FORCE is non-nil, this function tries to close the popup window
-immediately if possible, and the lastly selected window will be
-selected again."
+ (when popwin:popup-window
+ (unwind-protect
+ (progn
+ (when (popwin:window-deletable-p popwin:popup-window)
+ (delete-window popwin:popup-window))
+ (popwin:restore-window-outline (car (window-tree)) popwin:window-outline)
+ (when (and (not keep-selected)
+ (window-live-p popwin:selected-window))
+ (select-window popwin:selected-window)))
+ (popwin:pop-context)
+ ;; Cleanup if no context left.
+ (when (null popwin:context-stack)
+ (popwin:kill-dummy-buffer)
+ (popwin:stop-close-popup-window-timer)))))
+
+(defun popwin:close-popup-window-if-necessary ()
+ "Close the popup window if necessary. The all situations where
+the popup window will be closed are followings:
+
+* `C-g' has been pressed.
+* The popup buffer has been killed.
+* The popup buffer has been buried.
+* The popup buffer has been changed if the popup window is
+ dedicated to the buffer.
+* Another window has been selected."
(when popwin:popup-window
(let* ((window (selected-window))
+ (window-point (popwin:window-point window))
+ (window-buffer (window-buffer window))
(minibuf-window-p (window-minibuffer-p window))
+ (reading-from-minibuf
+ (and minibuf-window-p
+ (minibuffer-prompt)
+ t))
+ (quit-requested
+ (and (eq last-command 'keyboard-quit)
+ (eq last-command-event ?\C-g)))
(other-window-selected
(and (not (eq window popwin:focus-window))
(not (eq window popwin:popup-window))))
- (popup-buffer-still-working
- (and (buffer-live-p popwin:popup-buffer)
- (not (popwin:buried-buffer-p popwin:popup-buffer))))
- (not-stuck-or-closed
- (or (not popwin:popup-window-stuck-p)
- (not (popwin:popup-window-live-p)))))
- (if (or force
- (and (not minibuf-window-p)
- not-stuck-or-closed
- other-window-selected))
+ (orig-this-command this-command)
+ (popup-buffer-alive
+ (buffer-live-p popwin:popup-buffer))
+ (popup-buffer-buried
+ (popwin:buried-buffer-p popwin:popup-buffer))
+ (popup-buffer-changed-despite-of-dedicated
+ (and popwin:popup-window-dedicated-p
+ (or (not other-window-selected)
+ (not reading-from-minibuf))
+ (buffer-live-p window-buffer)
+ (not (eq popwin:popup-buffer window-buffer))))
+ (popup-window-alive (popwin:popup-window-live-p)))
+ (when (or quit-requested
+ (not popup-buffer-alive)
+ popup-buffer-buried
+ popup-buffer-changed-despite-of-dedicated
+ (not popup-window-alive)
+ (and other-window-selected
+ (not minibuf-window-p)
+ (not popwin:popup-window-stuck-p)))
+ (when (and quit-requested
+ (null orig-this-command))
+ (setq this-command 'popwin:close-popup-window)
+ (run-hooks 'pre-command-hook))
+ (if reading-from-minibuf
+ (progn
+ (popwin:close-popup-window)
+ (select-window (minibuffer-window)))
(popwin:close-popup-window
(and other-window-selected
- popup-buffer-still-working))))))
+ (and popup-buffer-alive
+ (not popup-buffer-buried))))
+ (when popup-buffer-changed-despite-of-dedicated
+ (popwin:switch-to-buffer window-buffer)
+ (goto-char window-point)))
+ (when (and quit-requested
+ (null orig-this-command))
+ (run-hooks 'post-command-hook))))))
(defun* popwin:popup-buffer (buffer
&key
@@ -408,6 +537,7 @@ selected again."
(height popwin:popup-window-height)
(position popwin:popup-window-position)
noselect
+ dedicated
stick)
"Show BUFFER in a popup window and return the popup window. If
NOSELECT is non-nil, the popup window will not be selected. If
@@ -417,25 +547,36 @@ that case, the buffer of the popup window will be replaced with
BUFFER."
(interactive "BPopup buffer:\n")
(setq buffer (get-buffer buffer))
- (unless (popwin:popup-window-live-p)
- (let ((win-outline (car (popwin:window-config-tree))))
- (destructuring-bind (master-win popup-win)
- (let ((size (if (popwin:position-horizontal-p position) width height))
- (adjust popwin:adjust-other-windows))
- (popwin:create-popup-window size position adjust))
- (setq popwin:popup-window popup-win
- popwin:master-window master-win
- popwin:window-outline win-outline
- popwin:selected-window (selected-window))
- (popwin:start-close-popup-window-timer))))
- (with-selected-window popwin:popup-window
- (popwin:switch-to-buffer buffer))
- (setq popwin:popup-buffer buffer
- popwin:popup-window-stuck-p stick)
+ (popwin:push-context)
+ (run-hooks 'popwin:before-popup-hook)
+ (multiple-value-bind (context context-stack)
+ (popwin:find-context-for-buffer buffer :valid-only t)
+ (if context
+ (progn
+ (popwin:use-context context)
+ (setq popwin:context-stack context-stack))
+ (let ((win-outline (car (popwin:window-config-tree))))
+ (destructuring-bind (master-win popup-win win-map)
+ (let ((size (if (popwin:position-horizontal-p position) width height))
+ (adjust popwin:adjust-other-windows))
+ (popwin:create-popup-window size position adjust))
+ (setq popwin:popup-window popup-win
+ popwin:master-window master-win
+ popwin:window-outline win-outline
+ popwin:window-map win-map
+ popwin:selected-window (selected-window)))
+ (popwin:update-window-reference 'popwin:context-stack :recursive t)
+ (popwin:start-close-popup-window-timer))
+ (with-selected-window popwin:popup-window
+ (popwin:switch-to-buffer buffer))
+ (setq popwin:popup-buffer buffer
+ popwin:popup-window-dedicated-p dedicated
+ popwin:popup-window-stuck-p stick)))
(if noselect
(setq popwin:focus-window popwin:selected-window)
(setq popwin:focus-window popwin:popup-window)
(select-window popwin:popup-window))
+ (run-hooks 'popwin:after-popup-hook)
popwin:popup-window)
(defun popwin:select-popup-window ()
@@ -457,9 +598,9 @@ be closed by `popwin:close-popup-window'."
;;; Special Display
-(defmacro popwin:without-special-display (&rest body)
+(defmacro popwin:without-special-displaying (&rest body)
"Evaluate BODY without special displaying."
- `(let (display-buffer-function special-display-function) , at body))
+ `(let (display-buffer-function) , at body))
(defcustom popwin:special-display-config
'(("*Help*")
@@ -493,6 +634,12 @@ empty. Available keywords are following:
noselect: If the value is non-nil, the popup window will not be
selected when it is shown.
+ dedicated: If the value is non-nil, the popup window will be
+ dedicated to the original popup buffer. In this case, when
+ another buffer is selected in the popup window, the popup
+ window will be closed immedicately and the selected buffer
+ will be shown on the previously selected window.
+
stick: If the value is non-nil, the popup window will be stuck
when it is shown.
@@ -507,46 +654,62 @@ buffers will be shown at the left of the frame with width 80."
(defun popwin:original-display-buffer (buffer &optional not-this-window)
"Call `display-buffer' for BUFFER without special displaying."
- (popwin:without-special-display
- ;; Close the popup window here so that the popup window won't to
- ;; be splitted.
- (when (and (eq (selected-window) popwin:popup-window)
- (not (same-window-p (buffer-name buffer))))
- (popwin:close-popup-window))
+ (popwin:without-special-displaying
+ (let ((same-window
+ (or (same-window-p (buffer-name buffer))
+ (and (>= emacs-major-version 24)
+ (boundp 'action)
+ (consp action)
+ (eq (car action) 'display-buffer-same-window)))))
+ ;; Close the popup window here so that the popup window won't to
+ ;; be splitted.
+ (when (and (eq (selected-window) popwin:popup-window)
+ (not same-window))
+ (popwin:close-popup-window)))
(if (and (>= emacs-major-version 24)
(boundp 'action)
(boundp 'frame))
;; Use variables ACTION and FRAME which are formal parameters
;; of DISPLAY-BUFFER.
+ ;;
+ ;; TODO use display-buffer-alist instead of
+ ;; display-buffer-function.
(display-buffer buffer action frame)
(display-buffer buffer not-this-window))))
-(defun* popwin:display-buffer-1 (buffer-or-name &key default-config-keywords if-buffer-not-found if-config-not-found)
+(defun* popwin:display-buffer-1 (buffer-or-name
+ &key
+ default-config-keywords
+ (if-buffer-not-found :create)
+ if-config-not-found)
"Display BUFFER-OR-NAME, if possible, in a popup
window. Otherwise call IF-CONFIG-NOT-FOUND with BUFFER-OR-NAME if
-it is non-nil. If IF-CONFIG-NOT-FOUND is nil, `display-buffer'
-will be called with `special-display-function' nil. If
-IF-BUFFER-NOT-FOUND is :create, create a buffer named
-BUFFER-OR-NAME if there is no such a
-buffer. DEFAULT-CONFIG-KEYWORDS is a property list which
-specifies default values of the selected config."
- (loop with buffer = (if (eq if-buffer-not-found :create)
- (get-buffer-create buffer-or-name)
- (get-buffer buffer-or-name))
+the value is a function. If IF-CONFIG-NOT-FOUND is nil,
+`popwin:popup-buffer' will be called. IF-BUFFER-NOT-FOUND
+indicates what happens when there is no such buffers. If the
+value is :create, create a new buffer named BUFFER-OR-NAME. If
+the value is :error, report an error. The default value
+is :create. DEFAULT-CONFIG-KEYWORDS is a property list which
+specifies default values of the config."
+ (loop with buffer = (popwin:get-buffer buffer-or-name if-buffer-not-found)
with name = (buffer-name buffer)
with mode = (buffer-local-value 'major-mode buffer)
with win-width = popwin:popup-window-width
with win-height = popwin:popup-window-height
with win-position = popwin:popup-window-position
with win-noselect
+ with win-dedicated
with win-stick
with found
until found
- for config in popwin:special-display-config
- for (pattern . keywords) = (if (atom config) (list config) config) do
- (destructuring-bind (&key regexp width height position noselect stick)
+ for config in (if if-config-not-found
+ popwin:special-display-config
+ `(, at popwin:special-display-config t))
+ for (pattern . keywords) = (popwin:listify config) do
+ (destructuring-bind (&key regexp width height position noselect dedicated stick)
(append keywords default-config-keywords)
- (let ((matched (cond ((and (stringp pattern) regexp)
+ (let ((matched (cond ((eq pattern t) t)
+ ((and (stringp pattern) regexp)
(string-match pattern name))
((stringp pattern)
(string= pattern name))
@@ -561,19 +724,19 @@ specifies default values of the selected config."
win-height (or height win-height)
win-position (or position win-position)
win-noselect noselect
+ win-dedicated dedicated
win-stick stick))))
finally return
- (if (or found
- (null if-config-not-found))
- (progn
- (setq popwin:last-display-buffer buffer)
- (popwin:popup-buffer buffer
- :width win-width
- :height win-height
- :position win-position
- :noselect (or (minibufferp) win-noselect)
- :stick win-stick))
- (funcall if-config-not-found buffer))))
+ (if (not found)
+ (funcall if-config-not-found buffer)
+ (setq popwin:last-display-buffer buffer)
+ (popwin:popup-buffer buffer
+ :width win-width
+ :height win-height
+ :position win-position
+ :noselect (or (minibufferp) win-noselect)
+ :dedicated win-dedicated
+ :stick win-stick))))
(defun popwin:display-buffer (buffer-or-name &optional not-this-window)
"Display BUFFER-OR-NAME, if possible, in a popup window, or as
@@ -583,12 +746,12 @@ usual. This function can be used as a value of
(popwin:display-buffer-1
buffer-or-name
:if-config-not-found
- (unless (popwin:called-interactively-p)
+ (unless (called-interactively-p)
(lambda (buffer)
(popwin:original-display-buffer buffer not-this-window)))))
(defun popwin:special-display-popup-window (buffer &rest ignore)
- "The `special-display-function' with a popup window."
+ "Obsolete."
(popwin:display-buffer-1 buffer))
(defun popwin:display-last-buffer ()
@@ -599,6 +762,43 @@ usual. This function can be used as a value of
(popwin:display-buffer-1 popwin:last-display-buffer)
(error "No popup window displayed")))
+(defun* popwin:pop-to-buffer-1 (buffer
+ &key
+ default-config-keywords
+ other-window
+ norecord)
+ (popwin:display-buffer-1 buffer
+ :default-config-keywords default-config-keywords
+ :if-config-not-found
+ (lambda (buffer)
+ (pop-to-buffer buffer other-window norecord))))
+
+(defun popwin:pop-to-buffer (buffer &optional other-window norecord)
+ "Same as `pop-to-buffer' except that this function will use
+`popwin:display-buffer-1' instead of `display-buffer'."
+ (popwin:pop-to-buffer-1 buffer
+ :other-window other-window
+ :norecord norecord))
+
+
+
+;;; Universal Display
+
+(defcustom popwin:universal-display-config '(t)
+ "Same as `popwin:special-display-config' except that this will
+be used for `popwin:universal-display'."
+ :group 'popwin)
+
+(defun popwin:universal-display ()
+ "Call the following command interactively with letting
+`popwin:special-display-config' be
+`popwin:universal-display-config'. This wil be useful when
+displaying buffers in popup windows temporarily."
+ (interactive)
+ (let ((command (key-binding (read-key-sequence "" t)))
+ (popwin:special-display-config popwin:universal-display-config))
+ (call-interactively command)))
+
;;; Extensions
@@ -639,23 +839,25 @@ usual. This function can be used as a value of
;;; Keymaps
(defvar popwin:keymap
- (let ((map (make-keymap)))
- (define-key map "b" 'popwin:popup-buffer)
+ (let ((map (make-sparse-keymap)))
+ (define-key map "b" 'popwin:popup-buffer)
(define-key map "\C-b" 'popwin:popup-buffer)
(define-key map "\M-b" 'popwin:popup-buffer-tail)
- (define-key map "o" 'popwin:display-buffer)
+ (define-key map "o" 'popwin:display-buffer)
(define-key map "\C-o" 'popwin:display-buffer)
- (define-key map "p" 'popwin:display-last-buffer)
+ (define-key map "p" 'popwin:display-last-buffer)
(define-key map "\C-p" 'popwin:display-last-buffer)
- (define-key map "f" 'popwin:find-file)
+ (define-key map "f" 'popwin:find-file)
(define-key map "\C-f" 'popwin:find-file)
(define-key map "\M-f" 'popwin:find-file-tail)
- (define-key map "s" 'popwin:select-popup-window)
+ (define-key map "s" 'popwin:select-popup-window)
(define-key map "\C-s" 'popwin:select-popup-window)
(define-key map "\M-s" 'popwin:stick-popup-window)
- (define-key map "0" 'popwin:close-popup-window)
- (define-key map "m" 'popwin:messages)
+ (define-key map "0" 'popwin:close-popup-window)
+ (define-key map "m" 'popwin:messages)
(define-key map "\C-m" 'popwin:messages)
+ (define-key map "u" 'popwin:universal-display)
+ (define-key map "\C-u" 'popwin:universal-display)
map)
"Default keymap for popwin commands. Use like:
\(global-set-key (kbd \"C-x C-p\") popwin:keymap\)