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 <[email protected]>
6 ;; Maintainer: David Ponce <[email protected]>
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.You are not allowed to attach a file to this page.