X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgutter-items.el;h=8ac62f6c26b51692ac63a5c5ac4e315fb898b0b8;hb=dff25f45a911f8a0e5c5bde4c1df0b01e7289fb4;hp=b1c75dfbb85112eef682965e84588c6302656794;hpb=59eec5f21669e81977b5b1fe9bf717cab49cf7fb;p=chise%2Fxemacs-chise.git.1

diff --git a/lisp/gutter-items.el b/lisp/gutter-items.el
index b1c75df..8ac62f6 100644
--- a/lisp/gutter-items.el
+++ b/lisp/gutter-items.el
@@ -39,7 +39,8 @@ Do not set this. Use `set-glyph-image' to change the properties of the tab.")
 (defcustom gutter-buffers-tab-visible-p
   (gutter-element-visible-p default-gutter-visible-p 'buffers-tab)
   "Whether the buffers tab is globally visible. 
-This option should be set through the options menu."
+
+There are side-effects, so don't setq it; use Customize or the options menu."
   :group 'buffers-tab
   :type 'boolean
   :set #'(lambda (var val)
@@ -47,11 +48,16 @@ This option should be set through the options menu."
 					 'buffers-tab val)
 	   (setq gutter-buffers-tab-visible-p val)))
 
+(defcustom gutter-buffers-tab-enabled t
+  "*Whether to enable support for buffers tab in the gutter.
+This is different to `gutter-buffers-tab-visible-p' which still runs hooks
+even when the gutter is invisible."
+  :group 'buffers-tab
+  :type 'boolean)
+
 (defvar gutter-buffers-tab-orientation 'top
   "Where the buffers tab currently is. Do not set this.")
 
-(defvar gutter-buffers-tab-extent nil)
-
 (defcustom buffers-tab-max-size 6
   "*Maximum number of entries which may appear on the \"Buffers\" tab.
 If this is 10, then only the ten most-recently-selected buffers will be
@@ -70,24 +76,40 @@ a large number or nil will slow down tab responsiveness."
   :group 'buffers-tab)
 
 (defcustom buffers-tab-omit-function 'buffers-menu-omit-invisible-buffers
-  "*If non-nil, a function specifying the buffers to omit from the buffers tab.
+  "*A function specifying the buffers to omit from the buffers tab, or nil.
 This is passed a buffer and should return non-nil if the buffer should be
-omitted.  The default value `buffers-tab-omit-invisible-buffers' omits
+omitted.  The default value `buffers-menu-omit-invisible-buffers' omits
 buffers that are normally considered \"invisible\" (those whose name
 begins with a space)."
   :type '(choice (const :tag "None" nil)
 		 function)
   :group 'buffers-tab)
 
