[logaling-commit] logaling/logalimacs [master] Update newest popup.el and popwin.el

アーカイブの一覧に戻る

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\)




More information about the logaling-commit mailing list
アーカイブの一覧に戻る