diff options
Diffstat (limited to 'emacs.d/tabbar.el')
| -rw-r--r-- | emacs.d/tabbar.el | 1932 |
1 files changed, 1932 insertions, 0 deletions
diff --git a/emacs.d/tabbar.el b/emacs.d/tabbar.el new file mode 100644 index 0000000..09db712 --- /dev/null +++ b/emacs.d/tabbar.el @@ -0,0 +1,1932 @@ +;;; Tabbar.el --- Display a tab bar in the header line + +;; Copyright (C) 2003, 2004, 2005 David Ponce + +;; Author: David Ponce <david@dponce.com> +;; Maintainer: David Ponce <david@dponce.com> +;; Created: 25 February 2003 +;; Keywords: convenience +;; Revision: $Id: tabbar.el,v 1.69 2006/06/08 08:27:39 ponced Exp $ + +(defconst tabbar-version "2.0") + +;; This file is not part of GNU Emacs. + +;; 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 the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth +;; Floor, Boston, MA 02110-1301, USA. + +;;; Commentary: +;; +;; This library provides the Tabbar global minor mode to display a tab +;; bar in the header line of Emacs 21 and later versions. You can use +;; the mouse to click on a tab and select it. Also, three buttons are +;; displayed on the left side of the tab bar in this order: the +;; "home", "scroll left", and "scroll right" buttons. The "home" +;; button is a general purpose button used to change something on the +;; tab bar. The scroll left and scroll right buttons are used to +;; scroll tabs horizontally. Tabs can be divided up into groups to +;; maintain several sets of tabs at the same time (see also the +;; chapter "Core" below for more details on tab grouping). Only one +;; group is displayed on the tab bar, and the "home" button, for +;; example, can be used to navigate through the different groups, to +;; show different tab bars. +;; +;; In a graphic environment, using the mouse is probably the preferred +;; way to work with the tab bar. However, you can also use the tab +;; bar when Emacs is running on a terminal, so it is possible to use +;; commands to press special buttons, or to navigate cyclically +;; through tabs. +;; +;; These commands, and default keyboard shortcuts, are provided: +;; +;; `tabbar-mode' +;; Toggle the Tabbar global minor mode. When enabled a tab bar is +;; displayed in the header line. +;; +;; `tabbar-local-mode' (C-c <C-f10>) +;; Toggle the Tabbar-Local minor mode. Provided the global minor +;; mode is turned on, the tab bar becomes local in the current +;; buffer when the local minor mode is enabled. This permits to +;; see the tab bar in a buffer where the header line is already +;; used by another mode (like `Info-mode' for example). +;; +;; `tabbar-mwheel-mode' +;; Toggle the Tabbar-Mwheel global minor mode. When enabled you +;; can use the mouse wheel to navigate through tabs of groups. +;; +;; `tabbar-press-home' (C-c <C-home>) +;; `tabbar-press-scroll-left' (C-c <C-prior>) +;; `tabbar-press-scroll-right' (C-c <C-next>) +;; Simulate a mouse-1 click on respectively the "home", "scroll +;; left", and "scroll right" buttons. A numeric prefix argument +;; value of 2, or 3, respectively simulates a mouse-2, or mouse-3 +;; click. +;; +;; `tabbar-backward' (C-c <C-left>) +;; `tabbar-forward' (C-c <C-right>) +;; Are the basic commands to navigate cyclically through tabs or +;; groups of tabs. The cycle is controlled by the +;; `tabbar-cycle-scope' option. The default is to navigate +;; through all tabs across all existing groups of tabs. You can +;; change the default behavior to navigate only through the tabs +;; visible on the tab bar, or through groups of tabs only. Or use +;; the more specialized commands below. +;; +;; `tabbar-backward-tab' +;; `tabbar-forward-tab' +;; Navigate through the tabs visible on the tab bar. +;; +;; `tabbar-backward-group' (C-c <C-up>) +;; `tabbar-forward-group' (C-c <C-down>) +;; Navigate through existing groups of tabs. +;; +;; +;; Core +;; ---- +;; +;; The content of the tab bar is represented by an internal data +;; structure: a tab set. A tab set is a collection (group) of tabs, +;; identified by an unique name. In a tab set, at any time, one and +;; only one tab is designated as selected within the tab set. +;; +;; A tab is a simple data structure giving the value of the tab, and a +;; reference to its tab set container. A tab value can be any Lisp +;; object. Each tab object is guaranteed to be unique. +;; +;; A tab set is displayed on the tab bar through a "view" defined by +;; the index of the leftmost tab shown. Thus, it is possible to +;; scroll the tab bar horizontally by changing the start index of the +;; tab set view. +;; +;; The visual representation of a tab bar is a list of valid +;; `header-line-format' template elements, one for each special +;; button, and for each tab found into a tab set "view". When the +;; visual representation of a tab is required, the function specified +;; in the variable `tabbar-tab-label-function' is called to obtain it. +;; The visual representation of a special button is obtained by +;; calling the function specified in `tabbar-button-label-function', +;; which is passed a button name among `home', `scroll-left', or +;; `scroll-right'. There are also options and faces to customize the +;; appearance of buttons and tabs (see the code for more details). +;; +;; When the mouse is over a tab, the function specified in +;; `tabbar-help-on-tab-function' is called, which is passed the tab +;; and should return a help string to display. When a tab is +;; selected, the function specified in `tabbar-select-tab-function' is +;; called, which is passed the tab and the event received. +;; +;; Similarly, to control the behavior of the special buttons, the +;; following variables are available, for respectively the `home', +;; `scroll-left' and `scroll-right' value of `<button>': +;; +;; `tabbar-<button>-function' +;; Function called when <button> is selected. The function is +;; passed the mouse event received. +;; +;; `tabbar-<button>-help-function' +;; Function called with no arguments to obtain a help string +;; displayed when the mouse is over <button>. +;; +;; To increase performance, each tab set automatically maintains its +;; visual representation in a cache. As far as possible, the cache is +;; used to display the tab set, and refreshed only when necessary. +;; +;; Several tab sets can be maintained at the same time. Only one is +;; displayed on the tab bar, it is obtained by calling the function +;; specified in the variable `tabbar-current-tabset-function'. +;; +;; A special tab set is maintained, that contains the list of the +;; currently selected tabs in the existing tab sets. This tab set is +;; useful to show the existing tab sets in a tab bar, and switch +;; between them easily. The function `tabbar-get-tabsets-tabset' +;; returns this special tab set. +;; +;; +;; Buffer tabs +;; ----------- +;; +;; The default tab bar implementation provided displays buffers in +;; dedicated tabs. Selecting a tab, switch (mouse-1), or pop +;; (mouse-2), to the buffer it contains. +;; +;; The list of buffers put in tabs is provided by the function +;; specified in the variable `tabbar-buffer-list-function'. The +;; default function: `tabbar-buffer-list', excludes buffers whose name +;; starts with a space, when they are not visiting a file. +;; +;; Buffers are organized in groups, each one represented by a tab set. +;; A buffer can have no group, or belong to more than one group. The +;; function specified by the variable `tabbar-buffer-groups-function' +;; is called for each buffer to obtain the groups it belongs to. The +;; default function provided: `tabbar-buffer-groups' organizes buffers +;; depending on their major mode (see that function for details). +;; +;; The "home" button toggles display of buffer groups on the tab bar, +;; allowing to easily show another buffer group by clicking on the +;; associated tab. +;; +;; Known problems: +;; +;; Bug item #858306 at <http://sf.net/tracker/?group_id=79309>: +;; tabbar-mode crashes GNU Emacs 21.3 on MS-Windows 98/95. +;; + +;;; History: +;; + +;;; Code: + +;;; Options +;; +(defgroup tabbar nil + "Display a tab bar in the header line." + :group 'convenience) + +(defcustom tabbar-cycle-scope nil + "*Specify the scope of cyclic navigation through tabs. +The following scopes are possible: + +- `tabs' + Navigate through visible tabs only. +- `groups' + Navigate through tab groups only. +- default + Navigate through visible tabs, then through tab groups." + :group 'tabbar + :type '(choice :tag "Cycle through..." + (const :tag "Visible Tabs Only" tabs) + (const :tag "Tab Groups Only" groups) + (const :tag "Visible Tabs then Tab Groups" nil))) + +(defcustom tabbar-auto-scroll-flag t + "*Non-nil means to automatically scroll the tab bar. +That is, when a tab is selected outside of the tab bar visible area, +the tab bar is scrolled horizontally so the selected tab becomes +visible." + :group 'tabbar + :type 'boolean) + +(defvar tabbar-inhibit-functions '(tabbar-default-inhibit-function) + "List of functions to be called before displaying the tab bar. +Those functions are called one by one, with no arguments, until one of +them returns a non-nil value, and thus, prevents to display the tab +bar.") + +(defvar tabbar-current-tabset-function nil + "Function called with no argument to obtain the current tab set. +This is the tab set displayed on the tab bar.") + +(defvar tabbar-tab-label-function nil + "Function that obtains a tab label displayed on the tab bar. +The function is passed a tab and should return a string.") + +(defvar tabbar-select-tab-function nil + "Function that select a tab. +The function is passed a mouse event and a tab, and should make it the +selected tab.") + +(defvar tabbar-help-on-tab-function nil + "Function to obtain a help string for a tab. +The help string is displayed when the mouse is onto the button. The +function is passed the tab and should return a help string or nil for +none.") + +(defvar tabbar-button-label-function nil + "Function that obtains a button label displayed on the tab bar. +The function is passed a button name should return a propertized +string to display.") + +(defvar tabbar-home-function nil + "Function called when clicking on the tab bar home button. +The function is passed the mouse event received.") + +(defvar tabbar-home-help-function nil + "Function to obtain a help string for the tab bar home button. +The help string is displayed when the mouse is onto the button. +The function is called with no arguments.") + +(defvar tabbar-scroll-left-function 'tabbar-scroll-left + "Function that scrolls tabs on left. +The function is passed the mouse event received when clicking on the +scroll left button. It should scroll the current tab set.") + +(defvar tabbar-scroll-left-help-function 'tabbar-scroll-left-help + "Function to obtain a help string for the scroll left button. +The help string is displayed when the mouse is onto the button. +The function is called with no arguments.") + +(defvar tabbar-scroll-right-function 'tabbar-scroll-right + "Function that scrolls tabs on right. +The function is passed the mouse event received when clicking on the +scroll right button. It should scroll the current tab set.") + +(defvar tabbar-scroll-right-help-function 'tabbar-scroll-right-help + "Function to obtain a help string for the scroll right button. +The help string is displayed when the mouse is onto the button. +The function is called with no arguments.") + +;;; Misc. +;; +(eval-and-compile + (defalias 'tabbar-display-update + (if (fboundp 'force-window-update) + #'(lambda () (force-window-update (selected-window))) + 'force-mode-line-update))) + +(defsubst tabbar-click-p (event) + "Return non-nil if EVENT is a mouse click event." + (memq 'click (event-modifiers event))) + +(defun tabbar-shorten (str width) + "Return a shortened string from STR that fits in the given display WIDTH. +WIDTH is specified in terms of character display width in the current +buffer; see also `char-width'. If STR display width is greater than +WIDTH, STR is truncated and an ellipsis string \"...\" is inserted at +end or in the middle of the returned string, depending on available +room." + (let* ((n (length str)) + (sw (string-width str)) + (el "...") + (ew (string-width el)) + (w 0) + (i 0)) + (cond + ;; STR fit in WIDTH, return it. + ((<= sw width) + str) + ;; There isn't enough room for the ellipsis, STR is just + ;; truncated to fit in WIDTH. + ((<= width ew) + (while (< w width) + (setq w (+ w (char-width (aref str i))) + i (1+ i))) + (substring str 0 i)) + ;; There isn't enough room to insert the ellipsis in the middle + ;; of the truncated string, so put the ellipsis at end. + ((zerop (setq sw (/ (- width ew) 2))) + (setq width (- width ew)) + (while (< w width) + (setq w (+ w (char-width (aref str i))) + i (1+ i))) + (concat (substring str 0 i) el)) + ;; Put the ellipsis in the middle of the truncated string. + (t + (while (< w sw) + (setq w (+ w (char-width (aref str i))) + i (1+ i))) + (setq w (+ w ew)) + (while (< w width) + (setq n (1- n) + w (+ w (char-width (aref str n))))) + (concat (substring str 0 i) el (substring str n))) + ))) + +;;; Tab and tab set +;; +(defsubst tabbar-make-tab (object tabset) + "Return a new tab with value OBJECT. +TABSET is the tab set the tab belongs to." + (cons object tabset)) + +(defsubst tabbar-tab-value (tab) + "Return the value of tab TAB." + (car tab)) + +(defsubst tabbar-tab-tabset (tab) + "Return the tab set TAB belongs to." + (cdr tab)) + +(defvar tabbar-tabsets nil + "The tab sets store.") + +(defvar tabbar-tabsets-tabset nil + "The special tab set of existing tab sets.") + +(defvar tabbar-current-tabset nil + "The tab set currently displayed on the tab bar.") +(make-variable-buffer-local 'tabbar-current-tabset) + +(defvar tabbar-init-hook nil + "Hook run after tab bar data has been initialized. +You should use this hook to initialize dependent data.") + +(defsubst tabbar-init-tabsets-store () + "Initialize the tab set store." + (setq tabbar-tabsets (make-vector 31 0) + tabbar-tabsets-tabset (make-symbol "tabbar-tabsets-tabset")) + (put tabbar-tabsets-tabset 'start 0) + (run-hooks 'tabbar-init-hook)) + +(defvar tabbar-quit-hook nil + "Hook run after tab bar data has been freed. +You should use this hook to reset dependent data.") + +(defsubst tabbar-free-tabsets-store () + "Free the tab set store." + (setq tabbar-tabsets nil + tabbar-tabsets-tabset nil) + (run-hooks 'tabbar-quit-hook)) + +;; Define an "hygienic" function free of side effect between its local +;; variables and those of the callee. +(eval-and-compile + (defalias 'tabbar-map-tabsets + (let ((function (make-symbol "function")) + (result (make-symbol "result")) + (tabset (make-symbol "tabset"))) + `(lambda (,function) + "Apply FUNCTION to each tab set, and make a list of the results. +The result is a list just as long as the number of existing tab sets." + (let (,result) + (mapatoms + #'(lambda (,tabset) + (push (funcall ,function ,tabset) ,result)) + tabbar-tabsets) + ,result))))) + +(defun tabbar-make-tabset (name &rest objects) + "Make a new tab set whose name is the string NAME. +It is initialized with tabs build from the list of OBJECTS." + (let* ((tabset (intern name tabbar-tabsets)) + (tabs (mapcar #'(lambda (object) + (tabbar-make-tab object tabset)) + objects))) + (set tabset tabs) + (put tabset 'select (car tabs)) + (put tabset 'start 0) + tabset)) + +(defsubst tabbar-get-tabset (name) + "Return the tab set whose name is the string NAME. +Return nil if not found." + (intern-soft name tabbar-tabsets)) + +(defsubst tabbar-delete-tabset (tabset) + "Delete the tab set TABSET. +That is, remove it from the tab sets store." + (unintern tabset tabbar-tabsets)) + +(defsubst tabbar-tabs (tabset) + "Return the list of tabs in TABSET." + (symbol-value tabset)) + +(defsubst tabbar-tab-values (tabset) + "Return the list of tab values in TABSET." + (mapcar 'tabbar-tab-value (tabbar-tabs tabset))) + +(defsubst tabbar-get-tab (object tabset) + "Search for a tab with value OBJECT in TABSET. +Return the tab found, or nil if not found." + (assoc object (tabbar-tabs tabset))) + +(defsubst tabbar-member (tab tabset) + "Return non-nil if TAB is in TABSET." + (or (eq (tabbar-tab-tabset tab) tabset) + (memq tab (tabbar-tabs tabset)))) + +(defsubst tabbar-template (tabset) + "Return the cached visual representation of TABSET. +That is, a `header-line-format' template, or nil if the cache is +empty." + (get tabset 'template)) + +(defsubst tabbar-set-template (tabset template) + "Set the cached visual representation of TABSET to TEMPLATE. +TEMPLATE must be a valid `header-line-format' template, or nil to +cleanup the cache." + (put tabset 'template template)) + +(defsubst tabbar-selected-tab (tabset) + "Return the tab selected in TABSET." + (get tabset 'select)) + +(defsubst tabbar-selected-value (tabset) + "Return the value of the tab selected in TABSET." + (tabbar-tab-value (tabbar-selected-tab tabset))) + +(defsubst tabbar-selected-p (tab tabset) + "Return non-nil if TAB is the selected tab in TABSET." + (eq tab (tabbar-selected-tab tabset))) + +(defvar tabbar--track-selected nil) + +(defsubst tabbar-select-tab (tab tabset) + "Make TAB the selected tab in TABSET. +Does nothing if TAB is not found in TABSET. +Return TAB if selected, nil if not." + (when (tabbar-member tab tabset) + (unless (tabbar-selected-p tab tabset) + (tabbar-set-template tabset nil) + (setq tabbar--track-selected tabbar-auto-scroll-flag)) + (put tabset 'select tab))) + +(defsubst tabbar-select-tab-value (object tabset) + "Make the tab with value OBJECT, the selected tab in TABSET. +Does nothing if a tab with value OBJECT is not found in TABSET. +Return the tab selected, or nil if nothing was selected." + (tabbar-select-tab (tabbar-get-tab object tabset) tabset)) + +(defsubst tabbar-start (tabset) + "Return the index of the first visible tab in TABSET." + (get tabset 'start)) + +(defsubst tabbar-view (tabset) + "Return the list of visible tabs in TABSET. +That is, the sub-list of tabs starting at the first visible one." + (nthcdr (tabbar-start tabset) (tabbar-tabs tabset))) + +(defun tabbar-add-tab (tabset object &optional append) + "Add to TABSET a tab with value OBJECT if there isn't one there yet. +If the tab is added, it is added at the beginning of the tab list, +unless the optional argument APPEND is non-nil, in which case it is +added at the end." + (let ((tabs (tabbar-tabs tabset))) + (if (tabbar-get-tab object tabset) + tabs + (let ((tab (tabbar-make-tab object tabset))) + (tabbar-set-template tabset nil) + (set tabset (if append + (append tabs (list tab)) + (cons tab tabs))))))) + +(defun tabbar-delete-tab (tab) + "Remove TAB from its tab set." + (let* ((tabset (tabbar-tab-tabset tab)) + (tabs (tabbar-tabs tabset)) + (sel (eq tab (tabbar-selected-tab tabset))) + (next (and sel (cdr (memq tab tabs))))) + (tabbar-set-template tabset nil) + (setq tabs (delq tab tabs)) + ;; When the selected tab is deleted, select the next one, if + ;; available, or the last one otherwise. + (and sel (tabbar-select-tab (car (or next (last tabs))) tabset)) + (set tabset tabs))) + +(defun tabbar-scroll (tabset count) + "Scroll the visible tabs in TABSET of COUNT units. +If COUNT is positive move the view on right. If COUNT is negative, +move the view on left." + (let ((start (min (max 0 (+ (tabbar-start tabset) count)) + (1- (length (tabbar-tabs tabset)))))) + (when (/= start (tabbar-start tabset)) + (tabbar-set-template tabset nil) + (put tabset 'start start)))) + +(defun tabbar-tab-next (tabset tab &optional before) + "Search in TABSET for the tab after TAB. +If optional argument BEFORE is non-nil, search for the tab before +TAB. Return the tab found, or nil otherwise." + (let* (last (tabs (tabbar-tabs tabset))) + (while (and tabs (not (eq tab (car tabs)))) + (setq last (car tabs) + tabs (cdr tabs))) + (and tabs (if before last (nth 1 tabs))))) + +(defun tabbar-current-tabset (&optional update) + "Return the tab set currently displayed on the tab bar. +If optional argument UPDATE is non-nil, call the user defined function +`tabbar-current-tabset-function' to obtain it. Otherwise return the +current cached copy." + (and update tabbar-current-tabset-function + (setq tabbar-current-tabset + (funcall tabbar-current-tabset-function))) + tabbar-current-tabset) + +(defun tabbar-get-tabsets-tabset () + "Return the tab set of selected tabs in existing tab sets." + (set tabbar-tabsets-tabset (tabbar-map-tabsets 'tabbar-selected-tab)) + (tabbar-scroll tabbar-tabsets-tabset 0) + (tabbar-set-template tabbar-tabsets-tabset nil) + tabbar-tabsets-tabset) + +;;; Faces +;; +(defface tabbar-default + '( + ;;(((class color grayscale) (background light)) + ;; :inherit variable-pitch + ;; :height 0.8 + ;; :foreground "gray50" + ;; :background "grey75" + ;; ) + (((class color grayscale) (background dark)) + :inherit variable-pitch + :height 0.8 + :foreground "grey75" + :background "gray50" + ) + (((class mono) (background light)) + :inherit variable-pitch + :height 0.8 + :foreground "black" + :background "white" + ) + (((class mono) (background dark)) + :inherit variable-pitch + :height 0.8 + :foreground "white" + :background "black" + ) + (t + :inherit variable-pitch + :height 0.8 + :foreground "gray50" + :background "gray75" + )) + "Default face used in the tab bar." + :group 'tabbar) + +(defface tabbar-unselected + '((t + :inherit tabbar-default + :box (:line-width 1 :color "white" :style released-button) + )) + "Face used for unselected tabs." + :group 'tabbar) + +(defface tabbar-selected + '((t + :inherit tabbar-default + :box (:line-width 1 :color "white" :style pressed-button) + :foreground "blue" + )) + "Face used for the selected tab." + :group 'tabbar) + +(defface tabbar-highlight + '((t + :underline t + )) + "Face used to highlight a tab during mouse-overs." + :group 'tabbar) + +(defface tabbar-separator + '((t + :inherit tabbar-default + :height 0.1 + )) + "Face used for separators between tabs." + :group 'tabbar) + +(defface tabbar-button + '((t + :inherit tabbar-default + :box (:line-width 1 :color "white" :style released-button) + :foreground "dark red" + )) + "Face used for tab bar buttons." + :group 'tabbar) + +(defface tabbar-button-highlight + '((t + :inherit tabbar-default + )) + "Face used to highlight a button during mouse-overs." + :group 'tabbar) + +(defcustom tabbar-background-color nil + "*Background color of the tab bar. +By default, use the background color specified for the +`tabbar-default' face (or inherited from another face), or the +background color of the `default' face otherwise." + :group 'tabbar + :type '(choice (const :tag "Default" nil) + (color))) + +(defsubst tabbar-background-color () + "Return the background color of the tab bar." + (or tabbar-background-color + (let* ((face 'tabbar-default) + (color (face-background face))) + (while (null color) + (or (facep (setq face (face-attribute face :inherit))) + (setq face 'default)) + (setq color (face-background face))) + color))) + +;;; Buttons and separator look and feel +;; +(defconst tabbar-button-widget + '(cons + (cons :tag "Enabled" + (string) + (repeat :tag "Image" + :extra-offset 2 + (restricted-sexp :tag "Spec" + :match-alternatives (listp)))) + (cons :tag "Disabled" + (string) + (repeat :tag "Image" + :extra-offset 2 + (restricted-sexp :tag "Spec" + :match-alternatives (listp)))) + ) + "Widget for editing a tab bar button. +A button is specified as a pair (ENABLED-BUTTON . DISABLED-BUTTON), +where ENABLED-BUTTON and DISABLED-BUTTON specify the value used when +the button is respectively enabled and disabled. Each button value is +a pair (STRING . IMAGE) where STRING is a string value, and IMAGE a +list of image specifications. +If IMAGE is non-nil, try to use that image, else use STRING. +If only the ENABLED-BUTTON image is provided, a DISABLED-BUTTON image +is derived from it.") + +;;; Home button +;; +(defvar tabbar-home-button-value nil + "Value of the home button.") + +(defconst tabbar-home-button-enabled-image + '((:type pbm :data "\ +P2 13 13 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 0 +6 0 255 255 255 255 255 255 255 255 255 255 9 130 9 255 255 255 255 +255 255 255 255 255 255 26 130 26 255 255 255 255 255 255 255 0 9 26 +41 130 41 26 9 0 255 255 255 255 5 145 140 135 130 125 120 115 5 255 +255 255 255 0 9 26 41 130 41 26 9 0 255 255 255 255 255 255 255 26 130 +26 255 255 255 255 255 255 255 255 255 255 9 130 9 255 255 255 255 255 +255 255 255 255 255 0 6 0 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 +")) + "Default image for the enabled home button.") + +(defconst tabbar-home-button-disabled-image + '((:type pbm :data "\ +P2 13 13 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 0 0 1 2 3 2 1 0 0 255 255 255 255 0 132 128 123 119 114 110 +106 0 255 255 255 255 0 0 1 2 3 2 1 0 0 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 255 +")) + "Default image for the disabled home button.") + +(defcustom tabbar-home-button + (cons (cons "[o]" tabbar-home-button-enabled-image) + (cons "[x]" tabbar-home-button-disabled-image)) + "The home button. +The variable `tabbar-button-widget' gives details on this widget." + :group 'tabbar + :type tabbar-button-widget + :set '(lambda (variable value) + (custom-set-default variable value) + ;; Schedule refresh of button value. + (setq tabbar-home-button-value nil))) + +;;; Scroll left button +;; +(defvar tabbar-scroll-left-button-value nil + "Value of the scroll left button.") + +(defconst tabbar-scroll-left-button-enabled-image + '((:type pbm :data "\ +P2 13 13 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 128 16 48 255 255 255 255 255 255 255 +255 144 28 86 128 0 255 255 255 255 255 255 160 44 92 159 135 113 0 +255 255 255 255 160 44 97 165 144 129 120 117 0 255 255 176 44 98 175 +174 146 127 126 127 128 0 255 255 0 160 184 156 143 136 134 135 137 +138 0 255 255 176 32 67 144 146 144 145 146 148 149 0 255 255 255 255 +160 42 75 140 154 158 159 160 0 255 255 255 255 255 255 160 40 74 154 +170 171 0 255 255 255 255 255 255 255 255 160 41 82 163 0 255 255 255 +255 255 255 255 255 255 255 160 32 48 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 +")) + "Default image for the enabled scroll left button. +A disabled button image will be automatically build from it.") + +(defcustom tabbar-scroll-left-button + (cons (cons " <" tabbar-scroll-left-button-enabled-image) + (cons " =" nil)) + "The scroll left button. +The variable `tabbar-button-widget' gives details on this widget." + :group 'tabbar + :type tabbar-button-widget + :set '(lambda (variable value) + (custom-set-default variable value) + ;; Schedule refresh of button value. + (setq tabbar-scroll-left-button-value nil))) + +;;; Scroll right button +;; +(defvar tabbar-scroll-right-button-value nil + "Value of the scroll right button.") + +(defconst tabbar-scroll-right-button-enabled-image + '((:type pbm :data "\ +P2 13 13 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +48 32 160 255 255 255 255 255 255 255 255 255 255 44 161 71 32 160 255 +255 255 255 255 255 255 255 36 157 163 145 62 32 160 255 255 255 255 +255 255 30 128 133 137 142 124 50 32 160 255 255 255 255 29 120 121 +124 126 126 124 105 42 32 176 255 255 31 126 127 128 128 128 128 126 +124 89 32 255 255 33 134 135 136 137 137 138 119 49 32 176 255 255 34 +143 144 145 146 128 54 32 160 255 255 255 255 36 152 153 134 57 32 160 +255 255 255 255 255 255 38 141 60 32 160 255 255 255 255 255 255 255 +255 48 32 160 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 +")) + "Default image for the enabled scroll right button. +A disabled button image will be automatically build from it.") + +(defcustom tabbar-scroll-right-button + (cons (cons " >" tabbar-scroll-right-button-enabled-image) + (cons " =" nil)) + "The scroll right button. +The variable `tabbar-button-widget' gives details on this widget." + :group 'tabbar + :type tabbar-button-widget + :set '(lambda (variable value) + (custom-set-default variable value) + ;; Schedule refresh of button value. + (setq tabbar-scroll-right-button-value nil))) + +;;; Separator +;; +(defconst tabbar-separator-widget + '(cons (choice (string) + (number :tag "Space width" 0.2)) + (repeat :tag "Image" + :extra-offset 2 + (restricted-sexp :tag "Spec" + :match-alternatives (listp)))) + "Widget for editing a tab bar separator. +A separator is specified as a pair (STRING-OR-WIDTH . IMAGE) where +STRING-OR-WIDTH is a string value or a space width, and IMAGE a list +of image specifications. +If IMAGE is non-nil, try to use that image, else use STRING-OR-WIDTH. +The value (\"\"), or (0) hide separators.") + +(defvar tabbar-separator-value nil + "Value of the separator used between tabs.") + +(defcustom tabbar-separator (list 0.2) + "Separator used between tabs. +The variable `tabbar-separator-widget' gives details on this widget." + :group 'tabbar + :type tabbar-separator-widget + :set '(lambda (variable value) + (custom-set-default variable value) + ;; Schedule refresh of separator value. + (setq tabbar-separator-value nil))) + +;;; Images +;; +(defcustom tabbar-use-images t + "*Non-nil means to try to use images in tab bar. +That is for buttons and separators." + :group 'tabbar + :type 'boolean + :set '(lambda (variable value) + (custom-set-default variable value) + ;; Schedule refresh of all buttons and separator values. + (setq tabbar-separator-value nil + tabbar-home-button-value nil + tabbar-scroll-left-button-value nil + tabbar-scroll-right-button-value nil))) + +(defsubst tabbar-find-image (specs) + "Find an image, choosing one of a list of image specifications. +SPECS is a list of image specifications. See also `find-image'." + (when (and tabbar-use-images (display-images-p)) + (condition-case nil + (find-image specs) + (error nil)))) + +(defsubst tabbar-disable-image (image) + "From IMAGE, return a new image which looks disabled." + (setq image (copy-sequence image)) + (setcdr image (plist-put (cdr image) :conversion 'disabled)) + image) + +(defsubst tabbar-normalize-image (image &optional margin) + "Make IMAGE centered and transparent. +If optional MARGIN is non-nil, it must be a number of pixels to add as +an extra margin around the image." + (let ((plist (cdr image))) + (or (plist-get plist :ascent) + (setq plist (plist-put plist :ascent 'center))) + (or (plist-get plist :mask) + (setq plist (plist-put plist :mask '(heuristic t)))) + (or (not (natnump margin)) + (plist-get plist :margin) + (plist-put plist :margin margin)) + (setcdr image plist)) + image) + +;;; Button keymaps and callbacks +;; +(defun tabbar-make-mouse-keymap (callback) + "Return a keymap that call CALLBACK on mouse events. +CALLBACK is passed the received mouse event." + (let ((keymap (make-sparse-keymap))) + ;; Pass mouse-1, mouse-2 and mouse-3 events to CALLBACK. + (define-key keymap [header-line down-mouse-1] 'ignore) + (define-key keymap [header-line mouse-1] callback) + (define-key keymap [header-line down-mouse-2] 'ignore) + (define-key keymap [header-line mouse-2] callback) + (define-key keymap [header-line down-mouse-3] 'ignore) + (define-key keymap [header-line mouse-3] callback) + keymap)) + +(defsubst tabbar-make-mouse-event (&optional type) + "Return a mouse click event. +Optional argument TYPE is a mouse-click event or one of the +symbols `mouse-1', `mouse-2' or `mouse-3'. +The default is `mouse-1'." + (if (tabbar-click-p type) + type + (list (or (memq type '(mouse-2 mouse-3)) 'mouse-1) + (or (event-start nil) ;; Emacs 21.4 + (list (selected-window) (point) '(0 . 0) 0))))) + +;;; Buttons +;; +(defconst tabbar-default-button-keymap + (tabbar-make-mouse-keymap 'tabbar-select-button-callback) + "Default keymap of a button.") + +(defun tabbar-help-on-button (window object position) + "Return a help string or nil for none, for the button under the mouse. +WINDOW is the window in which the help was found (unused). +OBJECT is the button label under the mouse. +POSITION is the position in that label. +Call `tabbar-NAME-help-function' where NAME is the button name +associated to OBJECT." + (let* ((name (get-text-property position 'tabbar-button object)) + (funvar (and name + (intern-soft (format "tabbar-%s-help-function" + name))))) + (and (symbol-value funvar) + (funcall (symbol-value funvar))))) + +(defsubst tabbar-click-on-button (name &optional type) + "Handle a mouse click event on button NAME. +Call `tabbar-select-NAME-function' with the received, or simulated +mouse click event. +Optional argument TYPE is a mouse click event type (see the function +`tabbar-make-mouse-event' for details)." + (let ((funvar (intern-soft (format "tabbar-%s-function" name)))) + (when (symbol-value funvar) + (funcall (symbol-value funvar) (tabbar-make-mouse-event type)) + (tabbar-display-update)))) + +(defun tabbar-select-button-callback (event) + "Handle a mouse EVENT on a button. +Pass mouse click events on a button to `tabbar-click-on-button'." + (interactive "@e") + (when (tabbar-click-p event) + (let ((target (posn-string (event-start event)))) + (tabbar-click-on-button + (get-text-property (cdr target) 'tabbar-button (car target)) + event)))) + +(defun tabbar-make-button-keymap (name) + "Return a keymap to handle mouse click events on button NAME." + (if (fboundp 'posn-string) + tabbar-default-button-keymap + (let ((event (make-symbol "event"))) + (tabbar-make-mouse-keymap + `(lambda (,event) + (interactive "@e") + (and (tabbar-click-p ,event) + (tabbar-click-on-button ',name ,event))))))) + +;;; Button callbacks +;; +(defun tabbar-scroll-left (event) + "On mouse EVENT, scroll current tab set on left." + (when (eq (event-basic-type event) 'mouse-1) + (tabbar-scroll (tabbar-current-tabset) -1))) + +(defun tabbar-scroll-left-help () + "Help string shown when mouse is over the scroll left button." + "mouse-1: scroll tabs left.") + +(defun tabbar-scroll-right (event) + "On mouse EVENT, scroll current tab set on right." + (when (eq (event-basic-type event) 'mouse-1) + (tabbar-scroll (tabbar-current-tabset) 1))) + +(defun tabbar-scroll-right-help () + "Help string shown when mouse is over the scroll right button." + "mouse-1: scroll tabs right.") + +;;; Tabs +;; +(defconst tabbar-default-tab-keymap + (tabbar-make-mouse-keymap 'tabbar-select-tab-callback) + "Default keymap of a tab.") + +(defun tabbar-help-on-tab (window object position) + "Return a help string or nil for none, for the tab under the mouse. +WINDOW is the window in which the help was found (unused). +OBJECT is the tab label under the mouse. +POSITION is the position in that label. +Call `tabbar-help-on-tab-function' with the associated tab." + (when tabbar-help-on-tab-function + (let ((tab (get-text-property position 'tabbar-tab object))) + (funcall tabbar-help-on-tab-function tab)))) + +(defsubst tabbar-click-on-tab (tab &optional type) + "Handle a mouse click event on tab TAB. +Call `tabbar-select-tab-function' with the received, or simulated +mouse click event, and TAB. +Optional argument TYPE is a mouse click event type (see the function +`tabbar-make-mouse-event' for details)." + (when tabbar-select-tab-function + (funcall tabbar-select-tab-function + (tabbar-make-mouse-event type) tab) + (tabbar-display-update))) + +(defun tabbar-select-tab-callback (event) + "Handle a mouse EVENT on a tab. +Pass mouse click events on a tab to `tabbar-click-on-tab'." + (interactive "@e") + (when (tabbar-click-p event) + (let ((target (posn-string (event-start event)))) + (tabbar-click-on-tab + (get-text-property (cdr target) 'tabbar-tab (car target)) + event)))) + +(defun tabbar-make-tab-keymap (tab) + "Return a keymap to handle mouse click events on TAB." + (if (fboundp 'posn-string) + tabbar-default-tab-keymap + (let ((event (make-symbol "event"))) + (tabbar-make-mouse-keymap + `(lambda (,event) + (interactive "@e") + (and (tabbar-click-p ,event) + (tabbar-click-on-tab ',tab ,event))))))) + +;;; Tab bar construction +;; +(defun tabbar-button-label (name) + "Return a label for button NAME. +That is a pair (ENABLED . DISABLED), where ENABLED and DISABLED are +respectively the appearance of the button when enabled and disabled. +They are propertized strings which could display images, as specified +by the variable `tabbar-NAME-button'." + (let* ((btn (symbol-value + (intern-soft (format "tabbar-%s-button" name)))) + (on (tabbar-find-image (cdar btn))) + (off (and on (tabbar-find-image (cddr btn))))) + (when on + (tabbar-normalize-image on 1) + (if off + (tabbar-normalize-image off 1) + ;; If there is no disabled button image, derive one from the + ;; button enabled image. + (setq off (tabbar-disable-image on)))) + (cons + (propertize (or (caar btn) " ") 'display on) + (propertize (or (cadr btn) " ") 'display off)))) + +(defun tabbar-line-button (name) + "Return the display representation of button NAME. +That is, a propertized string used as an `header-line-format' template +element." + (let ((label (if tabbar-button-label-function + (funcall tabbar-button-label-function name) + (cons name name)))) + ;; Cache the display value of the enabled/disabled buttons in + ;; variables `tabbar-NAME-button-value'. + (set (intern (format "tabbar-%s-button-value" name)) + (cons + (propertize (car label) + 'tabbar-button name + 'face 'tabbar-button + 'mouse-face 'tabbar-button-highlight + 'pointer 'hand + 'local-map (tabbar-make-button-keymap name) + 'help-echo 'tabbar-help-on-button) + (propertize (cdr label) + 'face 'tabbar-button + 'pointer 'arrow))))) + +(defun tabbar-line-separator () + "Return the display representation of a tab bar separator. +That is, a propertized string used as an `header-line-format' template +element." + (let ((image (tabbar-find-image (cdr tabbar-separator)))) + ;; Cache the separator display value in variable + ;; `tabbar-separator-value'. + (setq tabbar-separator-value + (cond + (image + (propertize " " + 'face 'tabbar-separator + 'pointer 'arrow + 'display (tabbar-normalize-image image))) + ((numberp (car tabbar-separator)) + (propertize " " + 'face 'tabbar-separator + 'pointer 'arrow + 'display (list 'space + :width (car tabbar-separator)))) + ((propertize (or (car tabbar-separator) " ") + 'face 'tabbar-separator + 'pointer 'arrow)))) + )) + +(defsubst tabbar-line-buttons (tabset) + "Return a list of propertized strings for tab bar buttons. +TABSET is the tab set used to choose the appropriate buttons." + (list + (if tabbar-home-function + (car tabbar-home-button-value) + (cdr tabbar-home-button-value)) + (if (> (tabbar-start tabset) 0) + (car tabbar-scroll-left-button-value) + (cdr tabbar-scroll-left-button-value)) + (if (< (tabbar-start tabset) + (1- (length (tabbar-tabs tabset)))) + (car tabbar-scroll-right-button-value) + (cdr tabbar-scroll-right-button-value)) + tabbar-separator-value)) + +(defsubst tabbar-line-tab (tab) + "Return the display representation of tab TAB. +That is, a propertized string used as an `header-line-format' template +element. +Call `tabbar-tab-label-function' to obtain a label for TAB." + (concat (propertize + (if tabbar-tab-label-function + (funcall tabbar-tab-label-function tab) + tab) + 'tabbar-tab tab + 'local-map (tabbar-make-tab-keymap tab) + 'help-echo 'tabbar-help-on-tab + 'mouse-face 'tabbar-highlight + 'face (if (tabbar-selected-p tab (tabbar-current-tabset)) + 'tabbar-selected + 'tabbar-unselected) + 'pointer 'hand) + tabbar-separator-value)) + +(defun tabbar-line-format (tabset) + "Return the `header-line-format' value to display TABSET." + (let* ((sel (tabbar-selected-tab tabset)) + (tabs (tabbar-view tabset)) + (padcolor (tabbar-background-color)) + atsel elts) + ;; Initialize buttons and separator values. + (or tabbar-separator-value + (tabbar-line-separator)) + (or tabbar-home-button-value + (tabbar-line-button 'home)) + (or tabbar-scroll-left-button-value + (tabbar-line-button 'scroll-left)) + (or tabbar-scroll-right-button-value + (tabbar-line-button 'scroll-right)) + ;; Track the selected tab to ensure it is always visible. + (when tabbar--track-selected + (while (not (memq sel tabs)) + (tabbar-scroll tabset -1) + (setq tabs (tabbar-view tabset))) + (while (and tabs (not atsel)) + (setq elts (cons (tabbar-line-tab (car tabs)) elts) + atsel (eq (car tabs) sel) + tabs (cdr tabs))) + (setq elts (nreverse elts)) + ;; At this point the selected tab is the last elt in ELTS. + ;; Scroll TABSET and ELTS until the selected tab becomes + ;; visible. + (with-temp-buffer + (let ((truncate-partial-width-windows nil) + (inhibit-modification-hooks t) + deactivate-mark ;; Prevent deactivation of the mark! + start) + (setq truncate-lines nil + buffer-undo-list t) + (apply 'insert (tabbar-line-buttons tabset)) + (setq start (point)) + (while (and (cdr elts) ;; Always show the selected tab! + (progn + (delete-region start (point-max)) + (goto-char (point-max)) + (apply 'insert elts) + (goto-char (point-min)) + (> (vertical-motion 1) 0))) + (tabbar-scroll tabset 1) + (setq elts (cdr elts))))) + (setq elts (nreverse elts)) + (setq tabbar--track-selected nil)) + ;; Format remaining tabs. + (while tabs + (setq elts (cons (tabbar-line-tab (car tabs)) elts) + tabs (cdr tabs))) + ;; Cache and return the new tab bar. + (tabbar-set-template + tabset + (list (tabbar-line-buttons tabset) + (nreverse elts) + (propertize "%-" + 'face (list :background padcolor + :foreground padcolor) + 'pointer 'arrow))) + )) + +(defun tabbar-line () + "Return the header line templates that represent the tab bar. +Inhibit display of the tab bar in current window if any of the +`tabbar-inhibit-functions' return non-nil." + (cond + ((run-hook-with-args-until-success 'tabbar-inhibit-functions) + ;; Don't show the tab bar. + (setq header-line-format nil)) + ((tabbar-current-tabset t) + ;; When available, use a cached tab bar value, else recompute it. + (or (tabbar-template tabbar-current-tabset) + (tabbar-line-format tabbar-current-tabset))))) + +(defconst tabbar-header-line-format '(:eval (tabbar-line)) + "The tab bar header line format.") + +(defun tabbar-default-inhibit-function () + "Inhibit display of the tab bar in specified windows. +That is dedicated windows, and `checkdoc' status windows." + (or (window-dedicated-p (selected-window)) + (member (buffer-name) + (list " *Checkdoc Status*" + (if (boundp 'ispell-choices-buffer) + ispell-choices-buffer + "*Choices*"))))) + +;;; Cyclic navigation through tabs +;; +(defun tabbar-cycle (&optional backward type) + "Cycle to the next available tab. +The scope of the cyclic navigation through tabs is specified by the +option `tabbar-cycle-scope'. +If optional argument BACKWARD is non-nil, cycle to the previous tab +instead. +Optional argument TYPE is a mouse event type (see the function +`tabbar-make-mouse-event' for details)." + (let* ((tabset (tabbar-current-tabset t)) + (ttabset (tabbar-get-tabsets-tabset)) + ;; If navigation through groups is requested, and there is + ;; only one group, navigate through visible tabs. + (cycle (if (and (eq tabbar-cycle-scope 'groups) + (not (cdr (tabbar-tabs ttabset)))) + 'tabs + tabbar-cycle-scope)) + selected tab) + (when tabset + (setq selected (tabbar-selected-tab tabset)) + (cond + ;; Cycle through visible tabs only. + ((eq cycle 'tabs) + (setq tab (tabbar-tab-next tabset selected backward)) + ;; When there is no tab after/before the selected one, cycle + ;; to the first/last visible tab. + (unless tab + (setq tabset (tabbar-tabs tabset) + tab (car (if backward (last tabset) tabset)))) + ) + ;; Cycle through tab groups only. + ((eq cycle 'groups) + (setq tab (tabbar-tab-next ttabset selected backward)) + ;; When there is no group after/before the selected one, cycle + ;; to the first/last available group. + (unless tab + (setq tabset (tabbar-tabs ttabset) + tab (car (if backward (last tabset) tabset)))) + ) + (t + ;; Cycle through visible tabs then tab groups. + (setq tab (tabbar-tab-next tabset selected backward)) + ;; When there is no visible tab after/before the selected one, + ;; cycle to the next/previous available group. + (unless tab + (setq tab (tabbar-tab-next ttabset selected backward)) + ;; When there is no next/previous group, cycle to the + ;; first/last available group. + (unless tab + (setq tabset (tabbar-tabs ttabset) + tab (car (if backward (last tabset) tabset)))) + ;; Select the first/last visible tab of the new group. + (setq tabset (tabbar-tabs (tabbar-tab-tabset tab)) + tab (car (if backward (last tabset) tabset)))) + )) + (tabbar-click-on-tab tab type)))) + +;;;###autoload +(defun tabbar-backward () + "Select the previous available tab. +Depend on the setting of the option `tabbar-cycle-scope'." + (interactive) + (tabbar-cycle t)) + +;;;###autoload +(defun tabbar-forward () + "Select the next available tab. +Depend on the setting of the option `tabbar-cycle-scope'." + (interactive) + (tabbar-cycle)) + +;;;###autoload +(defun tabbar-backward-group () + "Go to selected tab in the previous available group." + (interactive) + (let ((tabbar-cycle-scope 'groups)) + (tabbar-cycle t))) + +;;;###autoload +(defun tabbar-forward-group () + "Go to selected tab in the next available group." + (interactive) + (let ((tabbar-cycle-scope 'groups)) + (tabbar-cycle))) + +;;;###autoload +(defun tabbar-backward-tab () + "Select the previous visible tab." + (interactive) + (let ((tabbar-cycle-scope 'tabs)) + (tabbar-cycle t))) + +;;;###autoload +(defun tabbar-forward-tab () + "Select the next visible tab." + (interactive) + (let ((tabbar-cycle-scope 'tabs)) + (tabbar-cycle))) + +;;; Button press commands +;; +(defsubst tabbar--mouse (number) + "Return a mouse button symbol from NUMBER. +That is mouse-2, or mouse-3 when NUMBER is respectively 2, or 3. +Return mouse-1 otherwise." + (cond ((eq number 2) 'mouse-2) + ((eq number 3) 'mouse-3) + ('mouse-1))) + +;;;###autoload +(defun tabbar-press-home (&optional arg) + "Press the tab bar home button. +That is, simulate a mouse click on that button. +A numeric prefix ARG value of 2, or 3, respectively simulates a +mouse-2, or mouse-3 click. The default is a mouse-1 click." + (interactive "p") + (tabbar-click-on-button 'home (tabbar--mouse arg))) + +;;;###autoload +(defun tabbar-press-scroll-left (&optional arg) + "Press the tab bar scroll-left button. +That is, simulate a mouse click on that button. +A numeric prefix ARG value of 2, or 3, respectively simulates a +mouse-2, or mouse-3 click. The default is a mouse-1 click." + (interactive "p") + (tabbar-click-on-button 'scroll-left (tabbar--mouse arg))) + +;;;###autoload +(defun tabbar-press-scroll-right (&optional arg) + "Press the tab bar scroll-right button. +That is, simulate a mouse click on that button. +A numeric prefix ARG value of 2, or 3, respectively simulates a +mouse-2, or mouse-3 click. The default is a mouse-1 click." + (interactive "p") + (tabbar-click-on-button 'scroll-right (tabbar--mouse arg))) + +;;; Mouse-wheel support +;; +(require 'mwheel) + +;;; Compatibility +;; +(defconst tabbar--mwheel-up-event + (symbol-value (if (boundp 'mouse-wheel-up-event) + 'mouse-wheel-up-event + 'mouse-wheel-up-button))) + +(defconst tabbar--mwheel-down-event + (symbol-value (if (boundp 'mouse-wheel-down-event) + 'mouse-wheel-down-event + 'mouse-wheel-down-button))) + +(defsubst tabbar--mwheel-key (event-type) + "Return a mouse wheel key symbol from EVENT-TYPE. +When EVENT-TYPE is a symbol return it. +When it is a button number, return symbol `mouse-<EVENT-TYPE>'." + (if (symbolp event-type) + event-type + (intern (format "mouse-%s" event-type)))) + +(defsubst tabbar--mwheel-up-p (event) + "Return non-nil if EVENT is a mouse-wheel up event." + (let ((x (event-basic-type event))) + (if (eq 'mouse-wheel x) + (< (car (cdr (cdr event))) 0) ;; Emacs 21.3 + ;; Emacs > 21.3 + (eq x tabbar--mwheel-up-event)))) + +;;; Basic commands +;; +;;;###autoload +(defun tabbar-mwheel-backward (event) + "Select the previous available tab. +EVENT is the mouse event that triggered this command. +Mouse-enabled equivalent of the command `tabbar-backward'." + (interactive "@e") + (tabbar-cycle t event)) + +;;;###autoload +(defun tabbar-mwheel-forward (event) + "Select the next available tab. +EVENT is the mouse event that triggered this command. +Mouse-enabled equivalent of the command `tabbar-forward'." + (interactive "@e") + (tabbar-cycle nil event)) + +;;;###autoload +(defun tabbar-mwheel-backward-group (event) + "Go to selected tab in the previous available group. +If there is only one group, select the previous visible tab. +EVENT is the mouse event that triggered this command. +Mouse-enabled equivalent of the command `tabbar-backward-group'." + (interactive "@e") + (let ((tabbar-cycle-scope 'groups)) + (tabbar-cycle t event))) + +;;;###autoload +(defun tabbar-mwheel-forward-group (event) + "Go to selected tab in the next available group. +If there is only one group, select the next visible tab. +EVENT is the mouse event that triggered this command. +Mouse-enabled equivalent of the command `tabbar-forward-group'." + (interactive "@e") + (let ((tabbar-cycle-scope 'groups)) + (tabbar-cycle nil event))) + +;;;###autoload +(defun tabbar-mwheel-backward-tab (event) + "Select the previous visible tab. +EVENT is the mouse event that triggered this command. +Mouse-enabled equivalent of the command `tabbar-backward-tab'." + (interactive "@e") + (let ((tabbar-cycle-scope 'tabs)) + (tabbar-cycle t event))) + +;;;###autoload +(defun tabbar-mwheel-forward-tab (event) + "Select the next visible tab. +EVENT is the mouse event that triggered this command. +Mouse-enabled equivalent of the command `tabbar-forward-tab'." + (interactive "@e") + (let ((tabbar-cycle-scope 'tabs)) + (tabbar-cycle nil event))) + +;;; Wrappers when there is only one generic mouse-wheel event +;; +;;;###autoload +(defun tabbar-mwheel-switch-tab (event) + "Select the next or previous tab according to EVENT." + (interactive "@e") + (if (tabbar--mwheel-up-p event) + (tabbar-mwheel-forward-tab event) + (tabbar-mwheel-backward-tab event))) + +;;;###autoload +(defun tabbar-mwheel-switch-group (event) + "Select the next or previous group of tabs according to EVENT." + (interactive "@e") + (if (tabbar--mwheel-up-p event) + (tabbar-mwheel-forward-group event) + (tabbar-mwheel-backward-group event))) + +;;; Minor modes +;; +(defsubst tabbar-mode-on-p () + "Return non-nil if Tabbar mode is on." + (eq (default-value 'header-line-format) + tabbar-header-line-format)) + +;;; Tabbar-Local mode +;; +(defvar tabbar--local-hlf nil) + +;;;###autoload +(define-minor-mode tabbar-local-mode + "Toggle local display of the tab bar. +With prefix argument ARG, turn on if positive, otherwise off. +Returns non-nil if the new state is enabled. +When turned on, if a local header line is shown, it is hidden to show +the tab bar. The tab bar is locally hidden otherwise. When turned +off, if a local header line is hidden or the tab bar is locally +hidden, it is shown again. Signal an error if Tabbar mode is off." + :group 'tabbar + :global nil + (unless (tabbar-mode-on-p) + (error "Tabbar mode must be enabled")) +;;; ON + (if tabbar-local-mode + (if (and (local-variable-p 'header-line-format) + header-line-format) + ;; A local header line exists, hide it to show the tab bar. + (progn + ;; Fail in case of an inconsistency because another local + ;; header line is already hidden. + (when (local-variable-p 'tabbar--local-hlf) + (error "Another local header line is already hidden")) + (set (make-local-variable 'tabbar--local-hlf) + header-line-format) + (kill-local-variable 'header-line-format)) + ;; Otherwise hide the tab bar in this buffer. + (setq header-line-format nil)) +;;; OFF + (if (local-variable-p 'tabbar--local-hlf) + ;; A local header line is hidden, show it again. + (progn + (setq header-line-format tabbar--local-hlf) + (kill-local-variable 'tabbar--local-hlf)) + ;; The tab bar is locally hidden, show it again. + (kill-local-variable 'header-line-format)))) + +;;; Tabbar mode +;; +(defvar tabbar-prefix-key [(control ?c)] + "The common prefix key used in Tabbar mode.") + +(defvar tabbar-prefix-map + (let ((km (make-sparse-keymap))) + (define-key km [(control home)] 'tabbar-press-home) + (define-key km [(control left)] 'tabbar-backward) + (define-key km [(control right)] 'tabbar-forward) + (define-key km [(control up)] 'tabbar-backward-group) + (define-key km [(control down)] 'tabbar-forward-group) + (define-key km [(control prior)] 'tabbar-press-scroll-left) + (define-key km [(control next)] 'tabbar-press-scroll-right) + (define-key km [(control f10)] 'tabbar-local-mode) + km) + "The key bindings provided in Tabbar mode.") + +(defvar tabbar-mode-map + (let ((km (make-sparse-keymap))) + (define-key km tabbar-prefix-key tabbar-prefix-map) + km) + "Keymap to use in Tabbar mode.") + +(defvar tabbar--global-hlf nil) + +;;;###autoload +(define-minor-mode tabbar-mode + "Toggle display of a tab bar in the header line. +With prefix argument ARG, turn on if positive, otherwise off. +Returns non-nil if the new state is enabled. + +\\{tabbar-mode-map}" + :group 'tabbar + :require 'tabbar + :global t + :keymap tabbar-mode-map + (if tabbar-mode +;;; ON + (unless (tabbar-mode-on-p) + ;; Save current default value of `header-line-format'. + (setq tabbar--global-hlf (default-value 'header-line-format)) + (tabbar-init-tabsets-store) + (setq-default header-line-format tabbar-header-line-format)) +;;; OFF + (when (tabbar-mode-on-p) + ;; Turn off Tabbar-Local mode globally. + (mapc #'(lambda (b) + (condition-case nil + (with-current-buffer b + (and tabbar-local-mode + (tabbar-local-mode -1))) + (error nil))) + (buffer-list)) + ;; Restore previous `header-line-format'. + (setq-default header-line-format tabbar--global-hlf) + (tabbar-free-tabsets-store)) + )) + +;;; Tabbar-Mwheel mode +;; +(defvar tabbar-mwheel-mode-map + (let ((km (make-sparse-keymap))) + (if (get 'mouse-wheel 'event-symbol-elements) + ;; Use one generic mouse wheel event + (define-key km [A-mouse-wheel] + 'tabbar-mwheel-switch-group) + ;; Use separate up/down mouse wheel events + (let ((up (tabbar--mwheel-key tabbar--mwheel-up-event)) + (down (tabbar--mwheel-key tabbar--mwheel-down-event))) + (define-key km `[header-line ,down] + 'tabbar-mwheel-backward-group) + (define-key km `[header-line ,up] + 'tabbar-mwheel-forward-group) + (define-key km `[header-line (control ,down)] + 'tabbar-mwheel-backward-tab) + (define-key km `[header-line (control ,up)] + 'tabbar-mwheel-forward-tab) + (define-key km `[header-line (shift ,down)] + 'tabbar-mwheel-backward) + (define-key km `[header-line (shift ,up)] + 'tabbar-mwheel-forward) + )) + km) + "Keymap to use in Tabbar-Mwheel mode.") + +;;;###autoload +(define-minor-mode tabbar-mwheel-mode + "Toggle use of the mouse wheel to navigate through tabs or groups. +With prefix argument ARG, turn on if positive, otherwise off. +Returns non-nil if the new state is enabled. + +\\{tabbar-mwheel-mode-map}" + :group 'tabbar + :require 'tabbar + :global t + :keymap tabbar-mwheel-mode-map + (when tabbar-mwheel-mode + (unless (and mouse-wheel-mode tabbar-mode) + (tabbar-mwheel-mode -1)))) + +(defun tabbar-mwheel-follow () + "Toggle Tabbar-Mwheel following Tabbar and Mouse-Wheel modes." + (tabbar-mwheel-mode (if (and mouse-wheel-mode tabbar-mode) 1 -1))) + +(add-hook 'tabbar-mode-hook 'tabbar-mwheel-follow) +(add-hook 'mouse-wheel-mode-hook 'tabbar-mwheel-follow) + +;;; Buffer tabs +;; +(defgroup tabbar-buffer nil + "Display buffers in the tab bar." + :group 'tabbar) + +(defcustom tabbar-buffer-home-button + (cons (cons "[+]" tabbar-home-button-enabled-image) + (cons "[-]" tabbar-home-button-disabled-image)) + "The home button displayed when showing buffer tabs. +The enabled button value is displayed when showing tabs for groups of +buffers, and the disabled button value is displayed when showing +buffer tabs. +The variable `tabbar-button-widget' gives details on this widget." + :group 'tabbar-buffer + :type tabbar-button-widget + :set '(lambda (variable value) + (custom-set-default variable value) + ;; Schedule refresh of button value. + (setq tabbar-home-button-value nil))) + +(defvar tabbar-buffer-list-function 'tabbar-buffer-list + "Function that returns the list of buffers to show in tabs. +That function is called with no arguments and must return a list of +buffers.") + +(defvar tabbar-buffer-groups-function 'tabbar-buffer-groups + "Function that gives the group names the current buffer belongs to. +It must return a list of group names, or nil if the buffer has no +group. Notice that it is better that a buffer belongs to one group.") + +(defun tabbar-buffer-list () + "Return the list of buffers to show in tabs. +Exclude buffers whose name starts with a space, when they are not +visiting a file. The current buffer is always included." + (delq nil + (mapcar #'(lambda (b) + (cond + ;; Always include the current buffer. + ((eq (current-buffer) b) b) + ((buffer-file-name b) b) + ((char-equal ?\ (aref (buffer-name b) 0)) nil) + ((buffer-live-p b) b))) + (buffer-list)))) + +(defun tabbar-buffer-mode-derived-p (mode parents) + "Return non-nil if MODE derives from a mode in PARENTS." + (let (derived) + (while (and (not derived) mode) + (if (memq mode parents) + (setq derived t) + (setq mode (get mode 'derived-mode-parent)))) + derived)) + +(defun tabbar-buffer-groups () + "Return the list of group names the current buffer belongs to. +Return a list of one element based on major mode." + (list + (cond + ((or (get-buffer-process (current-buffer)) + ;; Check if the major mode derives from `comint-mode' or + ;; `compilation-mode'. + (tabbar-buffer-mode-derived-p + major-mode '(comint-mode compilation-mode))) + "Process" + ) + ((member (buffer-name) + '("*scratch*" "*Messages*")) + "Common" + ) + ((eq major-mode 'dired-mode) + "Dired" + ) + ((memq major-mode + '(help-mode apropos-mode Info-mode Man-mode)) + "Help" + ) + ((memq major-mode + '(rmail-mode + rmail-edit-mode vm-summary-mode vm-mode mail-mode + mh-letter-mode mh-show-mode mh-folder-mode + gnus-summary-mode message-mode gnus-group-mode + gnus-article-mode score-mode gnus-browse-killed-mode)) + "Mail" + ) + (t + ;; Return `mode-name' if not blank, `major-mode' otherwise. + (if (and (stringp mode-name) + ;; Take care of preserving the match-data because this + ;; function is called when updating the header line. + (save-match-data (string-match "[^ ]" mode-name))) + mode-name + (symbol-name major-mode)) + )))) + +;;; Group buffers in tab sets. +;; +(defvar tabbar--buffers nil) + +(defun tabbar-buffer-update-groups () + "Update tab sets from groups of existing buffers. +Return the the first group where the current buffer is." + (let ((bl (sort + (mapcar + #'(lambda (b) + (with-current-buffer b + (list (current-buffer) + (buffer-name) + (if tabbar-buffer-groups-function + (funcall tabbar-buffer-groups-function) + '("Common"))))) + (and tabbar-buffer-list-function + (funcall tabbar-buffer-list-function))) + #'(lambda (e1 e2) + (string-lessp (nth 1 e1) (nth 1 e2)))))) + ;; If the cache has changed, update the tab sets. + (unless (equal bl tabbar--buffers) + ;; Add new buffers, or update changed ones. + (dolist (e bl) + (dolist (g (nth 2 e)) + (let ((tabset (tabbar-get-tabset g))) + (if tabset + (unless (equal e (assq (car e) tabbar--buffers)) + ;; This is a new buffer, or a previously existing + ;; buffer that has been renamed, or moved to another + ;; group. Update the tab set, and the display. + (tabbar-add-tab tabset (car e) t) + (tabbar-set-template tabset nil)) + (tabbar-make-tabset g (car e)))))) + ;; Remove tabs for buffers not found in cache or moved to other + ;; groups, and remove empty tabsets. + (mapc 'tabbar-delete-tabset + (tabbar-map-tabsets + #'(lambda (tabset) + (dolist (tab (tabbar-tabs tabset)) + (let ((e (assq (tabbar-tab-value tab) bl))) + (or (and e (memq tabset + (mapcar 'tabbar-get-tabset + (nth 2 e)))) + (tabbar-delete-tab tab)))) + ;; Return empty tab sets + (unless (tabbar-tabs tabset) + tabset)))) + ;; The new cache becomes the current one. + (setq tabbar--buffers bl))) + ;; Return the first group the current buffer belongs to. + (car (nth 2 (assq (current-buffer) tabbar--buffers)))) + +;;; Tab bar callbacks +;; +(defvar tabbar--buffer-show-groups nil) + +(defsubst tabbar-buffer-show-groups (flag) + "Set display of tabs for groups of buffers to FLAG." + (setq tabbar--buffer-show-groups flag + ;; Redisplay the home button. + tabbar-home-button-value nil)) + +(defun tabbar-buffer-tabs () + "Return the buffers to display on the tab bar, in a tab set." + (let ((tabset (tabbar-get-tabset (tabbar-buffer-update-groups)))) + (tabbar-select-tab-value (current-buffer) tabset) + (when tabbar--buffer-show-groups + (setq tabset (tabbar-get-tabsets-tabset)) + (tabbar-select-tab-value (current-buffer) tabset)) + tabset)) + +(defun tabbar-buffer-button-label (name) + "Return a label for button NAME. +That is a pair (ENABLED . DISABLED), where ENABLED and DISABLED are +respectively the appearance of the button when enabled and disabled. +They are propertized strings which could display images, as specified +by the variable `tabbar-button-label'. +When NAME is 'home, return a different ENABLED button if showing tabs +or groups. Call the function `tabbar-button-label' otherwise." + (let ((lab (tabbar-button-label name))) + (when (eq name 'home) + (let* ((btn tabbar-buffer-home-button) + (on (tabbar-find-image (cdar btn))) + (off (tabbar-find-image (cddr btn)))) + ;; When `tabbar-buffer-home-button' does not provide a value, + ;; default to the enabled value of `tabbar-home-button'. + (if on + (tabbar-normalize-image on 1) + (setq on (get-text-property 0 'display (car lab)))) + (if off + (tabbar-normalize-image off 1) + (setq off (get-text-property 0 'display (car lab)))) + (setcar lab + (if tabbar--buffer-show-groups + (propertize (or (caar btn) (car lab)) 'display on) + (propertize (or (cadr btn) (car lab)) 'display off))) + )) + lab)) + +(defun tabbar-buffer-tab-label (tab) + "Return a label for TAB. +That is, a string used to represent it on the tab bar." + (let ((label (if tabbar--buffer-show-groups + (format "[%s]" (tabbar-tab-tabset tab)) + (format "%s" (tabbar-tab-value tab))))) + ;; Unless the tab bar auto scrolls to keep the selected tab + ;; visible, shorten the tab label to keep as many tabs as possible + ;; in the visible area of the tab bar. + (if tabbar-auto-scroll-flag + label + (tabbar-shorten + label (max 1 (/ (window-width) + (length (tabbar-view + (tabbar-current-tabset))))))))) + +(defun tabbar-buffer-help-on-tab (tab) + "Return the help string shown when mouse is onto TAB." + (if tabbar--buffer-show-groups + (let* ((tabset (tabbar-tab-tabset tab)) + (tab (tabbar-selected-tab tabset))) + (format "mouse-1: switch to buffer %S in group [%s]" + (buffer-name (tabbar-tab-value tab)) tabset)) + (format "mouse-1: switch to buffer %S\n\ +mouse-2: pop to buffer, mouse-3: delete other windows" + (buffer-name (tabbar-tab-value tab))) + )) + +(defun tabbar-buffer-select-tab (event tab) + "On mouse EVENT, select TAB." + (let ((mouse-button (event-basic-type event)) + (buffer (tabbar-tab-value tab))) + (cond + ((eq mouse-button 'mouse-2) + (pop-to-buffer buffer t)) + ((eq mouse-button 'mouse-3) + (delete-other-windows)) + (t + (switch-to-buffer buffer))) + ;; Don't show groups. + (tabbar-buffer-show-groups nil) + )) + +(defun tabbar-buffer-click-on-home (event) + "Handle a mouse click EVENT on the tab bar home button. +mouse-1, toggle the display of tabs for groups of buffers. +mouse-3, close the current buffer." + (let ((mouse-button (event-basic-type event))) + (cond + ((eq mouse-button 'mouse-1) + (tabbar-buffer-show-groups (not tabbar--buffer-show-groups))) + ((eq mouse-button 'mouse-3) + (kill-buffer nil)) + ))) + +(defun tabbar-buffer-help-on-home () + "Return the help string shown when mouse is onto the toggle button." + (concat + (if tabbar--buffer-show-groups + "mouse-1: show buffers in selected group" + "mouse-1: show groups of buffers") + ", mouse-3: close current buffer")) + +(defun tabbar-buffer-track-killed () + "Hook run just before actually killing a buffer. +In Tabbar mode, try to switch to a buffer in the current tab bar, +after the current buffer has been killed. Try first the buffer in tab +after the current one, then the buffer in tab before. On success, put +the sibling buffer in front of the buffer list, so it will be selected +first." + (and (eq header-line-format tabbar-header-line-format) + (eq tabbar-current-tabset-function 'tabbar-buffer-tabs) + (eq (current-buffer) (window-buffer (selected-window))) + (let ((bl (tabbar-tab-values (tabbar-current-tabset))) + (b (current-buffer)) + found sibling) + (while (and bl (not found)) + (if (eq b (car bl)) + (setq found t) + (setq sibling (car bl))) + (setq bl (cdr bl))) + (when (and (setq sibling (or (car bl) sibling)) + (buffer-live-p sibling)) + ;; Move sibling buffer in front of the buffer list. + (save-current-buffer + (switch-to-buffer sibling)))))) + +;;; Tab bar buffer setup +;; +(defun tabbar-buffer-init () + "Initialize tab bar buffer data. +Run as `tabbar-init-hook'." + (setq tabbar--buffers nil + tabbar--buffer-show-groups nil + tabbar-current-tabset-function 'tabbar-buffer-tabs + tabbar-tab-label-function 'tabbar-buffer-tab-label + tabbar-select-tab-function 'tabbar-buffer-select-tab + tabbar-help-on-tab-function 'tabbar-buffer-help-on-tab + tabbar-button-label-function 'tabbar-buffer-button-label + tabbar-home-function 'tabbar-buffer-click-on-home + tabbar-home-help-function 'tabbar-buffer-help-on-home + ) + (add-hook 'kill-buffer-hook 'tabbar-buffer-track-killed)) + +(defun tabbar-buffer-quit () + "Quit tab bar buffer. +Run as `tabbar-quit-hook'." + (setq tabbar--buffers nil + tabbar--buffer-show-groups nil + tabbar-current-tabset-function nil + tabbar-tab-label-function nil + tabbar-select-tab-function nil + tabbar-help-on-tab-function nil + tabbar-button-label-function nil + tabbar-home-function nil + tabbar-home-help-function nil + ) + (remove-hook 'kill-buffer-hook 'tabbar-buffer-track-killed)) + +(add-hook 'tabbar-init-hook 'tabbar-buffer-init) +(add-hook 'tabbar-quit-hook 'tabbar-buffer-quit) + +(provide 'tabbar) + +(run-hooks 'tabbar-load-hook) + +;;; tabbar.el ends here |