Attachment 'tabbar.el'

Download

   1 ;;; tabbar.el --- Display a tab bar in the header line
   2 
   3 ;; Copyright (C) 2003 David Ponce
   4 
   5 ;; Author: David Ponce <david@dponce.com>
   6 ;; Maintainer: David Ponce <david@dponce.com>
   7 ;; Created: 25 February 2003
   8 ;; Keywords: convenience
   9 ;; Revision: $Id: tabbar.el,v 1.20 2003/06/05 08:15:49 ponced Exp $
  10 
  11 (defconst tabbar-version "1.3")
  12 
  13 ;; This file is not part of GNU Emacs.
  14 
  15 ;; This program is free software; you can redistribute it and/or
  16 ;; modify it under the terms of the GNU General Public License as
  17 ;; published by the Free Software Foundation; either version 2, or (at
  18 ;; your option) any later version.
  19 
  20 ;; This program is distributed in the hope that it will be useful, but
  21 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  23 ;; General Public License for more details.
  24 
  25 ;; You should have received a copy of the GNU General Public License
  26 ;; along with this program; see the file COPYING.  If not, write to
  27 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  28 ;; Boston, MA 02111-1307, USA.
  29 
  30 ;;; Commentary:
  31 ;;
  32 ;; This library provides a minor mode to display tabs in the header
  33 ;; line.  It works only on GNU Emacs 21.
  34 ;;
  35 ;; M-x `tabbar-mode' toggle the display of the tab bar, globally.
  36 ;;
  37 ;; M-x `tabbar-local-mode' toggle the display of the tab bar, locally
  38 ;; in the current buffer, when the global mode in on.  This mode
  39 ;; permit to see the tab bar in a buffer where the header line is
  40 ;; already used by another mode (like `info' buffers).  That command
  41 ;; is particularly useful when it is given a keyboard shortcut, like
  42 ;; this:
  43 ;;
  44 ;;   (global-set-key [(control f10)] 'tabbar-local-mode)
  45 ;;
  46 ;; It is possible to navigate through tabs using commands (that is,
  47 ;; using the keyboard).  The main commands to cycle through tabs are:
  48 ;;
  49 ;; - `tabbar-forward' select the next available tab.
  50 ;; - `tabbar-backward' select the previous available tab.
  51 ;;
  52 ;; It is worth defining keys for them.  For example:
  53 ;;
  54 ;;   (global-set-key [(control shift tab)] 'tabbar-backward)
  55 ;;   (global-set-key [(control tab)]       'tabbar-forward)
  56 ;;
  57 ;; The default cycle is to first try to select the tab just
  58 ;; after/before the selected tab.  If this is the last/first tab, then
  59 ;; the first/last tab of the next/previous group of tabs is selected.
  60 ;; That behavior is controlled by the `tabbar-cycling-scope' option.
  61 ;;
  62 ;; The following specialized commands can be useful too:
  63 ;;
  64 ;; - `tabbar-forward-tab'/`tabbar-backward-tab'
  65 ;;      Navigate through visible tabs only.
  66 ;;
  67 ;; - `tabbar-forward-group'/`tabbar-backward-group'
  68 ;;      Navigate through tab groups only.
  69 ;;
  70 ;; Core
  71 ;; ----
  72 ;;
  73 ;; The content of the tab bar is represented by an internal data
  74 ;; structure: a tab set.  A tab set is a collection of tabs,
  75 ;; identified by an unique name.  In a tab set, at any time, one and
  76 ;; only one tab is designated as selected within the tab set.
  77 ;;
  78 ;; A tab is a simple data structure giving: the value of the tab, and
  79 ;; a reference to its tab set container.  A tab value can be any Lisp
  80 ;; object, even if the most common value is probably a string.  Each
  81 ;; tab object is guaranteed to be unique.
  82 ;;
  83 ;; A tab set is displayed on the tab bar through a "view" defined by
  84 ;; the index of the leftmost tab shown.  Thus, it is possible to
  85 ;; scroll the tab bar horizontally, by changing the start index of the
  86 ;; tab set view.
  87 ;;
  88 ;; The visual representation of a tab set is a list a
  89 ;; `header-line-format' template elements.  Each template element is
  90 ;; the visual representation of a tab.  When the visual representation
  91 ;; of a tab is required, the function specified in the variable
  92 ;; `tabbar-tab-label-function' is called to obtain a label (a text
  93 ;; representation) for that tab.  Also, the function specified in the
  94 ;; variable `tabbar-help-on-tab-function' is called when the mouse is
  95 ;; on a tab.  That function is passed the tab and can return a help
  96 ;; string to display.  Finally, when a tab is selected by clicking on
  97 ;; it, the function specified in the variable
  98 ;; `tabbar-select-tab-function' is called with the mouse event
  99 ;; received, and the tab.
 100 ;;
 101 ;; To increase performance, the tab set automatically maintains its
 102 ;; visual representation in a cache.  As far as possible, that cache
 103 ;; is used to display the tab set, and refreshed only when necessary.
 104 ;;
 105 ;; Several tab sets can be maintained at the same time.  Only one is
 106 ;; displayed on the tab bar, it is obtained by calling the function
 107 ;; specified in the variable `tabbar-current-tabset-function'.
 108 ;;
 109 ;; A special tab set is maintained, that contains the list of
 110 ;; currently selected tabs, in existing tab sets.  For example, a such
 111 ;; tab set can be used to display a tab bar with a tab for each
 112 ;; created tab set, allowing to switch to another tab set by clicking
 113 ;; on the corresponding tab.
 114 ;;
 115 ;; Three buttons are displayed to the left, on the tab bar: the "home"
 116 ;; button, the "scroll left" and the "scroll right" buttons.  The
 117 ;; "home" button is a general purpose button used to change something
 118 ;; on the tab bar.  The scroll left and scroll right buttons are used
 119 ;; to scroll tabs horizontally.  The following variables are
 120 ;; available, for respectively the `home', `scroll-left' and
 121 ;; `scroll-right' value of `<button>':
 122 ;;
 123 ;; `tabbar-<button>-function'
 124 ;;    Specify a function called when clicking on the button.  The
 125 ;;    function is passed the mouse event received.
 126 ;;
 127 ;; `tabbar-<button>-help-function'
 128 ;;    Specify a function to obtain a help string displayed when the
 129 ;;    mouse is onto the button.  The function is called with no
 130 ;;    arguments.
 131 ;;
 132 ;; The appearance of tabs and buttons is also customizable (see the
 133 ;; code for more details).
 134 ;;
 135 ;; Buffer tabs
 136 ;; -----------
 137 ;;
 138 ;; The default tab bar implementation provided, displays buffers in
 139 ;; dedicated tabs.  Selecting a tab, switch (mouse-1), or pop
 140 ;; (mouse-2), to the buffer it contains.
 141 ;;
 142 ;; The list of buffers put in tabs is provided by the function
 143 ;; specified in the variable `tabbar-buffer-list-function'.  The
 144 ;; default function: `tabbar-buffer-list', excludes buffers whose name
 145 ;; starts with a space, when they are not visiting a file.
 146 ;;
 147 ;; Buffers are organized in groups, each one represented by a tab set.
 148 ;; A buffer can have no group, or belong to more than one group.  The
 149 ;; function specified by the variable `tabbar-buffer-groups-function'
 150 ;; is called for each buffer to obtain its groups.  The default
 151 ;; function provided: `tabbar-buffer-groups' organizes buffers
 152 ;; depending on their major mode (see that function for details).
 153 ;;
 154 ;; The "home" button toggles display of buffer groups on the tab bar,
 155 ;; allowing to easily choose another buffer group by clicking on its
 156 ;; tab.
 157 ;;
 158 ;; The scroll buttons permit to scroll tabs when some of them are
 159 ;; outside the tab bar visible area.
 160 
 161 ;;; History:
 162 ;;
 163 
 164 ;;; Code:
 165 (eval-when-compile
 166   (require 'cl))
 167 
 168 ;;; Options
 169 ;;
 170 (defgroup tabbar nil
 171   "Display a tab bar in the header line."
 172   :group 'convenience)
 173 
 174 (defcustom tabbar-cycling-scope nil
 175   "*Specify the scope of cyclic navigation through tabs.
 176 The following scopes are possible:
 177 
 178 - `tabs'
 179     Navigate through visible tabs only.
 180 - `groups'
 181     Navigate through tab groups only.
 182 - default
 183     Navigate through visible tabs, then through tab groups."
 184   :group 'tabbar
 185   :type '(choice :tag "Cycle through..."
 186                  (const :tag "Visible Tabs Only" tabs)
 187                  (const :tag "Tab Groups Only" groups)
 188                  (const :tag "Visible Tabs then Tab Groups" nil)))
 189 
 190 (defcustom tabbar-speedkey-use nil
 191   "If set to t, show a speedkey (1~0) before tab, and switch
 192 quickly using tabbar-speedkey-prefix + coresponding sppedkey."
 193   :group 'tabbar
 194   :type 'boolean)
 195 
 196 (defcustom tabbar-speedkey-prefix (kbd "<f1>")
 197   "Prefix key for speedkey commands."
 198   :group 'tabbar
 199   :type 'string)
 200 
 201 (defvar tabbar-speedkey-map nil
 202   "Keymap for tabbar-speedkey commands.")
 203 
 204 (defcustom tabbar-inhibit-functions
 205   '(tabbar-default-inhibit-function)
 206   "List of functions to be called before displaying the tab bar.
 207 Those functions are called one by one, with no arguments, until one of
 208 them returns a non-nil value, and thus, prevent to display the tab
 209 bar."
 210   :group 'tabbar
 211   :type 'hook)
 212 
 213 (defcustom tabbar-current-tabset-function
 214   'tabbar-buffer-tabs
 215   "Function called with no argument to obtain the current tab set.
 216 This is the tab set displayed on the tab bar."
 217   :group 'tabbar
 218   :type 'function)
 219 
 220 (defcustom tabbar-tab-label-function
 221   'tabbar-buffer-tab-label
 222   "Function that obtains a tab label displayed on the tab bar.
 223 The function is passed a tab and should return a string."
 224   :group 'tabbar
 225   :type 'function)
 226 
 227 (defcustom tabbar-select-tab-function
 228   'tabbar-buffer-select-tab
 229   "Function that select a tab.
 230 The function is passed a mouse event and a tab, and should make it the
 231 selected tab."
 232   :group 'tabbar
 233   :type 'function)
 234 
 235 (defcustom tabbar-help-on-tab-function
 236   'tabbar-buffer-help-on-tab
 237   "Function to obtain a help string for a tab.
 238 The help string is displayed when the mouse is onto the button.  The
 239 function is passed the tab and should return a help string or nil for
 240 none."
 241   :group 'tabbar
 242   :type 'function)
 243 
 244 (defcustom tabbar-home-function
 245   'tabbar-buffer-toggle-group-mode
 246   "Function called when clicking on the tab bar home button.
 247 The function is passed the mouse event received."
 248   :group 'tabbar
 249   :type 'function)
 250 
 251 (defcustom tabbar-home-help-function
 252   'tabbar-buffer-toggle-group-mode-help
 253   "Function to obtain a help string for the tab bar home button.
 254 The help string is displayed when the mouse is onto the button.
 255 The function is called with no arguments."
 256   :group 'tabbar
 257   :type 'function)
 258 
 259 (defcustom tabbar-scroll-left-function
 260   'tabbar-scroll-left
 261   "Function that scrolls tabs on left.
 262 The function is passed the mouse event received when clicking on the
 263 scroll left button.  It should scroll the current tab set."
 264   :group 'tabbar
 265   :type 'function)
 266 
 267 (defcustom tabbar-scroll-left-help-function
 268   'tabbar-scroll-left-help
 269   "Function to obtain a help string for the scroll left button.
 270 The help string is displayed when the mouse is onto the button.
 271 The function is called with no arguments."
 272   :group 'tabbar
 273   :type 'function)
 274 
 275 (defcustom tabbar-scroll-right-function
 276   'tabbar-scroll-right
 277   "Function that scrolls tabs on right.
 278 The function is passed the mouse event received when clicking on the
 279 scroll right button.  It should scroll the current tab set."
 280   :group 'tabbar
 281   :type 'function)
 282 
 283 (defcustom tabbar-scroll-right-help-function
 284   'tabbar-scroll-right-help
 285   "Function to obtain a help string for the scroll right button.
 286 The help string is displayed when the mouse is onto the button.
 287 The function is called with no arguments."
 288   :group 'tabbar
 289   :type 'function)
 290 
 291 ;;; Tab and tab set
 292 ;;
 293 (defconst tabbar-tabsets-tabset-name "tabbar-tabsets-tabset"
 294   "Name of the special tab set of existing tab sets.")
 295 
 296 (defsubst tabbar-make-tab (object tabset)
 297   "Return a new tab with value OBJECT.
 298 TABSET is the tab set the tab belongs to."
 299   (cons object tabset))
 300 
 301 (defsubst tabbar-tab-value (tab)
 302   "Return the value of tab TAB."
 303   (car tab))
 304 
 305 (defsubst tabbar-tab-tabset (tab)
 306   "Return the tab set TAB belongs to."
 307   (cdr tab))
 308 
 309 (defvar tabbar-tabsets nil
 310   "The tab sets store.")
 311 
 312 (defvar tabbar-current-tabset nil
 313   "The tab set currently displayed on the tab bar.")
 314 (make-variable-buffer-local 'tabbar-current-tabset)
 315 
 316 (defvar tabbar-last-selected-tab nil
 317   "The last selected tab.")
 318 
 319 (defsubst tabbar-free-tabsets-store ()
 320   "Free the tab set store."
 321   (setq tabbar-tabsets nil
 322         tabbar-current-tabset nil
 323         tabbar-last-selected-tab nil))
 324 
 325 (defsubst tabbar-init-tabsets-store ()
 326   "Initialize the tab set store."
 327   (tabbar-free-tabsets-store)
 328   (setq tabbar-tabsets (make-vector 31 0)))
 329 
 330 (defmacro tabbar-map-tabsets (function)
 331   "Apply FUNCTION to each existing tab set.
 332 Return the list of the results."
 333   (let ((result (make-symbol "result"))
 334         (tabset (make-symbol "tabset")))
 335     `(let (,result)
 336        (mapatoms #'(lambda (,tabset)
 337                      (setq ,result
 338                            (cons (funcall ,function ,tabset)
 339                                  ,result)))
 340                  tabbar-tabsets)
 341        (nreverse ,result))))
 342 
 343 (defun tabbar-make-tabset (name &rest objects)
 344   "Make a new tab set whose name is the string NAME.
 345 It is initialized with tabs build from the list of OBJECTS."
 346   (let* ((tabset (intern name tabbar-tabsets))
 347          (tabs (mapcar #'(lambda (object)
 348                            (tabbar-make-tab object tabset))
 349                        objects)))
 350     (set tabset tabs)
 351     (put tabset 'select (car tabs))
 352     (put tabset 'start 0)
 353     tabset))
 354 
 355 (defsubst tabbar-get-tabset (name)
 356   "Return the tab set whose name is the string NAME.
 357 Return nil if not found."
 358   (intern-soft name tabbar-tabsets))
 359 
 360 (defsubst tabbar-delete-tabset (tabset)
 361   "Delete the tab set TABSET.
 362 That is, remove it from the tab sets store."
 363   (unintern tabset tabbar-tabsets))
 364 
 365 (defsubst tabbar-tabs (tabset)
 366   "Return the list of tabs in TABSET."
 367   (symbol-value tabset))
 368 
 369 (defsubst tabbar-tab-values (tabset)
 370   "Return the list of tab values in TABSET."
 371   (mapcar 'tabbar-tab-value (tabbar-tabs tabset)))
 372 
 373 (defsubst tabbar-get-tab (object tabset)
 374   "Search for a tab with value OBJECT in TABSET.
 375 Return the tab found, or nil if not found."
 376   (assoc object (tabbar-tabs tabset)))
 377 
 378 (defsubst tabbar-member (tab tabset)
 379   "Return non-nil if TAB is in TABSET."
 380   (or (eq (tabbar-tab-tabset tab) tabset)
 381       (memq tab (tabbar-tabs tabset))))
 382 
 383 (defsubst tabbar-template (tabset)
 384   "Return the template to display TABSET in the header line."
 385   (get tabset 'template))
 386 
 387 (defsubst tabbar-set-template (tabset template)
 388   "Set the TABSET's header line format with TEMPLATE."
 389   (put tabset 'template template))
 390 
 391 (defsubst tabbar-selected-tab (tabset)
 392   "Return the tab selected in TABSET."
 393   (get tabset 'select))
 394 
 395 (defsubst tabbar-selected-value (tabset)
 396   "Return the value of the tab selected in TABSET."
 397   (tabbar-tab-value (tabbar-selected-tab tabset)))
 398 
 399 (defsubst tabbar-selected-p (tab tabset)
 400   "Return non-nil if TAB is the selected tab in TABSET."
 401   (eq tab (tabbar-selected-tab tabset)))
 402 
 403 (defsubst tabbar-select-tab (tab tabset)
 404   "Make TAB the selected tab in TABSET.
 405 Does nothing if TAB is not found in TABSET.
 406 Return TAB if selected, nil if not."
 407   (when (tabbar-member tab tabset)
 408     (or (tabbar-selected-p tab tabset)
 409         (tabbar-set-template tabset nil))
 410     (put tabset 'select tab)))
 411 
 412 (defsubst tabbar-select-tab-value (object tabset)
 413   "Make the tab with value OBJECT, the selected tab in TABSET.
 414 Does nothing if a tab with value OBJECT is not found in TABSET.
 415 Return the tab selected, or nil if nothing was selected."
 416   (tabbar-select-tab (tabbar-get-tab object tabset) tabset))
 417 
 418 (defsubst tabbar-start (tabset)
 419   "Return the index of the first tab in the TABSET's view."
 420   (get tabset 'start))
 421 
 422 (defsubst tabbar-view (tabset)
 423   "Return the list of tabs in the TABSET's view."
 424   (nthcdr (tabbar-start tabset) (tabbar-tabs tabset)))
 425 
 426 (defun tabbar-add-tab (tabset object &optional append)
 427   "Add to TABSET a tab with value OBJECT if there isn't one there yet.
 428 If the tab is added, it is added at the beginning of the tab list,
 429 unless the optional argument APPEND is non-nil, in which case it is
 430 added at the end."
 431   (let ((tabs (tabbar-tabs tabset)))
 432     (if (tabbar-get-tab object tabset)
 433         tabs
 434       (let ((tab (tabbar-make-tab object tabset)))
 435         (tabbar-set-template tabset nil)
 436         (set tabset (if append
 437                         (append tabs (list tab))
 438                       (cons tab tabs)))))))
 439 
 440 (defun tabbar-delete-tab (tab)
 441   "Remove TAB from its TABSET."
 442   (let* ((tabset (tabbar-tab-tabset tab))
 443          (tabs   (tabbar-tabs tabset)))
 444     (tabbar-set-template tabset nil)
 445     (when (eq tab (tabbar-selected-tab tabset))
 446       (tabbar-select-tab (car (or (cdr (memq tab tabs)) (last tabs)))
 447                          tabset))
 448     (set tabset (delq tab tabs))))
 449 
 450 (defun tabbar-scroll (tabset count)
 451   "Scroll the TABSET's view of COUNT tabs.
 452 If COUNT is positive move the view on right.  If COUNT is negative,
 453 move the view on left."
 454   (let ((start (min (max 0 (+ (tabbar-start tabset) count))
 455                     (1- (length (tabbar-tabs tabset))))))
 456     (when (/= start (tabbar-start tabset))
 457       (tabbar-set-template tabset nil)
 458       (put tabset 'start start)
 459       (tabbar-adjust tabset)
 460       (when (/= start (tabbar-start tabset)) ; if set failed, select prev/next tab.
 461 	(switch-to-buffer (tabbar-tab-value
 462 			   (tabbar-tab-next tabset
 463 					    (tabbar-selected-tab tabset)
 464 					    (if (< count 0) t nil))))
 465 	(put tabset 'start start)))))
 466 
 467 (defun tabbar-list-insert-before (el pos li-sym)
 468   (let ((li-value (symbol-value li-sym)))
 469     (if (= pos 0)
 470 	(set li-sym (cons el li-value))
 471       (setcdr (nthcdr (1- pos) li-value)
 472 	      (cons el (nthcdr pos li-value))))))
 473 
 474 (defun tabbar-move (tabset count)
 475   "Change the position of tab on the TABSET.
 476 If COUNT is positive move the tab on right.  If COUNT is negative,
 477 move the tab on left."
 478   (let* ((tabs (tabbar-tabs tabset))
 479 	 (sel-tab (tabbar-selected-tab tabset))
 480 	 (sel-index (position sel-tab tabs))
 481 	 (mov-index (max 0 (min (+ sel-index count) (1- (length tabs))))))
 482     (unless (= sel-index mov-index)
 483       (set tabset (delq sel-tab tabs))
 484       (tabbar-list-insert-before sel-tab mov-index tabset)
 485       (tabbar-set-template tabset nil)
 486       (tabbar-select-tab sel-tab tabset)
 487       )))
 488 
 489 (defun tabbar-tab-next (tabset tab &optional before)
 490   "Search in TABSET for the tab after TAB.
 491 If optional argument BEFORE is non-nil, search for the tab before
 492 TAB.  Return the tab found, or nil otherwise."
 493   (let* (last (tabs (tabbar-tabs tabset)))
 494     (while (and tabs (not (eq tab (car tabs))))
 495       (setq last (car tabs)
 496             tabs (cdr tabs)))
 497     (and tabs (if before last (nth 1 tabs)))))
 498 
 499 (defun tabbar-current-tabset (&optional update)
 500   "Return the current tab set, that will be displayed on the tab bar.
 501 If optional argument UPDATE is non-nil, call the user defined function
 502 `tabbar-current-tabset-function' to obtain it.  Otherwise return the
 503 current cached copy."
 504   (when (and update tabbar-current-tabset-function)
 505     (setq tabbar-current-tabset
 506           (funcall tabbar-current-tabset-function))
 507     (or tabbar-last-selected-tab
 508         (setq tabbar-last-selected-tab
 509               (tabbar-selected-tab tabbar-current-tabset))))
 510   tabbar-current-tabset)
 511 
 512 (defun tabbar-get-tabsets-tabset ()
 513   "Return the tab set of selected tabs in existing tab sets."
 514   (let ((tabsets-tabset
 515          (or (tabbar-get-tabset tabbar-tabsets-tabset-name)
 516              (tabbar-make-tabset tabbar-tabsets-tabset-name))))
 517     (set tabsets-tabset
 518          (delq t
 519                (tabbar-map-tabsets
 520                 #'(lambda (tabset)
 521                     (or (eq tabset tabsets-tabset)
 522                         (tabbar-selected-tab tabset))))))
 523     (tabbar-scroll tabsets-tabset 0)
 524     (tabbar-set-template tabsets-tabset nil)
 525     tabsets-tabset))
 526 
 527 (defsubst tabbar-set-start (tabset start)
 528   "Set the index of the first tab in the TABSET's view to START."
 529   (put tabset 'start start))
 530 
 531 (defsubst tabbar-tab-label-width (tab)
 532   "Return the width of label TAB occupies, including separator."
 533   (+ (length (if tabbar-tab-label-function
 534 		 (funcall tabbar-tab-label-function tab)
 535 	       tab))
 536      (length tabbar-separator-value)))
 537 
 538 (defun tabbar-tabs-view-width (tabs start end)
 539   "Return sum of width of TABS from START index to END index."
 540   (let ((sum 0))
 541     (mapc #'(lambda (_tab)
 542 	      (setq sum (+ sum
 543 			   (tabbar-tab-label-width _tab))))
 544 	  (butlast (nthcdr start tabs)
 545 		   (- (length tabs) end 1)))
 546     sum))
 547 
 548 (defun tabbar-adjust (tabset)
 549   "Adjust TABSET's first tab index."
 550   (let* ((tabs (tabbar-tabs tabset))
 551 	 (sel-index (position
 552 		     (tabbar-selected-tab tabset)
 553 		     tabs))
 554 	 (start-index (tabbar-start tabset))
 555 	 view-width)
 556     (when (< sel-index start-index)
 557       (setq start-index (if (= start-index (length tabs))
 558 			    0
 559 			  sel-index)))
 560     (when (> sel-index start-index)
 561       (setq view-width (tabbar-tabs-view-width tabs start-index sel-index))
 562       (when (> view-width (window-width))
 563 	;; increase start-index until selected tab is within window.
 564 	(setq tabs (nthcdr start-index tabs))
 565 	(while (and (< start-index sel-index)
 566 		    (> view-width (window-width)))
 567 	  (setq view-width (- view-width
 568 			      (tabbar-tab-label-width (car tabs)))
 569 		start-index (1+ start-index)
 570 		tabs (cdr tabs))
 571 	  )))
 572     (tabbar-set-start tabset start-index)))
 573 
 574 (defun tabbar-debug ()
 575   (interactive)
 576   (let* ((tabset (tabbar-current-tabset))
 577 	 (tabs (tabbar-tabs tabset))
 578 	 (sel-index (position
 579 		     (tabbar-selected-tab tabset)
 580 		     tabs))
 581 	 (start-index (tabbar-start tabset))
 582 	 view-width)
 583     (message "----")
 584     (message "Tabs[%d] = %s" (length tabs) tabs)
 585     (message "StartIndex = %d" start-index)
 586     (setq start-index (1- start-index))
 587     (message "New StartIndex = %d" start-index)
 588     (message "SelIndex = %d" sel-index)
 589     (when (< sel-index start-index)
 590       (setq start-index (if (= start-index (length tabs))
 591 			    0
 592 			  sel-index)))
 593     (when (> sel-index start-index)
 594       (setq view-width (tabbar-tabs-view-width tabs start-index sel-index))
 595       (message "ViewWidth = %d" view-width)
 596       (message "WindowWidth = %d" (window-width))
 597       (when (> view-width (window-width))
 598 	;; increase start-index until selected tab is within window.
 599 	(setq tabs (nthcdr start-index tabs))
 600 	(while (and (< start-index sel-index)
 601 		    (> view-width (window-width)))
 602 	  (setq view-width (- view-width
 603 			      (tabbar-tab-label-width (car tabs)))
 604 		start-index (1+ start-index)
 605 		tabs (cdr tabs))
 606 	  )
 607 	(message "Adjust StartIndex = %d" start-index)
 608 	(message "Adjust ViewWidth = %d" view-width)
 609 
 610 	))
 611     (message "Final StartIndex = %d" start-index)))
 612 
 613 
 614 ;;; Buttons and separators
 615 ;;
 616 (defun tabbar-find-image (specs)
 617   "Find an image, choosing one of a list of image specifications.
 618 SPECS is a list of image specifications.  See also `find-image'."
 619   (when (display-images-p)
 620     (condition-case nil
 621         (find-image specs)
 622       (error nil))))
 623 
 624 (defconst tabbar-separator-widget
 625   '(cons (string)
 626          (repeat :tag "Image"
 627                  :extra-offset 2
 628                  (restricted-sexp :tag "Spec"
 629                                   :match-alternatives (listp))))
 630   "Widget for editing a tab bar separator.
 631 A separator is specified as a pair (STRING . IMAGE) where STRING is a
 632 string value, and IMAGE a list of image specifications.
 633 If IMAGE is non-nil, try to use that image, else use STRING.
 634 The value (\"\") hide separators.")
 635 
 636 (defun tabbar-setup-separator (variable value)
 637   "Set VARIABLE with specification of tab separator in VALUE.
 638 Initialize `VARIABLE-value' with the template element to use in header
 639 line, to display a separator on the tab bar."
 640   (let ((text (intern (format "%s-value" variable)))
 641         (image (tabbar-find-image (cdr value))))
 642     (set text (propertize (if image " " (car value))
 643                           'face 'tabbar-separator-face
 644                           'display image))
 645     (custom-set-default variable value)
 646     ))
 647 
 648 (defvar tabbar-separator-value nil
 649   "Text of the separator used between tabs.")
 650 
 651 (defcustom tabbar-separator (list " ")
 652   "Separator used between tabs.
 653 See the variable `tabbar-separator-widget' for details."
 654   :group 'tabbar
 655   :type tabbar-separator-widget
 656   :set 'tabbar-setup-separator)
 657 
 658 (defconst tabbar-button-widget
 659   '(cons
 660     (cons :tag "Enabled"
 661           (string)
 662           (repeat :tag "Image"
 663                   :extra-offset 2
 664                   (restricted-sexp :tag "Spec"
 665                                    :match-alternatives (listp))))
 666     (cons :tag "Disabled"
 667           (string)
 668           (repeat :tag "Image"
 669                   :extra-offset 2
 670                   (restricted-sexp :tag "Spec"
 671                                    :match-alternatives (listp))))
 672     )
 673   "Widget for editing a tab bar button.
 674 A button is specified as a pair (ENABLED-BUTTON . DISABLED-BUTTON),
 675 where ENABLED-BUTTON and DISABLED-BUTTON specify the value used when
 676 the button is respectively enabled and disabled.  Each button value is
 677 a pair (STRING . IMAGE) where STRING is a string value, and IMAGE a
 678 list of image specifications.
 679 If IMAGE is non-nil, try to use that image, else use STRING.")
 680 
 681 (defun tabbar-setup-button (variable value)
 682   "Set VARIABLE with the button specification in VALUE.
 683 Initialize `VARIABLE-enable' and `VARIABLE-disable' with the template
 684 elements to use in the header line, to respectively display an enabled
 685 and a disabled button on the tab bar.
 686 The variable `VARIABLE-keymap' must be set with the keymap used for the
 687 enabled button.
 688 The function `VARIABLE-help' must be defined to return the `help-echo'
 689 string shown when the mouse is on the button."
 690   (let ((enabled  (intern (format "%s-enabled" variable)))
 691         (disabled (intern (format "%s-disabled" variable)))
 692         (keymap   (intern (format "%s-keymap" variable)))
 693         (help     (intern (format "%s-help" variable)))
 694         (image-en (tabbar-find-image (cdar value)))
 695         (image-di (tabbar-find-image (cddr value))))
 696     (set enabled (propertize (if image-en " " (caar value))
 697                              'display image-en
 698                              'face 'tabbar-button-face
 699                              'local-map (symbol-value keymap)
 700                              'help-echo help))
 701     (set disabled (propertize (if image-di " " (cadr value))
 702                               'display image-di
 703                               'face 'tabbar-button-face
 704 			      'local-map (symbol-value keymap)
 705 			      'help-echo help))
 706     (custom-set-default variable value)
 707     ))
 708 
 709 (defun tabbar-make-button-keymap (callback)
 710   "Return a button keymap that call CALLBACK on mouse events.
 711 CALLBACK is passed the received mouse event."
 712   (let ((keymap (make-sparse-keymap)))
 713     ;; Pass mouse-1, mouse-2 and mouse-3 events to CALLBACK.
 714     (define-key keymap [header-line down-mouse-1] 'ignore)
 715     (define-key keymap [header-line mouse-1] callback)
 716     (define-key keymap [header-line down-mouse-2] 'ignore)
 717     (define-key keymap [header-line mouse-2] callback)
 718     (define-key keymap [header-line down-mouse-3] 'ignore)
 719     (define-key keymap [header-line mouse-3] callback)
 720     keymap))
 721 
 722 (defvar tabbar-home-button-enabled nil
 723   "Text of the enabled home button.")
 724 
 725 (defvar tabbar-home-button-disabled nil
 726   "Text of the disabled home button.")
 727 
 728 (defconst tabbar-home-button-keymap
 729   (tabbar-make-button-keymap 'tabbar-home-button-callback)
 730   "Keymap of the home button.")
 731 
 732 (defun tabbar-home-button-callback (event)
 733   "Handle a mouse EVENT on the home button.
 734 Call `tabbar-home-function'."
 735   (interactive "e")
 736   (when tabbar-home-function
 737     (save-selected-window
 738       (select-window (posn-window (event-start event)))
 739       (funcall tabbar-home-function event)
 740       (force-mode-line-update)
 741       (sit-for 0)
 742       )))
 743 
 744 (defun tabbar-home-button-help (window object position)
 745   "Return a help string or nil for none, for the home button.
 746 Call `tabbar-home-help-function'.
 747 Arguments WINDOW, OBJECT and POSITION, are not used."
 748   (when tabbar-home-help-function
 749     (funcall tabbar-home-help-function)))
 750 
 751 (defconst tabbar-home-button-enabled-image
 752   '((:type pbm :ascent center :data "\
 753 P2
 754 10 10
 755 255
 756 184 184 184 184 0 184 184 184 184 184 184 184 184 0 0 0 184 184 184 184
 757 184 184 0 0 0 0 0 184 184 184 184 0 0 0 0 0 0 0 184 184 184 184 255 0 0
 758 0 255 255 255 184 184 0 0 0 0 0 0 0 184 184 184 184 0 0 0 0 0 255 255 184
 759 184 184 184 0 0 0 255 255 184 184 184 184 184 184 0 255 255 184 184 184
 760 184 184 184 184 184 255 184 184 184 184
 761 "))
 762   "Default image for the enabled home button.")
 763 
 764 (defconst tabbar-home-button-disabled-image
 765   '((:type pbm :ascent center :data "\
 766 P2
 767 10 10
 768 255
 769 184 184 184 184 120 184 184 184 184 184 184 184 184 120 120 120 184 184
 770 184 184 184 184 120 184 184 184 120 184 184 184 184 120 120 160 184 160
 771 120 120 184 184 184 184 255 120 184 120 255 255 255 184 184 120 120 160
 772 184 160 120 120 184 184 184 184 120 184 184 184 120 255 255 184 184 184
 773 184 120 120 120 255 255 184 184 184 184 184 184 120 255 255 184 184 184
 774 184 184 184 184 184 255 184 184 184 184
 775 "))
 776   "Default image for the disabled home button.")
 777 
 778 (defcustom tabbar-home-button
 779   (cons (cons "[o]" tabbar-home-button-enabled-image)
 780         (cons "[x]" tabbar-home-button-disabled-image))
 781   "The home button.
 782 See the variable `tabbar-button-widget' for details."
 783   :group 'tabbar
 784   :type tabbar-button-widget
 785   :set 'tabbar-setup-button)
 786 
 787 (defvar tabbar-scroll-left-button-enabled nil
 788   "Text of the enabled scroll left button.")
 789 
 790 (defvar tabbar-scroll-left-button-disabled nil
 791   "Text of the disabled scroll left button.")
 792 
 793 (defconst tabbar-scroll-left-button-keymap
 794   (tabbar-make-button-keymap 'tabbar-scroll-left-button-callback)
 795   "Keymap of the scroll left button.")
 796 
 797 (defun tabbar-scroll-left-button-callback (event)
 798   "Handle a mouse EVENT on the scroll left button.
 799 Call `tabbar-scroll-left-function'."
 800   (interactive "e")
 801   (when tabbar-scroll-left-function
 802     (save-selected-window
 803       (select-window (posn-window (event-start event)))
 804       (funcall tabbar-scroll-left-function event)
 805       (force-mode-line-update)
 806       (sit-for 0)
 807       )))
 808 
 809 (defun tabbar-scroll-left-button-help (window object position)
 810   "Return a help string or nil for none, for the scroll left button.
 811 Call `tabbar-scroll-left-help-function'.
 812 Arguments WINDOW, OBJECT and POSITION, are not used."
 813   (when tabbar-scroll-left-help-function
 814     (funcall tabbar-scroll-left-help-function)))
 815 
 816 (defconst tabbar-scroll-left-button-enabled-image
 817   '((:type pbm :ascent center :data "\
 818 P2
 819 8 10
 820 255
 821 184 184 184 184 184 184 184 184 184 184 184 184 184 0 184 184 184 184 184
 822 184 0 0 255 184 184 184 184 0 0 0 255 184 184 184 0 0 0 0 255 184 184 184
 823 184 0 0 0 255 184 184 184 184 184 0 0 255 184 184 184 184 184 184 0 255
 824 184 184 184 184 184 184 184 255 184 184 184 184 184 184 184 184 184
 825 "))
 826   "Default image for the enabled scroll left button.")
 827 
 828 (defconst tabbar-scroll-left-button-disabled-image
 829   '((:type pbm :ascent center :data "\
 830 P2
 831 8 10
 832 255
 833 184 184 184 184 184 184 184 184 184 184 184 184 184 120 184 184 184 184
 834 184 184 120 120 255 184 184 184 184 120 184 120 255 184 184 184 120 184
 835 184 120 255 184 184 184 184 120 184 120 255 184 184 184 184 184 120 120
 836 255 184 184 184 184 184 184 120 255 184 184 184 184 184 184 184 255 184
 837 184 184 184 184 184 184 184 184
 838 "))
 839   "Default image for the disabled scroll left button.")
 840 
 841 (defcustom tabbar-scroll-left-button
 842   (cons (cons " <" tabbar-scroll-left-button-enabled-image)
 843         (cons " =" tabbar-scroll-left-button-disabled-image))
 844   "The scroll left button.
 845 See the variable `tabbar-button-widget' for details."
 846   :group 'tabbar
 847   :type tabbar-button-widget
 848   :set 'tabbar-setup-button)
 849 
 850 (defvar tabbar-scroll-right-button-enabled nil
 851   "Text of the enabled scroll right button.")
 852 
 853 (defvar tabbar-scroll-right-button-disabled nil
 854   "Text of the disabled scroll right button.")
 855 
 856 (defconst tabbar-scroll-right-button-keymap
 857   (tabbar-make-button-keymap 'tabbar-scroll-right-button-callback)
 858   "Keymap of the scroll right button.")
 859 
 860 (defun tabbar-scroll-right-button-callback (event)
 861   "Handle a mouse EVENT on the scroll right button.
 862 Call `tabbar-scroll-right-function'."
 863   (interactive "e")
 864   (when tabbar-scroll-right-function
 865     (save-selected-window
 866       (select-window (posn-window (event-start event)))
 867       (funcall tabbar-scroll-right-function event)
 868       (force-mode-line-update)
 869       (sit-for 0)
 870       )))
 871 
 872 (defun tabbar-scroll-right-button-help (window object position)
 873   "Return a help string or nil for none, for the scroll right button.
 874 Call `tabbar-scroll-right-help-function'.
 875 Arguments WINDOW, OBJECT and POSITION, are not used."
 876   (when tabbar-scroll-right-help-function
 877     (funcall tabbar-scroll-right-help-function)))
 878 
 879 (defconst tabbar-scroll-right-button-enabled-image
 880   '((:type pbm :ascent center :data "\
 881 P2
 882 8 10
 883 255
 884 184 184 184 184 184 184 184 184 184 0 184 184 184 184 184 184 184 0 0 184
 885 184 184 184 184 184 0 0 0 184 184 184 184 184 0 0 0 0 184 184 184 184 0
 886 0 0 255 255 184 184 184 0 0 255 255 184 184 184 184 0 255 255 184 184 184
 887 184 184 184 255 184 184 184 184 184 184 184 184 184 184 184 184 184
 888 "))
 889   "Default image for the enabled scroll right button.")
 890 
 891 (defconst tabbar-scroll-right-button-disabled-image
 892   '((:type pbm :ascent center :data "\
 893 P2
 894 8 10
 895 255
 896 184 184 184 184 184 184 184 184 184 120 184 184 184 184 184 184 184 120
 897 120 184 184 184 184 184 184 120 184 120 184 184 184 184 184 120 184 184
 898 120 184 184 184 184 120 184 120 255 255 184 184 184 120 120 255 255 184
 899 184 184 184 120 255 255 184 184 184 184 184 184 255 184 184 184 184 184
 900 184 184 184 184 184 184 184 184
 901 "))
 902   "Default image for the disabled scroll right button.")
 903 
 904 (defcustom tabbar-scroll-right-button
 905   (cons (cons " >" tabbar-scroll-right-button-enabled-image)
 906         (cons " =" tabbar-scroll-right-button-disabled-image))
 907   "The scroll right button.
 908 See the variable `tabbar-button-widget' for details."
 909   :group 'tabbar
 910   :type tabbar-button-widget
 911   :set 'tabbar-setup-button)
 912 
 913 ;;; Faces
 914 ;;
 915 (defface tabbar-default-face
 916   '(
 917     (t
 918      (:inherit variable-pitch
 919                :height 0.8
 920                :foreground "gray60"
 921                :background "gray72"
 922                )
 923      )
 924     )
 925   "Default face used in the tab bar."
 926   :group 'tabbar)
 927 
 928 (defface tabbar-unselected-face
 929   '(
 930     (t
 931      (:inherit tabbar-default-face
 932                :box (:line-width 2 :color "white" :style pressed-button)
 933                )
 934      )
 935     )
 936   "Face used for uselected tabs."
 937   :group 'tabbar)
 938 
 939 (defface tabbar-selected-face
 940   '(
 941     (t
 942      (:inherit tabbar-default-face
 943                :box (:line-width 2 :color "white" :style released-button)
 944                :foreground "blue"
 945                )
 946      )
 947     )
 948   "Face used for the selected tab."
 949   :group 'tabbar)
 950 
 951 (defface tabbar-separator-face
 952   '(
 953     (t
 954      (:inherit tabbar-default-face
 955                :height 0.2
 956                )
 957      )
 958     )
 959   "Face used for the select mode button."
 960   :group 'tabbar)
 961 
 962 (defface tabbar-button-face
 963   '(
 964     (t
 965      (:inherit tabbar-default-face
 966                :box (:line-width 2 :color "white" :style released-button)
 967                :foreground "dark red"
 968                )
 969      )
 970     )
 971   "Face used for the select mode button."
 972   :group 'tabbar)
 973 
 974 ;;; Wrappers
 975 ;;
 976 (defun tabbar-scroll-left (event)
 977   "On mouse EVENT, scroll/move current tab set on left."
 978   (cond
 979    ((eq (event-basic-type event) 'mouse-1)
 980     (tabbar-scroll (tabbar-current-tabset) -1))
 981    ((eq (event-basic-type event) 'mouse-2)
 982     (tabbar-move (tabbar-current-tabset) -10000))
 983    ((eq (event-basic-type event) 'mouse-3)
 984     (tabbar-move (tabbar-current-tabset) -1))
 985    ))
 986 
 987 (defun tabbar-scroll-left-help ()
 988   "Return the help string shown when mouse is onto the scroll left button."
 989   "mouse-1: scroll tabs left. mouse-2: move tab leftmost. mouse-3: move tab left")
 990 
 991 (defun tabbar-scroll-right (event)
 992   "On mouse EVENT, scroll/move current tab set on right."
 993   (cond
 994    ((eq (event-basic-type event) 'mouse-1)
 995     (tabbar-scroll (tabbar-current-tabset) 1))
 996    ((eq (event-basic-type event) 'mouse-2)
 997     (tabbar-move (tabbar-current-tabset) 10000))
 998    ((eq (event-basic-type event) 'mouse-3)
 999     (tabbar-move (tabbar-current-tabset) 1))
1000    ))
1001 
1002 (defun tabbar-scroll-right-help ()
1003   "Return the help string shown when mouse is onto the scroll right button."
1004   "mouse-1: scroll tabs right. mouse-2: move tab rightmost mouse-3: move tab right")
1005 
1006  ;; These functions can be called at compilation time.
1007 (eval-and-compile
1008 
1009   (defun tabbar-make-select-tab-command (tab)
1010     "Return a command to handle TAB selection.
1011 That command calls `tabbar-select-tab-function' with the received
1012 mouse event and TAB."
1013     (let ((event (make-symbol "event")))
1014       `(lambda (,event)
1015          (interactive "e")
1016          (setq tabbar-last-selected-tab ,tab)
1017          (when tabbar-select-tab-function
1018            (select-window (posn-window (event-start ,event)))
1019            (funcall tabbar-select-tab-function ,event ,tab)
1020            (force-mode-line-update)
1021            (sit-for 0)))))
1022 
1023   (defun tabbar-make-help-on-tab-function (tab)
1024     "Return a function that return a help string on TAB.
1025 That command calls `tabbar-help-on-tab-function' with TAB."
1026     (let ((window (make-symbol "window"))
1027           (object (make-symbol "object"))
1028           (position (make-symbol "position"))
1029           )
1030       `(lambda (,window ,object ,position)
1031          (when tabbar-help-on-tab-function
1032            (funcall tabbar-help-on-tab-function ,tab)))))
1033 
1034   )
1035 
1036 (defun tabbar-line-element (tab)
1037   "Return an `header-line-format' template element from TAB.
1038 Call `tabbar-tab-label-function' to obtain a label for TAB."
1039   (let* ((keymap (make-sparse-keymap))
1040          (qtab   (list 'quote tab))
1041          (select (tabbar-make-select-tab-command qtab))
1042          (help   (tabbar-make-help-on-tab-function qtab))
1043          (label  (if tabbar-tab-label-function
1044                      (funcall tabbar-tab-label-function tab)
1045                    tab)))
1046     ;; Call `tabbar-select-tab-function' on mouse events.
1047     (define-key keymap [header-line down-mouse-1] 'ignore)
1048     (define-key keymap [header-line mouse-1] select)
1049     (define-key keymap [header-line down-mouse-2] 'ignore)
1050     (define-key keymap [header-line mouse-2] select)
1051     (define-key keymap [header-line down-mouse-3] 'ignore)
1052     (define-key keymap [header-line mouse-3] select)
1053     ;; Return the tab followed by a separator.
1054     (list (propertize label 'local-map keymap 'help-echo help
1055                       'face (if (tabbar-selected-p
1056                                  tab(tabbar-current-tabset))
1057                                 'tabbar-selected-face
1058                               'tabbar-unselected-face))
1059           tabbar-separator-value)))
1060 
1061 (defun tabbar-line ()
1062   "Return the header line templates that represent the tab bar.
1063 Call `tabbar-current-tabset-function' to obtain the current tab set to
1064 display.  Then call `tabbar-line-element' on each tab in current tab
1065 set's view to build a list of template elements for
1066 `header-line-format'."
1067   (if (run-hook-with-args-until-success 'tabbar-inhibit-functions)
1068       (setq header-line-format nil)
1069     (let ((tabset (tabbar-current-tabset t))
1070           (padcolor (face-background 'tabbar-default-face)))
1071       (when tabset
1072 	(tabbar-adjust tabset)
1073         (list (format "%s%s%s"
1074                       (if tabbar-home-function
1075                           tabbar-home-button-enabled
1076                         tabbar-home-button-disabled)
1077                       (if (> (tabbar-start tabset) 0)
1078                           tabbar-scroll-left-button-enabled
1079                         tabbar-scroll-left-button-disabled)
1080                       (if (< (tabbar-start tabset)
1081                              (1- (length (tabbar-tabs tabset))))
1082                           tabbar-scroll-right-button-enabled
1083                         tabbar-scroll-right-button-disabled)
1084 			  )
1085               tabbar-separator-value
1086               (or
1087                ;; If a cached template exists, use it.
1088                (tabbar-template tabset)
1089                ;; Otherwise use a refeshed value.
1090                (tabbar-set-template tabset
1091                                     (mapcar 'tabbar-line-element
1092                                             (tabbar-view tabset))))
1093               (propertize "%-" 'face (list :background padcolor
1094                                            :foreground padcolor))))
1095       )))
1096 
1097 ;;; Cyclic navigation through tabs
1098 ;;
1099 (defsubst tabbar-make-mouse-event (&optional type)
1100   "Return a basic mouse event.
1101 Optional argument TYPE is a mouse event type.  That is one of the
1102 symbols `mouse-1', `mouse-2' or `mouse-3'.  The default is `mouse-1'."
1103   (list (or (memq type '(mouse-2 mouse-3)) 'mouse-1)
1104         (or (event-start nil) ;; Emacs 21.4
1105             (list (selected-window) (point) '(0 . 0) 0))))
1106 
1107 (defmacro tabbar-click-on-tab (tab &optional type)
1108   "Simulate a mouse click event on tab TAB.
1109 Optional argument TYPE is a mouse event type (see the function
1110 `tabbar-make-mouse-event' for details)."
1111   `(,(tabbar-make-select-tab-command tab)
1112     (tabbar-make-mouse-event ,type)))
1113 
1114 (defun tabbar-cycle (&optional backward)
1115   "Cycle to the next available tab.
1116 If optional argument BACKWARD is non-nil, cycle to the previous tab
1117 instead.
1118 The scope of the cyclic navigation through tabs is specified by the
1119 option `tabbar-cycling-scope'."
1120   (let ((tabset (tabbar-current-tabset t))
1121         selected tab)
1122     (when tabset
1123       (setq selected (tabbar-selected-tab tabset))
1124       (cond
1125        ;; Cycle through visible tabs only.
1126        ((eq tabbar-cycling-scope 'tabs)
1127         (setq tab (tabbar-tab-next tabset selected backward))
1128         ;; When there is no tab after/before the selected one, cycle
1129         ;; to the first/last visible tab.
1130         (unless tab
1131           (setq tabset (tabbar-tabs tabset)
1132                 tab (car (if backward (last tabset) tabset))))
1133         )
1134        ;; Cycle through tab groups only.
1135        ((eq tabbar-cycling-scope 'groups)
1136         (setq tabset (tabbar-get-tabsets-tabset)
1137               tab (tabbar-tab-next tabset selected backward))
1138         ;; When there is no group after/before the selected one, cycle
1139         ;; to the first/last available group.
1140         (unless tab
1141           (setq tabset (tabbar-tabs tabset)
1142                 tab (car (if backward (last tabset) tabset))))
1143         )
1144        (t
1145         ;; Cycle through visible tabs then tab groups.
1146         (setq tab (tabbar-tab-next tabset selected backward))
1147         ;; When there is no visible tab after/before the selected one,
1148         ;; cycle to the next/previous available group.
1149         (unless tab
1150           (setq tabset (tabbar-get-tabsets-tabset)
1151                 tab (tabbar-tab-next tabset selected backward))
1152           ;; When there is no next/previous group, cycle to the
1153           ;; first/last available group.
1154           (unless tab
1155             (setq tabset (tabbar-tabs tabset)
1156                   tab (car (if backward (last tabset) tabset))))
1157           ;; Select the first/last visible tab of the new group.
1158           (setq tabset (tabbar-tabs (tabbar-tab-tabset tab))
1159                 tab (car (if backward (last tabset) tabset))))
1160         ))
1161       (tabbar-click-on-tab tab))))
1162 
1163 ;;;###autoload
1164 (defun tabbar-backward ()
1165   "Select the previous available tab.
1166 Depend on the setting of the option `tabbar-cycling-scope'."
1167   (interactive)
1168   (tabbar-cycle t))
1169 
1170 ;;;###autoload
1171 (defun tabbar-forward ()
1172   "Select the next available tab.
1173 Depend on the setting of the option `tabbar-cycling-scope'."
1174   (interactive)
1175   (tabbar-cycle))
1176 
1177 ;;;###autoload
1178 (defun tabbar-backward-group ()
1179   "Go to selected tab in the previous available group."
1180   (interactive)
1181   (let ((tabbar-cycling-scope 'groups))
1182     (tabbar-cycle t)))
1183 
1184 ;;;###autoload
1185 (defun tabbar-forward-group ()
1186   "Go to selected tab in the next available group."
1187   (interactive)
1188   (let ((tabbar-cycling-scope 'groups))
1189     (tabbar-cycle)))
1190 
1191 ;;;###autoload
1192 (defun tabbar-backward-tab ()
1193   "Select the previous visible tab."
1194   (interactive)
1195   (let ((tabbar-cycling-scope 'tabs))
1196     (tabbar-cycle t)))
1197 
1198 ;;;###autoload
1199 (defun tabbar-forward-tab ()
1200   "Select the next visible tab."
1201   (interactive)
1202   (let ((tabbar-cycling-scope 'tabs))
1203     (tabbar-cycle)))
1204 
1205 ;;;###autoload
1206 (defun tabbar-goto-group()
1207   "Prompt a group name and go."
1208   (interactive)
1209   (let* ((tablist (mapcar #'(lambda (tab)
1210 			      (cons
1211 			       (downcase (format "%s" (tabbar-tab-tabset tab)))
1212 			       tab))
1213 			  (tabbar-tabs (tabbar-get-tabsets-tabset))))
1214 	 (read-group (completing-read "Tab group: " tablist nil t))
1215 	 (tab (cdr (assoc read-group tablist))))
1216     (tabbar-click-on-tab tab)))
1217 
1218 
1219 ;;; Minor modes
1220 ;;
1221 (defvar tabbar-old-global-hlf nil
1222   "Global value of the header line when entering tab bar mode.")
1223 
1224 (defconst tabbar-header-line-format '(:eval (tabbar-line))
1225   "The tab bar header line format.")
1226 
1227 ;;;###autoload
1228 (define-minor-mode tabbar-mode
1229   "Toggle display of a tab bar in the header line.
1230 With prefix argument ARG, turn on if positive, otherwise off.
1231 Returns non-nil if the new state is enabled."
1232   :global t
1233   :group 'tabbar
1234   (if tabbar-mode
1235 ;;; ON
1236       (unless (eq header-line-format tabbar-header-line-format)
1237         ;; Save current default value of `header-line-format'.
1238         (setq tabbar-old-global-hlf (default-value 'header-line-format))
1239         (add-hook 'kill-buffer-hook 'tabbar-buffer-kill-buffer-hook)
1240         (tabbar-init-tabsets-store)
1241         (setq-default header-line-format tabbar-header-line-format)
1242 	(tabbar-speedkey-install))
1243 ;;; OFF
1244     ;; Restore previous `header-line-format', if it has not changed.
1245     (when (eq (default-value 'header-line-format)
1246               tabbar-header-line-format)
1247       (setq-default header-line-format tabbar-old-global-hlf))
1248     (remove-hook 'kill-buffer-hook 'tabbar-buffer-kill-buffer-hook)
1249     (tabbar-free-tabsets-store)
1250     ;; Turn off locals tab bar mode
1251     (mapc #'(lambda (b)
1252               (with-current-buffer b
1253                 (tabbar-local-mode -1)))
1254           (buffer-list))
1255     (tabbar-speedkey-uninstall)
1256     ))
1257 
1258 (defvar tabbar-old-local-hlf nil
1259   "Local value of the header line when entering tab bar local mode.")
1260 (make-variable-buffer-local 'tabbar-old-local-hlf)
1261 
1262 ;;;###autoload
1263 (define-minor-mode tabbar-local-mode
1264   "Toggle local display of the tab bar.
1265 With prefix argument ARG, turn on if positive, otherwise off.
1266 Returns non-nil if the new state is enabled.
1267 When on and tab bar global mode is on, if a buffer local value of
1268 `header-line-format' exists, it is saved, then the local header line
1269 is killed to show the tab bar.  When off, the saved local value of the
1270 header line is restored, hiding the tab bar."
1271   :global nil
1272   :group 'tabbar
1273 ;;; ON
1274   (if tabbar-local-mode
1275       (if (and tabbar-mode (local-variable-p 'header-line-format)
1276                (not (local-variable-p 'tabbar-old-local-hlf)))
1277           (progn
1278             (setq tabbar-old-local-hlf header-line-format)
1279             (kill-local-variable 'header-line-format))
1280         (setq tabbar-local-mode nil))
1281 ;;; OFF
1282     (when (local-variable-p 'tabbar-old-local-hlf)
1283       (setq header-line-format tabbar-old-local-hlf)
1284       (kill-local-variable 'tabbar-old-local-hlf))
1285     ))
1286 
1287 ;;; Hooks
1288 ;;
1289 (defun tabbar-default-inhibit-function ()
1290   "Inhibit display of the tab bar in specified windows.
1291 That is dedicated windows, and `checkdoc' status windows."
1292   (or (window-dedicated-p (selected-window))
1293       (member (buffer-name)
1294               '(" *Checkdoc Status*"))))
1295 
1296 (defun tabbar-buffer-kill-buffer-hook ()
1297   "Hook run just before actually killing a buffer.
1298 In tab bar mode, try to switch to a buffer in the current tab bar,
1299 after the current buffer has been killed.  Try first the buffer in tab
1300 after the current one, then the buffer in tab before.  On success, put
1301 the sibling buffer in front of the buffer list, so it will be selected
1302 first."
1303   (and tabbar-mode
1304        (eq tabbar-current-tabset-function 'tabbar-buffer-tabs)
1305        (eq (current-buffer) (window-buffer (selected-window)))
1306        (let ((bl (tabbar-tab-values (tabbar-current-tabset)))
1307              (bn (buffer-name))
1308              found sibling)
1309          (while (and bl (not found))
1310            (if (equal bn (car bl))
1311                (setq found t)
1312              (setq sibling (car bl)))
1313            (setq bl (cdr bl)))
1314          (when (setq sibling (or (car bl) sibling))
1315            ;; Move sibling buffer in front of the buffer list.
1316            (save-current-buffer
1317              (switch-to-buffer sibling))))))
1318 
1319 ;;; Buffer tabs
1320 ;;
1321 (defcustom tabbar-buffer-list-function
1322   'tabbar-buffer-list
1323   "*Function that returns the list of buffers to show in tabs.
1324 That function is called with no arguments and must return a list of
1325 buffers."
1326   :group 'tabbar
1327   :type 'function)
1328 
1329 (defcustom tabbar-buffer-groups-function
1330   'tabbar-buffer-groups
1331   "*Function that gives the group names a buffer belongs to.
1332 That function is passed a buffer and must return a list of group
1333 names, or nil if the buffer has no group.
1334 Notice that it is better that a buffer belongs to one group."
1335   :group 'tabbar
1336   :type 'function)
1337 
1338 (defun tabbar-buffer-list ()
1339   "Return the list of buffers to show in tabs.
1340 Exclude buffers whose name starts with a space, when they are not
1341 visiting a file."
1342   (delq t
1343         (mapcar #'(lambda (b)
1344                     (cond
1345                      ((buffer-file-name b) b)
1346                      ((char-equal ?\  (aref (buffer-name b) 0)))
1347                      (b)))
1348                 (buffer-list))))
1349 
1350 (defun tabbar-buffer-groups (buffer)
1351   "Return the list of group names BUFFER belongs to.
1352 Return only one group for each buffer."
1353   (with-current-buffer (get-buffer buffer)
1354     (cond
1355      ((or (get-buffer-process (current-buffer))
1356           (memq major-mode
1357                 '(comint-mode compilation-mode)))
1358       '("Process")
1359       )
1360      ((member (buffer-name)
1361               '("*scratch*" "*Messages*"))
1362       '("Common")
1363       )
1364      ((eq major-mode 'dired-mode)
1365       '("Dired")
1366       )
1367      ((memq major-mode
1368             '(help-mode apropos-mode Info-mode Man-mode))
1369       '("Help")
1370       )
1371      ((memq major-mode
1372             '(rmail-mode
1373               rmail-edit-mode vm-summary-mode vm-mode mail-mode
1374               mh-letter-mode mh-show-mode mh-folder-mode
1375               gnus-summary-mode message-mode gnus-group-mode
1376               gnus-article-mode score-mode gnus-browse-killed-mode))
1377       '("Mail")
1378       )
1379      (t
1380       (list
1381        (if (and (stringp mode-name) (string-match "[^ ]" mode-name))
1382            mode-name
1383          (symbol-name major-mode)))
1384       )
1385      )))
1386 
1387 ;;; Group buffers in tab sets.
1388 ;;
1389 (defun tabbar-buffer-cleanup-tabsets (buffers)
1390   "Remove obsolete tabs from existing tab sets.
1391 That is tabs whose value is a killed buffer or a buffer not in
1392 BUFFERS.  Delete tab sets that no more contain tabs."
1393   (mapc 'tabbar-delete-tabset
1394         (tabbar-map-tabsets
1395          #'(lambda (tabset)
1396              (mapc #'(lambda (tab)
1397                        (let ((b (get-buffer (tabbar-tab-value tab))))
1398                          (unless (and b (memq b buffers))
1399                            (tabbar-delete-tab tab))))
1400                    (tabbar-tabs tabset))
1401              (unless (tabbar-tabs tabset)
1402                tabset)))))
1403 
1404 (defun tabbar-buffer-update-groups ()
1405   "Update group of buffers.
1406 Return the the first group where the current buffer is."
1407   ;; Ensure that the current buffer will always have a tab!
1408   (let ((buffers (cons (current-buffer)
1409                        (funcall tabbar-buffer-list-function)))
1410         current-group)
1411     (mapc
1412      #'(lambda (buffer)
1413          (let* ((name (buffer-name buffer))
1414                 (groups (funcall tabbar-buffer-groups-function name)))
1415            (when (eq buffer (current-buffer))
1416              (setq current-group (car groups)))
1417            (mapc #'(lambda (group)
1418                      (let ((tabset (tabbar-get-tabset group)))
1419                        (if tabset
1420                            (tabbar-add-tab tabset name t)
1421                          (tabbar-make-tabset group name))))
1422                  groups)))
1423      buffers)
1424     (tabbar-buffer-cleanup-tabsets buffers)
1425     current-group))
1426 
1427 ;;; Tab bar callbacks
1428 ;;
1429 (defvar tabbar-buffer-group-mode nil
1430   "Display tabs for group of buffers, when non-nil.")
1431 (make-variable-buffer-local 'tabbar-buffer-group-mode)
1432 
1433 (defun tabbar-buffer-tabs ()
1434   "Return the buffers to display on the tab bar, in a tab set."
1435   (let ((group (tabbar-buffer-update-groups))
1436         (buffer (buffer-name))
1437         tabset curtab)
1438     (if tabbar-buffer-group-mode
1439         (progn
1440           (setq tabset (tabbar-get-tabsets-tabset)
1441                 curtab (tabbar-selected-tab (tabbar-current-tabset)))
1442           (unless (and (equal buffer (tabbar-tab-value curtab))
1443                        (tabbar-select-tab curtab tabset))
1444             (tabbar-select-tab-value buffer tabset)))
1445       (setq tabset (tabbar-tab-tabset tabbar-last-selected-tab))
1446       (unless (and tabset (tabbar-get-tab buffer tabset))
1447         (setq tabset (tabbar-get-tabset group)))
1448       (tabbar-select-tab-value buffer tabset))
1449     tabset))
1450 
1451 (defun tabbar-buffer-tab-label (tab)
1452   "Return the label to display TAB.
1453 Must be a valid `header-line-format' template element."
1454   (if tabbar-buffer-group-mode
1455       (format "[%s]" (tabbar-tab-tabset tab))
1456     (if tabbar-speedkey-use
1457 	(format " %s%s " (tabbar-speedkey-key tab) (tabbar-tab-value tab))
1458 	(format " %s " (tabbar-tab-value tab)))
1459     ))
1460 
1461 (defun tabbar-buffer-help-on-tab (tab)
1462   "Return the help string shown when mouse is onto TAB."
1463   (if tabbar-buffer-group-mode
1464       "mouse-1: switch to selected tab in group"
1465     "\
1466 mouse-1: switch to buffer, \
1467 mouse-2: kill buffer, \
1468 mouse-3: popup context menu"
1469     ))
1470 
1471 (defun tabbar-buffer-select-tab (event tab)
1472   "On mouse EVENT, select TAB."
1473   (let ((mouse-button (event-basic-type event))
1474         (buffer (tabbar-tab-value tab)))
1475     (cond
1476      ((eq mouse-button 'mouse-1)
1477       (switch-to-buffer buffer))
1478      ((eq mouse-button 'mouse-2)
1479       (kill-buffer buffer))
1480      ((eq mouse-button 'mouse-3)
1481       (tabbar-tab-popup)))
1482     ;; Disable group mode.
1483     (setq tabbar-buffer-group-mode nil)
1484     ))
1485 
1486 (defun tabbar-buffer-toggle-group-mode (event)
1487   "On mouse EVENT, toggle group mode.
1488 When enabled, display tabs for group of buffers, instead of buffer
1489 tabs."
1490   (setq tabbar-buffer-group-mode (not tabbar-buffer-group-mode)))
1491 
1492 (defun tabbar-buffer-toggle-group-mode-help ()
1493   "Return the help string shown when mouse is onto the toggle button."
1494   (if tabbar-buffer-group-mode
1495       "mouse-1: show buffers in selected group"
1496     "mouse-1: show groups of buffers"
1497     ))
1498 
1499 (defun tabbar-sorted-tabs (tabset key)
1500   "Return the list of sorted tabs in TABSET, compared with KEY
1501 function. KEY may be 'tabbar-tab-value or 'tabbar-tab-tabset."
1502   (sort (copy-seq (tabbar-tabs tabset))
1503 	(lambda (a b)
1504 	  (string< (funcall key a) (funcall key b)))))
1505 
1506 (defun tabbar-tab-menu (tabset)
1507   "Return the menu list of tabs in TABSET."
1508   (mapcar
1509    (lambda (tab)
1510      (vector (tabbar-tab-value tab)
1511 	     `(tabbar-click-on-tab ',tab)))
1512    (tabbar-sorted-tabs tabset 'tabbar-tab-value)))
1513 
1514 (defun tabbar-tabgroup-menu ()
1515   "Return the menu list of tabsets."
1516   (mapcar
1517    (lambda (tab)
1518      (cons (format "%s" (tabbar-tab-tabset tab))
1519 	   (cons (vector "<<group>>"
1520 			 `(tabbar-click-on-tab ',tab))
1521 		 (tabbar-tab-menu (tabbar-tab-tabset tab)))))
1522    (tabbar-sorted-tabs (tabbar-get-tabsets-tabset) 'tabbar-tab-tabset)))
1523 
1524 (defun tabbar-tab-popup ()
1525   "Popup a tab context menu."
1526   (interactive)
1527   (popup-menu
1528    `("Tabbar"
1529      ("Quick Switch" .
1530       ,(tabbar-tab-menu (tabbar-current-tabset)))
1531      ("Switch To" .
1532       ,(tabbar-tabgroup-menu))
1533      )))
1534 
1535 (defun tabbar-speedkey-key (tab)
1536   "Return the speedkey of tab."
1537   (let ((idx (position tab (tabbar-tabs (tabbar-tab-tabset tab)))))
1538     (cond
1539      ((and (>= idx 0)
1540 	   (<= idx 8))
1541       (format "%d'" (1+ idx)))
1542      ((= idx 9)
1543       "0)")
1544      ((and (>= idx 10)
1545 	   (<= idx 35))
1546       (format "%c'" (+ (- idx 10) ?a)))
1547      (t
1548       ""))))
1549 
1550 (defun tabbar-speedkey-handler ()
1551   "Handler of tabbar speedkey."
1552   (interactive)
1553   (let (idx tab)
1554     (cond
1555      ((and (>= last-input-char ?1)
1556 	   (<= last-input-char ?9))
1557       (setq idx (- last-input-char ?1))) ; '1'~'9' -> 0~8
1558      ((= last-input-char ?0)
1559       (setq idx 9))			; '0' -> 9
1560      ((and (>= last-input-char ?a)
1561 	   (<= last-input-char ?z))
1562       (setq idx (+ 10 (- last-input-char ?a)))) ; 'a'~'z' -> 10~35
1563      (t
1564       (error "Unsupport speedkey")))
1565     (setq tab (elt (tabbar-tabs tabbar-current-tabset) idx))
1566     (when tab
1567       (tabbar-click-on-tab tab))))
1568 
1569 (defun tabbar-speedkey-install ()
1570   "Install speedkey."
1571   (when (and tabbar-speedkey-use
1572 	     tabbar-speedkey-prefix)
1573     (setq tabbar-speedkey-map (make-sparse-keymap))
1574     (dolist (k (append (number-sequence ?0 ?9) (number-sequence ?a ?z)))
1575       (define-key tabbar-speedkey-map (char-to-string k) 'tabbar-speedkey-handler))
1576     (global-set-key tabbar-speedkey-prefix tabbar-speedkey-map)
1577     ))
1578 
1579 (defun tabbar-speedkey-uninstall ()
1580   "Uninstall speedkey."
1581   (and tabbar-speedkey-use
1582        tabbar-speedkey-prefix
1583        (global-unset-key tabbar-speedkey-prefix)))
1584 
1585 (provide 'tabbar)
1586 
1587 ;;; tabbar.el ends here

Attached Files

To refer to attachments on a page, use attachment:filename, as shown below in the list of files. Do NOT use the URL of the [get] link, since this is subject to change and can break easily.
  • [get | view] (2021-05-11 08:52:08, 55.2 KB) [[attachment:tabbar.el]]
 All files | Selected Files: delete move to page copy to page

You are not allowed to attach a file to this page.