'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
(defcustom buffers-tab-omit-function 'buffers-menu-omit-invisible-buffers
"*If non-nil, a function specifying the buffers to omit from the buffers tab.
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-filter-functions (list buffers-tab-selection-function)
+ "*If non-nil, a list of functions specifying the buffers to select
+from the buffers tab.
+Each function in the list is passed two buffers, the buffer to
+potentially select and the context buffer, and should return non-nil
+if the first buffer should be selected. The default value groups
+buffers by major mode and by `buffers-tab-grouping-regexp'."
+
+ :type '(choice (const :tag "None" nil)
+ sexp)
+ :group 'buffers-tab)
+
(defcustom buffers-tab-sort-function nil
"*If non-nil, a function specifying the buffers to select from the
buffers tab. This is passed the buffer list and returns the list in the
: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."
(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)
(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
(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)))
(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)
((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
;; '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
: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 :justify left
+ :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.
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,
;; 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)
projects / chise / xemacs-chise.git.1 / blobdiff