-(defcustom buffers-tab-selection-function 'select-buffers-tab-buffers-by-mode
-  "*If non-nil, a function specifying the buffers to select from the
-buffers tab.  This is passed two buffers and should return non-nil if
-the second buffer should be selected.  The default value
-`select-buffers-tab-buffers-by-mode' groups buffers by major mode and
-by `buffers-tab-grouping-regexp'."
+(make-obsolete-variable 'buffers-tab-selection-function
+			'buffers-tab-filter-functions)
+(defcustom buffers-tab-selection-function nil
+  "*A function specifying buffers to display in the buffers tab, or nil.
+Don't use this---it is never consulted.  Use `buffers-tab-filter-functions'
+instead.
+
+The function must take arguments (BUF1 BUF2).  BUF1 is a candidate for
+display in the buffers tab control.  BUF2 is current (first in the buffers
+list).  Return non-nil if BUF1 should be added to the tab control."
+  :type '(choice function (const :tag "None" nil))
+  :group 'buffers-tab)
 
-  :type '(choice (const :tag "None" nil)
-		 function)
+(defcustom buffers-tab-filter-functions '(select-buffers-tab-buffers-by-mode)
+  "*A list of functions specifying buffers to display in the buffers tab.
+
+If nil, all buffers are kept, up to `buffers-tab-max-size', in usual order.
+Otherwise, each function in the list must take arguments (BUF1 BUF2).
+BUF1 is the candidate, and BUF2 is the current buffer (first in the buffers
+list).  The function should return non-nil if BUF1 should be added to the
+buffers tab.  BUF1 will be omitted if any of the functions returns nil.
+
+Defaults to `select-buffers-tab-buffers-by-mode', which adds BUF1 if BUF1 and
+BUF2 have the same major mode, or both match `buffers-tab-grouping-regexp'."
+  :type '(repeat function)
   :group 'buffers-tab)
 
 (defcustom buffers-tab-sort-function nil
@@ -101,7 +123,7 @@ list in `buffer-list' order (usual most-recently-selected-first)."
   :group 'buffers-tab)
 
 (make-face 'buffers-tab "Face for displaying the buffers tab.")
-(set-face-parent 'buffers-tab 'default)
+(set-face-parent 'buffers-tab 'modeline)
 
 (defcustom buffers-tab-face 'buffers-tab
   "*Face to use for displaying the buffers tab."
@@ -159,13 +181,14 @@ If this is 0, then the full buffer name will be shown."
 	(select-window (car (windows-of-buffer buffer)))
       (switch-to-buffer buffer))))
 
-(defun select-buffers-tab-buffers-by-mode (buf1 buf2)
+(defun select-buffers-tab-buffers-by-mode (buffer-to-select buf1)
   "For use as a value of `buffers-tab-selection-function'.
 This selects buffers by major mode `buffers-tab-grouping-regexp'."
   (let ((mode1 (symbol-name (symbol-value-in-buffer 'major-mode buf1)))
-	(mode2 (symbol-name (symbol-value-in-buffer 'major-mode buf2)))
+	(mode2 (symbol-name (symbol-value-in-buffer 'major-mode 
+						    buffer-to-select)))
 	(modenm1 (symbol-value-in-buffer 'mode-name buf1))
-	(modenm2 (symbol-value-in-buffer 'mode-name buf2)))
+	(modenm2 (symbol-value-in-buffer 'mode-name buffer-to-select)))
     (cond ((or (eq mode1 mode2)
 	       (eq modenm1 modenm2)
 	       (and (string-match "^[^-]+-" mode1)
@@ -212,32 +235,25 @@ This just returns the buffer's name, optionally truncated."
 	   (when selected (setq selected nil))))
      buffers)))
 
-;;; #### SJT I'd really like this function to have just two hooks: (1) the
-;;; buffer filter list and (2) a sort function list.  Both should be lists
-;;; of functions.  Each filter takes two arguments:  a buffer and a model
-;;; buffer.  (The model buffer argument allows selecting according to the
-;;; mode or directory of that buffer.)  The filter returns t if the buffer
-;;; should be listed and nil otherwise.  Effectively the filter amounts to
-;;; the conjuction of the filter list.  (Optionally the filter could take a
-;;; frame instead of a buffer or generalize to a locale as in a specifier?)
-;;; The filtering is done this way to preserve the ordering imposed by
-;;; `buffer-list'.  In addition, the in-deletion argument will be used the
-;;; same way as in the current design.
-;;; The list is checked for length and pruned according to least-recently-
-;;; selected.  (Optionally there could be some kind of sort function here,
-;;; too.)
-;;; Finally the list is sorted to gutter display order, and the tab data
-;;; structure is created and returned.
-;;; #### Docstring isn't very well expressed.
+;;; #### SJT would like this function to have a sort function list. I
+;;; don't see how this could work given that sorting is not
+;;; cumulative --andyp.
 (defun buffers-tab-items (&optional in-deletion frame force-selection)
-  "This is the tab filter for the top-level buffers \"Buffers\" tab.
-It dynamically creates a list of buffers to use as the contents of the tab.
-Only the most-recently-used few buffers will be listed on the tab, for
-efficiency reasons.  You can control how many buffers will be shown by
-setting `buffers-tab-max-size'.  You can control the text of the tab
-items by redefining the function `format-buffers-menu-line'."
+  "Return a list of tab instantiators based on the current buffers list.
+This function is used as the tab filter for the top-level buffers
+\"Buffers\" tab.  It dynamically creates a list of tab instantiators
+to use as the contents of the tab.  The contents and order of the list
+is controlled by `buffers-tab-filter-functions' which by default
+groups buffers according to major mode and removes invisible buffers.
+You can control how many buffers will be shown by setting
+`buffers-tab-max-size'.  You can control the text of the tab items by
+redefining the function `format-buffers-menu-line'."
   (save-match-data
-    (let* ((buffers (delete-if buffers-tab-omit-function (buffer-list frame)))
+    ;; NB it is too late if we run the omit function as part of the
+    ;; filter functions because we need to know which buffer is the
+    ;; context buffer before they get run.
+    (let* ((buffers (delete-if 
+		     buffers-tab-omit-function (buffer-list frame)))
 	   (first-buf (car buffers)))
       ;; maybe force the selected window
       (when (and force-selection
@@ -249,16 +265,24 @@ items by redefining the function `format-buffers-menu-line'."
       (when in-deletion 
 	(setq buffers (delq (current-buffer) buffers))
 	(setq first-buf (car buffers)))
-      ;; select buffers in group (default is by mode)
-      (when buffers-tab-selection-function
-	(delete-if-not #'(lambda (buf)
-			   (funcall buffers-tab-selection-function
-				    first-buf buf)) buffers))
+      ;; filter buffers
+      (when buffers-tab-filter-functions
+	(setq buffers
+	      (delete-if 
+	       #'null 
+	       (mapcar #'(lambda (buf)
+			   (let ((tmp-buf buf))
+			     (mapc #'(lambda (fun)
+				       (unless (funcall fun buf first-buf)
+					 (setq tmp-buf nil)))
+				   buffers-tab-filter-functions)
+			     tmp-buf))
+		       buffers))))
       ;; maybe shorten list of buffers
       (and (integerp buffers-tab-max-size)
 	   (> buffers-tab-max-size 1)
 	   (> (length buffers) buffers-tab-max-size)
-	   (setcdr (nthcdr buffers-tab-max-size buffers) nil))
+	   (setcdr (nthcdr (1- buffers-tab-max-size) buffers) nil))
       ;; sort buffers in group (default is most-recently-selected)
       (when buffers-tab-sort-function
 	(setq buffers (funcall buffers-tab-sort-function buffers)))
@@ -269,14 +293,11 @@ items by redefining the function `format-buffers-menu-line'."
 (defun add-tab-to-gutter ()
   "Put a tab control in the gutter area to hold the most recent buffers."
   (setq gutter-buffers-tab-orientation (default-gutter-position))
-  (let ((gutter-string (copy-sequence "\n")))
-    (unless gutter-buffers-tab-extent
-      (setq gutter-buffers-tab-extent (make-extent 0 1 gutter-string)))
-    (set-extent-begin-glyph 
-     gutter-buffers-tab-extent
-     (setq gutter-buffers-tab 
-	   (make-glyph)))
-
+  (let* ((gutter-string (copy-sequence "\n"))
+	 (gutter-buffers-tab-extent (make-extent 0 1 gutter-string)))
+    (set-extent-begin-glyph gutter-buffers-tab-extent
+			    (setq gutter-buffers-tab 
+				  (make-glyph)))
     ;; Nuke all existing tabs
     (remove-gutter-element top-gutter 'buffers-tab)
     (remove-gutter-element bottom-gutter 'buffers-tab)
@@ -298,56 +319,62 @@ items by redefining the function `format-buffers-menu-line'."
 		 ((eq gutter-buffers-tab-orientation 'left)
 		  (set-specifier left-gutter-border-width 0 'global x)
 		  (set-gutter-element left-gutter 'buffers-tab
-				      gutter-string 'global x)
-		  (set-specifier left-gutter-width
-				 (glyph-width gutter-buffers-tab)
-				 'global x))
+				      gutter-string 'global x))
 		 ((eq gutter-buffers-tab-orientation 'right)
 		  (set-specifier right-gutter-border-width 0 'global x)
 		  (set-gutter-element right-gutter 'buffers-tab
-				      gutter-string 'global x)
-		  (set-specifier right-gutter-width
-				 (glyph-width gutter-buffers-tab)
-				 'global x))
+				      gutter-string 'global x))
 		 )))
      (console-type-list))))
 
 (defun update-tab-in-gutter (frame &optional force-selection)
   "Update the tab control in the gutter area."
     ;; dedicated frames don't get tabs
-  (unless (window-dedicated-p (frame-selected-window frame))
+  (unless (or (window-dedicated-p (frame-selected-window frame))
+	      (frame-property frame 'popup))
     (when (specifier-instance default-gutter-visible-p frame)
       (unless (and gutter-buffers-tab
 		   (eq (default-gutter-position)
 		       gutter-buffers-tab-orientation))
 	(add-tab-to-gutter))
       (when (valid-image-instantiator-format-p 'tab-control frame)
-	(set-glyph-image
-	 gutter-buffers-tab
-	 (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face
-		 :orientation gutter-buffers-tab-orientation
-		 (if (or (eq gutter-buffers-tab-orientation 'top)
-			 (eq gutter-buffers-tab-orientation 'bottom))
-		     :pixel-width :pixel-height)
-		 (if (or (eq gutter-buffers-tab-orientation 'top)
-			 (eq gutter-buffers-tab-orientation 'bottom))
-		     '(gutter-pixel-width) '(gutter-pixel-height))
-		 :items (buffers-tab-items nil frame force-selection))
-	 frame)))))
+	(let ((items (buffers-tab-items nil frame force-selection)))
+	  (when items
+	    (set-glyph-image
+	     gutter-buffers-tab
+	     (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face
+		     :orientation gutter-buffers-tab-orientation
+		     (if (or (eq gutter-buffers-tab-orientation 'top)
+			     (eq gutter-buffers-tab-orientation 'bottom))
+			 :pixel-width :pixel-height)
+		     (if (or (eq gutter-buffers-tab-orientation 'top)
+			     (eq gutter-buffers-tab-orientation 'bottom))
+			 '(gutter-pixel-width) '(gutter-pixel-height)) 
+		     :items items)
+	     frame)
+	    ;; set-glyph-image will not make the gutter dirty
+	    (set-gutter-dirty-p gutter-buffers-tab-orientation)))))))
 
 ;; A myriad of different update hooks all doing slightly different things
-(add-hook 'create-frame-hook 
-	  #'(lambda (frame)
-	      (when gutter-buffers-tab (update-tab-in-gutter frame t))))
-(add-hook 'buffer-list-changed-hook 'update-tab-in-gutter)
-(add-hook 'default-gutter-position-changed-hook
-	  #'(lambda ()
-	      (when gutter-buffers-tab
-		(mapc #'update-tab-in-gutter (frame-list)))))
-(add-hook 'gutter-element-visibility-changed-hook
-	  #'(lambda (prop visible-p)
-	      (when (and (eq prop 'buffers-tab) visible-p)
-		(mapc #'update-tab-in-gutter (frame-list)))))
+(add-one-shot-hook 
+ 'after-init-hook
+ #'(lambda ()
+     ;; don't add the hooks if the user really doesn't want them
+     (when gutter-buffers-tab-enabled
+       (add-hook 'create-frame-hook 
+		 #'(lambda (frame)
+		     (when gutter-buffers-tab (update-tab-in-gutter frame t))))
+       (add-hook 'buffer-list-changed-hook 'update-tab-in-gutter)
+       (add-hook 'default-gutter-position-changed-hook
+		 #'(lambda ()
+		     (when gutter-buffers-tab
+		       (mapc #'update-tab-in-gutter (frame-list)))))
+       (add-hook 'gutter-element-visibility-changed-hook
+		 #'(lambda (prop visible-p)
+		     (when (and (eq prop 'buffers-tab) visible-p)
+		       (mapc #'update-tab-in-gutter (frame-list)))))
+       (update-tab-in-gutter (selected-frame) t))))
+
 ;;
 ;; progress display
 ;; ripped off from message display
@@ -393,21 +420,22 @@ side-by-side."
     (setq progress-glyph-height 16)
     (setq progress-layout-instantiator
 	  `[layout
-	    :orientation horizontal
-	    :margin-width 4
+	    :orientation vertical :margin-width 4
+	    :horizontally-justify left :vertically-justify center
 	    :items (,progress-gauge-instantiator
 		    [button
 		     :pixel-height (eval progress-glyph-height)
 		     ;; 'quit is special and acts "asynchronously".
 		     :descriptor "Stop" :callback 'quit]
 		    ,progress-text-instantiator)])
-    (set-glyph-image progress-layout-glyph progress-layout-instantiator locale))
+    (set-glyph-image progress-layout-glyph progress-layout-instantiator
+		     locale))
    (t 
     (setq progress-glyph-height 24)
     (setq progress-layout-instantiator
 	  `[layout 
-	    :orientation vertical :justify left
-	    :margin-width 4
+	    :orientation vertical :margin-width 4
+	    :horizontally-justify left :vertically-justify center
 	    :items (,progress-text-instantiator
 		    [layout 
 		     :orientation horizontal
@@ -417,7 +445,21 @@ side-by-side."
 			      :descriptor " Stop "
 			      ;; 'quit is special and acts "asynchronously".
 			      :callback 'quit])])])
-    (set-glyph-image progress-layout-glyph progress-layout-instantiator locale))))
+    (set-glyph-image progress-layout-glyph progress-layout-instantiator
+		     locale))))
+
+(defvar progress-abort-glyph (make-glyph))
+
+(defun set-progress-abort-instantiator (&optional locale)
+  (set-glyph-image progress-abort-glyph
+		   `[layout :orientation vertical
+			    :horizontally-justify left :vertically-justify center
+			    :items (,progress-text-instantiator
+				    [layout
+				     :margin-width 4
+				     :pixel-height progress-glyph-height
+				     :orientation horizontal])]
+		   locale))
 
 (defvar progress-stack nil
   "An alist of label/string pairs representing active progress gauges.
@@ -425,15 +467,6 @@ The first element in the list is currently displayed in the gutter area.
 Do not modify this directly--use the `progress-feedback' or
 `display-progress-feedback'/`clear-progress-feedback' functions.")
 
-(defvar progress-abort-glyph
-  (make-glyph
-   `[layout :orientation vertical :justify left
-	    :items (,progress-text-instantiator
-		    [layout
-		     :margin-width 4
-		     :pixel-height progress-glyph-height
-		     :orientation horizontal])]))
-
 (defun progress-feedback-displayed-p (&optional return-string frame)
   "Return a non-nil value if a progress gauge is presently displayed in the
 gutter area.  If optional argument RETURN-STRING is non-nil,
@@ -545,8 +578,8 @@ you should just use (progress nil)."
 	  ;; fixup the gutter specifiers
 	  (set-gutter-element bottom-gutter 'progress gutter-string frame)
 	  (set-specifier bottom-gutter-border-width 2 frame)
-	  (set-instantiator-property progress-text-instantiator :datat message)
-	  (set-progress-feedback-instantiator (frame-selected-window frame))
+	  (set-instantiator-property progress-text-instantiator :data message)
+	  (set-progress-abort-instantiator (frame-selected-window frame))
 	  (set-specifier bottom-gutter-height 'autodetect frame)
 	  (set-gutter-element-visible-p bottom-gutter-visible-p 
 					'progress t frame)
@@ -637,8 +670,10 @@ If the only argument is nil, clear any existing progress gauge."
 
 (defun progress-feedback-with-label (label fmt &optional value &rest args)
   "Print a progress gauge and message in the bottom gutter area of the frame.
-First argument LABEL is an identifier for this progress gauge.  The rest of the
-arguments are the same as to `format'."
+LABEL is an identifier for this progress gauge.
+FMT is a format string to be passed to `format' along with ARGS.
+Optional VALUE is the current degree of progress, an integer 0-100.
+The remaining ARGS are passed with FMT `(apply #'format FMT ARGS)'."
   ;; #### sometimes the buffer gets changed temporarily. I don't know
   ;; why this is, so protect against it.
   (save-excursion