Skip to content
This repository
tree: 9dab2c8efe
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 928 lines (824 sloc) 33.607 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927
;; -*-no-byte-compile: t; -*-
;; Aquamacs-tabbar.el --- "Look and feel" improvements to tabbar.el. Uses
;; Window Tabs by default: Tab-set is specific to each window, and tabbar
;; is hidden when only a single tab exists for that window.

;; Author: Nathaniel Cunningham <nathaniel.cunningham@gmail.com>
;; Maintainer: Nathaniel Cunningham <nathaniel.cunningham@gmail.com>
;; Created: February 2008
;; (C) Copyright 2008, the Aquamacs Project
;; Revision: $Id: aquamacs-tabbar.el,v 1.53 2009/03/11 16:46:00 davidswelt Exp $

;; load original tabbar-mode

(require 'tabbar)
(require 'aquamacs-tools)


;; check version of tabbar
(unless (and (boundp 'tabbar-version)
(string< "1.9999" tabbar-version))
  (message "Tabbar version too low. Uninstall %s."
(locate-library "tabbar"))
  (let ((load-path (list default-directory)))
    (load "tabbar/tabbar.el")))

(when (and (boundp 'tabbar-version)
(not (equal "2.0" tabbar-version)))
  (message "Warning: possibly incompatible tabbar version installed in %s."
(locate-library "tabbar")))


;; modify various settings:
;; eliminate gap between header-line and toolbar
;; save current value of tool-bar-border,
;; to reset when tabbar-mode is turned off
(add-hook 'tabbar-init-hook (lambda ()
(setq tool-bar-border-saved tool-bar-border
tool-bar-border 0)))
(add-hook 'tabbar-quit-hook (lambda ()
(setq tool-bar-border tool-bar-border-saved
tool-bar-border-saved nil)))

;; improve tabbar-selected-tab such that it defaults to (tabbar-current-tabset)
;; if no tabset is passed
(defsubst tabbar-selected-tab (&optional tabset)
  "Return the tab selected in TABSET. If no TABSET is specified,
use (tabbar-current-tabset)."
  (get (or tabset (tabbar-current-tabset) (tabbar-current-tabset t)) 'select))

(defvar tabbar-close-tab-function nil
  "Function to call to close a tabbar tab. Passed a single argument, the tab
construct to be closed.")

(defvar tabbar-new-tab-function nil
  "Function to call to create a new buffer in tabbar-mode. Optional single
argument is the MODE for the new buffer.")
  
;; for buffer tabs, use the usual command to close/kill a buffer
(defun tabbar-buffer-close-tab (tab)
  (let ((buffer (tabbar-tab-value tab))
(one-buffer-one-frame nil))
    (with-current-buffer buffer
      (close-current-window-asktosave))))

(setq tabbar-close-tab-function 'tabbar-window-close-tab)

(defun tabbar-close-tab (&optional tab)
  "Generic function to close a tabbar tab. Calls function named in
tabbar-close-tab-function. Passes a single argument: the tab construct
to be closed. If no tab is specified, (tabbar-selected-tab) is used"
  (interactive)
  (let ((thetab (or tab (tabbar-selected-tab))))
    (funcall tabbar-close-tab-function thetab)))


;; change faces for better-looking tabs (and more obvious selected tab!)
;; full face specification to avoid inheriting from the frame font
;; or from mode-line
(set-face-attribute 'tabbar-default nil
:inherit nil
:height 110
:weight 'normal
:width 'normal
:slant 'normal
:underline nil
:strike-through nil
;; inherit from frame :inverse-video
:stipple nil
:background "gray80"
:foreground "black"
;; :box '(:line-width 2 :color "white" :style nil)
:box nil
:family "Lucida Grande")

(set-face-attribute 'tabbar-selected nil
:background "gray95"
:foreground "gray20"
:inherit 'tabbar-default
:box '(:line-width 3 :color "grey95" :style nil))
;; :box '(:line-width 2 :color "white" :style released-button))

(set-face-attribute 'tabbar-unselected nil
:inherit 'tabbar-default
:background "gray80"
:box '(:line-width 3 :color "grey80" :style nil))

(defface tabbar-selected-highlight '((t
:foreground "black"
:background "gray95"))
  "Face for selected, highlighted tabs."
  :group 'tabbar)

(defface tabbar-unselected-highlight '((t
                    :foreground "black"
:background "grey75"
:box (:line-width 3 :color "grey75" :style nil)))
  "Face for unselected, highlighted tabs."
  :group 'tabbar)

(set-face-attribute 'tabbar-button nil
:inherit 'tabbar-default
:box nil)

(set-face-attribute 'tabbar-separator nil
:background "grey50"
  :foreground "grey50"
:height 1.0)

(setq tabbar-separator '(1)) ;; set tabbar-separator size to 1 pixel

(defface tabbar-selected-modified
  '((t
     :inherit tabbar-selected
     :weight bold
     :height 110
     ))
  "Face used for unselected tabs."
  :group 'tabbar)

(defface tabbar-unselected-modified
  '((t
     :inherit tabbar-unselected
     :weight bold
     :height 110
     ))
  "Face used for unselected tabs."
  :group 'tabbar)

(defface tabbar-key-binding '((t
:foreground "white"))
    "Face for unselected, highlighted tabs."
    :group 'tabbar)


;; do not let color themes override tabbar faces
(aquamacs-set-defaults '((color-theme-illegal-faces "^\\(w3-\\|tabbar-\\)")))


  ;; you may redefine these:
(defvar tabbar-key-binding-modifier-list '(alt)
  "List of modifiers to be used for keys bound to tabs.
Must call `tabbar-define-access-keys' or toggle `tabbar-mode' for
changes to this variable to take effect.")

(defvar tabbar-key-binding-keys '((49 kp-1) (50 kp-2) (51 kp-3) (52 kp-4) (53 kp-5) (54 kp-6) (55 kp-7) (56 kp-8) (57 kp-9) (48 kp-0))
  "Codes of ten keys bound to tabs (without modifiers.
This is a list with 10 elements, one for each of the first 10
tabs. Each element is a list of keys, either of which can be
used in conjunction with the modifiers defined in
`tabbar-key-binding-modifier-list'. Must call
`tabbar-define-access-keys' or toggle `tabbar-mode' for changes
to this variable to take effect.")

(defsubst tabbar-key-command (index) ; command name
  (intern (format "tabbar-select-tab-%s" index)))

(eval-when-compile (require 'cl))
(defun tabbar-define-access-keys (&optional modifiers keys)
  "Set tab access keys for `tabbar-mode'.
MODIFIERS as in `tabbar-key-binding-modifier-list', and
KEYS defines the elements to use for `tabbar-key-binding-keys'."
  (if modifiers (setq tabbar-key-binding-modifier-list modifiers))
  (if keys (setq tabbar-key-binding-keys keys))
  (loop for keys in tabbar-key-binding-keys
for ni from 1 to 10 do
(let ((name (tabbar-key-command ni)))
(eval `(defun ,name ()
"Select tab in selected window."
(interactive)
(tabbar-select-tab-by-index ,(- ni 1))))
;; store label in property of command name symbol
(put name 'label
(format "%c" (car keys)))
(loop for key in keys do
(define-key tabbar-mode-map
(vector (append
tabbar-key-binding-modifier-list
(list key)))
name)))))
 
(defun tabbar-select-tab-by-index (index)
  ;; (let ((vis-index (+ index (or (get (tabbar-current-tabset) 'start) 0))))
  (unless (> (length (tabbar-tabs (tabbar-current-tabset))) 1)
    ;; better window (with tabs)in this frame?

    (let ((better-w))
      (walk-windows (lambda (w)
(and (not better-w)
(with-selected-window w
(if (> (length (tabbar-tabs (tabbar-current-tabset t))) 1)
(setq better-w w)))))
'avoid-minibuf (selected-frame))
      (if better-w (select-window better-w))))
     
  (tabbar-window-select-a-tab
   (nth index (tabbar-tabs (tabbar-current-tabset)))))

(defun tabbar-window-select-a-tab (tab)
  "Select TAB"
  (let ((one-buffer-one-frame nil)
(buffer (tabbar-tab-value tab)))
    (when buffer
      
      (set-window-dedicated-p (selected-window) nil)
      (let ((prevtab (tabbar-get-tab (window-buffer (selected-window))
(tabbar-tab-tabset tab)))
(marker (cond ((bobp) (point-min-marker))
((eobp) (point-max-marker))
(t (point-marker)))))
(set-marker-insertion-type marker t)
(assq-set prevtab marker
'tab-points))
      (switch-to-buffer buffer)
      (let ((new-pt (cdr (assq tab tab-points))))
(and new-pt
(eq (marker-buffer new-pt) (window-buffer (selected-window)))
(let ((pos (marker-position new-pt)))
(unless (eq pos (point))
(if transient-mark-mode
(deactivate-mark))
(goto-char pos))
(set-marker new-pt nil) ;; delete marker
))))))
; (marker-insertion-type (cdr (car tab-points)))


;; function for closing a tab via context menu. Kills buffer if doesn't
;; appear in other tabs.
(defun tabbar-close-clicked-tab (event)
  (interactive "@e")
  (when (tabbar-click-p event)
    (let* ((clicklocation (posn-string (event-start event)))
(clickedtab (get-text-property (cdr clicklocation)
'tabbar-tab (car clicklocation))))
      (save-current-buffer
;; (tabbar-window-close-tab clickedtab)))))
(tabbar-close-tab clickedtab)))))

;; function for closing all other tabs via context menu
(defun tabbar-close-other-tabs (event)
  "Close all tabs except the one where context menu was generated via click"
  (interactive "@e")
  (when (tabbar-click-p event)
    (let* ((clicklocation (posn-string (event-start event)))
(clickedtab (get-text-property (cdr clicklocation)
'tabbar-tab (car clicklocation)))
(tablist (tabbar-tabs (tabbar-tab-tabset clickedtab))))
; (save-current-buffer
(dolist (thistab tablist (tabbar-tab-value clickedtab))
(unless (equal thistab clickedtab)
;; (tabbar-window-close-tab thistab))))));)
(tabbar-close-tab thistab))))))

;; function for removing a tab via context menu, without killing buffer
(defun tabbar-delete-clicked-tab (event)
  (interactive "@e")
  (when (tabbar-click-p event)
    (let* ((clicklocation (posn-string (event-start event)))
(clickedtab (get-text-property (cdr clicklocation)
'tabbar-tab (car clicklocation))))
;; (save-current-buffer
;; (tabbar-window-close-tab clickedtab)))))
(tabbar-window-delete-tab clickedtab))))

(defun tabbar-delete-current-tab ()
  "Delete the current tab."
  (interactive)
  (if tabbar-mode
      (tabbar-window-delete-tab (tabbar-selected-tab))
    (delete-window)))

;; function to open a new tab, suppressing new frame creation
(defun tabbar-new-tab (&optional mode)
  "Creates a new tab, containing an empty buffer (with major-mode MODE
if specified), in current window."
  (interactive)
  (let ((one-buffer-one-frame nil))
    (new-empty-buffer nil mode)))

(setq tabbar-new-tab-function 'tabbar-new-tab)

;; function for duplicating an existing tab in a new frame
(defun tabbar-new-frame-with-clicked-buffer (event)
  (interactive "@e")
  (when (tabbar-click-p event)
    (let* ((clicklocation (posn-string (event-start event)))
(clickedtab (get-text-property (cdr clicklocation)
'tabbar-tab (car clicklocation)))
(buffer (tabbar-tab-value clickedtab)))
      (with-current-buffer buffer
(make-frame-command)))))

;; Opens clicked tab in a new frame, and deletes clicked tab
;; This function/implementation is specific to `window tabs' -- can't be done
;; with `buffer tabs'
(defun tabbar-move-clicked-buffer-to-new-frame (event)
  (interactive "@e")
  (when (tabbar-click-p event)
    (let* ((clicklocation (posn-string (event-start event)))
(clickedtab (get-text-property (cdr clicklocation)
'tabbar-tab (car clicklocation)))
(buffer (tabbar-tab-value clickedtab))
(wnumber (string-to-number (symbol-name (tabbar-tab-tabset tab))))
(wind (window-number-get-window wnumber)))
      (with-current-buffer buffer
(make-frame-command))
      (with-selected-window wind
(tabbar-close-tab clickedtab)))))

(defun tabbar-move-current-buffer-to-new-frame ()
  (interactive)
  (let* ((tab (tabbar-selected-tab (tabbar-current-tabset t)))
(buffer (tabbar-tab-value tab))
(wnumber (string-to-number (symbol-name (tabbar-tab-tabset tab))))
(wind (window-number-get-window wnumber)))
    (with-current-buffer buffer
(make-frame-command))
    (with-selected-window wind
(tabbar-close-tab tab))))

;; keymap for tabbar context menu
(defvar tabbar-context-menu-map
  (let ((map (make-sparse-keymap)))
    (define-key map [removetab] (cons "Hide Tab" 'tabbar-delete-clicked-tab))
    (define-key map [duptab]
      (cons "Duplicate Tab in New Frame" 'tabbar-new-frame-with-clicked-buffer))
    (define-key map [movetab]
      (cons "Move Tab to New Frame" 'tabbar-move-clicked-buffer-to-new-frame))
    (define-key map [closeothers] (cons "Close Other Tabs" 'tabbar-close-other-tabs))
    (define-key map [closetab] (cons "Close Tab" 'tabbar-close-clicked-tab))
    (define-key map [newtab] (cons "New Buffer in New Tab" 'tabbar-new-tab))
    map) "Keymap for the Tabbar context menu.")

;; keymap for tabbar context menu
(defvar tabbar-empty-context-menu-map
  (let ((map (make-sparse-keymap)))
    (define-key map [mergetabs] (cons "Merge All Windows" 'tabbar-window-merge-windows))
    (define-key map [newtab] (cons "New Buffer in New Tab" 'tabbar-new-tab))
    map) "Keymap for the context menu of the empty portion of tab bar.")

;; modify hints to give only the buffer name
(defun tabbar-buffer-help-on-tab (tab)
  "Return the help string shown when mouse is onto TAB."
  (if tabbar--buffer-show-groups
      (let* ((tabset (tabbar-tab-tabset tab))
             (tab (tabbar-selected-tab tabset)))
        (format "click: switch to buffer %S in group [%s]"
                (buffer-name (tabbar-tab-value tab)) tabset))
    (format "%s"
            (buffer-name (tabbar-tab-value tab)))
    ))

;; provide new actions for middle-click/right-click on tabs
(defun tabbar-buffer-select-tab (event tab &optional prefix)
  "On mouse EVENT, select TAB."
  (let ((mouse-button (event-basic-type event))
(one-buffer-one-frame nil)
        (buffer (tabbar-tab-value tab)))
    (cond
     ((eq mouse-button 'mouse-3)
      (popup-menu tabbar-context-menu-map event prefix))
     (t
      (switch-to-buffer buffer)))
    ;; Don't show groups.
    (tabbar-buffer-show-groups nil)
    ))

(defsubst tabbar-normalize-image (image &optional margin nomask)
  "Make IMAGE centered and transparent.
If optional MARGIN is non-nil, it must be a number of pixels to add as
an extra margin around the image. If optional NOMASK is non-nil, no mask
property is included."
  (let ((plist (cdr image)))
    (or (plist-get plist :ascent)
        (setq plist (plist-put plist :ascent 'center)))
    (or (plist-get plist :mask)
        (unless nomask
(setq plist (plist-put plist :mask '(heuristic t)))))
    (or (not (natnump margin))
        (plist-get plist :margin)
        (plist-put plist :margin margin))
    (setcdr image plist))
  image)

;; use images for tabbar buttons
(defun tabbar-button-label (name)
 ;; redefine tabbar-button-label to eliminate 1-pixel border around images
  "Return a label for button NAME.
That is a pair (ENABLED . DISABLED), where ENABLED and DISABLED are
respectively the appearance of the button when enabled and disabled.
They are propertized strings which could display images, as specified
by the variable `tabbar-NAME-button'."
  (let* ((btn (symbol-value
               (intern-soft (format "tabbar-%s-button" name))))
         (on (tabbar-find-image (cdar btn)))
         (off (and on (tabbar-find-image (cddr btn)))))
    (when on
      (tabbar-normalize-image on 0 t)
      (if off
          (tabbar-normalize-image off 0 t)
        ;; If there is no disabled button image, derive one from the
        ;; button enabled image.
        (setq off (tabbar-disable-image on))))
    (cons
     (propertize (or (caar btn) " ") 'display on)
     (propertize (or (cadr btn) " ") 'display off))))

(defun tabbar-buffer-button-label (name)
 ;; redefine tabbar-buffer-button-label to eliminate 1-pixel border around images
  "Return a label for button NAME.
That is a pair (ENABLED . DISABLED), where ENABLED and DISABLED are
respectively the appearance of the button when enabled and disabled.
They are propertized strings which could display images, as specified
by the variable `tabbar-button-label'.
When NAME is 'home, return a different ENABLED button if showing tabs
or groups. Call the function `tabbar-button-label' otherwise."
  (let ((lab (tabbar-button-label name)))
    (when (eq name 'home)
      (let* ((btn tabbar-buffer-home-button)
             (on (tabbar-find-image (cdar btn)))
             (off (tabbar-find-image (cddr btn))))
        ;; When `tabbar-buffer-home-button' does not provide a value,
        ;; default to the enabled value of `tabbar-home-button'.
        (if on
            (tabbar-normalize-image on 0 t)
          (setq on (get-text-property 0 'display (car lab))))
        (if off
            (tabbar-normalize-image off 0 t)
          (setq off (get-text-property 0 'display (car lab))))
        (setcar lab
                (if tabbar--buffer-show-groups
                    (propertize (or (caar btn) (car lab)) 'display on)
                  (propertize (or (cadr btn) (car lab)) 'display off)))
        ))
    lab))

(setq tabbar-home-button-enabled-image
  '((:type png :file "down.png")))

(setq tabbar-home-button-disabled-image
  '((:type png :file "up.png")))

(setq tabbar-home-button
  (cons (cons "[o]" tabbar-home-button-enabled-image)
        (cons "[x]" tabbar-home-button-disabled-image)))

(setq tabbar-buffer-home-button
  (cons (cons "[+]" tabbar-home-button-enabled-image)
        (cons "[-]" tabbar-home-button-disabled-image)))

(setq tabbar-scroll-left-button-enabled-image
  '((:type tiff :file "left.tiff")))

(setq tabbar-scroll-left-button-disabled-image
  '((:type tiff :file "left_disabled.tiff")))

(setq tabbar-scroll-left-button
  (cons (cons " <" tabbar-scroll-left-button-enabled-image)
        (cons " =" tabbar-scroll-left-button-disabled-image)))

(setq tabbar-scroll-right-button-enabled-image
  '((:type tiff :file "right.tiff")))

(setq tabbar-scroll-right-button-disabled-image
  '((:type tiff :file "right_disabled.tiff")))

(setq tabbar-scroll-right-button
  (cons (cons " >" tabbar-scroll-right-button-enabled-image)
        (cons " =" tabbar-scroll-right-button-disabled-image)))

(setq tabbar-close-tab-button
      '((:type tiff :file "close-tab.tiff")))

;; allow fast-clicking through lists of tabs
(defsubst tabbar-click-p (event)
  "Return non-nil if EVENT is a mouse click event."
  ;;counts as a click even if it's the last of a double- or triple-click;
  ;;allows fast cycling through tabs with the mouse.
  (and (or
(memq 'click (event-modifiers event))
(memq 'double (event-modifiers event))
(memq 'triple (event-modifiers event)))
       ;; don't count double- or triple-drag events
       (not (memq 'drag (event-modifiers event))))
  )

(defun tabbar-check-overflow (tabset &optional noscroll)
  "Return t if the current tabbar is longer than the header line.
If NOSCROLL is non-nil, exclude the tabbar-scroll buttons in the
check."
  (let ((tabs (tabbar-view tabset))
elts)
    (while tabs
      (setq elts (cons (tabbar-line-tab (car tabs)) elts)
tabs (cdr tabs)))
    (setq elts (nreverse elts))
    (with-temp-buffer
      (let ((truncate-partial-width-windows nil)
(inhibit-modification-hooks t)
deactivate-mark ;; Prevent deactivation of the mark!
start)
(setq truncate-lines nil
buffer-undo-list t)
(apply 'insert (tabbar-dummy-line-buttons noscroll))
(setq start (point))
(delete-region start (point-max))
(goto-char (point-max))
(apply 'insert elts)
(goto-char (point-min))
(> (vertical-motion 1) 0)))))

;; redefine tabbar-click-on-tab with an additional argument that can
;; trigger closing the tab instead of selecting it!
(defsubst tabbar-click-on-tab (tab &optional type action)
  "Handle a mouse click event on tab TAB.
Call `tabbar-select-tab-function' with the received, or simulated
mouse click event, and TAB.
Optional argument TYPE is a mouse click event type (see the function
`tabbar-make-mouse-event' for details)."
  (let* ((mouse-event (tabbar-make-mouse-event type))
(mouse-button (event-basic-type mouse-event)))
    (if (eq action 'close-tab)
(when (and (eq mouse-button 'mouse-1) tabbar-close-tab-function)
(funcall tabbar-close-tab-function tab))
      (when tabbar-select-tab-function
(funcall tabbar-select-tab-function
(tabbar-make-mouse-event type) tab)
(tabbar-display-update)))))

(defun tabbar-select-tab-callback (event)
  "Handle a mouse EVENT on a tab.
Pass mouse click events on a tab to `tabbar-click-on-tab'."
  (interactive "@e")
  (when (tabbar-click-p event)
    (let ((target (posn-string (event-start event))))
      (tabbar-click-on-tab
       (get-text-property (cdr target) 'tabbar-tab (car target))
       event
       (get-text-property (cdr target) 'tabbar-action (car target))))))

(defcustom tabbar-show-key-bindings t
  "Decide whether to number the tabs showing their key bindings."
  :group 'Aquamacs)

(defsubst tabbar-line-tab (tab)
    "Return the display representation of tab TAB.
That is, a propertized string used as an `header-line-format' template
element.
Call `tabbar-tab-label-function' to obtain a label for TAB."
    (let* ((selected-p (tabbar-selected-p tab (tabbar-current-tabset)))
(close-button-image (tabbar-find-image tabbar-close-tab-button))
(mouse-face (if selected-p
'tabbar-selected-highlight
'tabbar-unselected-highlight))

(text-face (if selected-p
'tabbar-selected
'tabbar-unselected))
(close-button
(propertize "[x]"
'tabbar-tab tab
'local-map (tabbar-make-tab-keymap tab)
'tabbar-action 'close-tab
;; 'help-echo 'tabbar-help-on-tab ;; no help echo: it's redundant
'mouse-face mouse-face
'face text-face
'pointer 'arrow
'display (tabbar-normalize-image close-button-image 0 'nomask)))

(display-label
(propertize (if tabbar-tab-label-function
(funcall tabbar-tab-label-function tab)
tab)
'tabbar-tab tab
'local-map (tabbar-make-tab-keymap tab)
;; 'help-echo 'tabbar-help-on-tab ;; no help echo: it's redundant
'mouse-face mouse-face
'face (cond ((and selected-p
(buffer-modified-p (tabbar-tab-value tab)))
'tabbar-selected-modified)
((and (not selected-p)
(buffer-modified-p (tabbar-tab-value tab)))
'tabbar-unselected-modified)
((and selected-p
(not (buffer-modified-p (tabbar-tab-value tab))))
'tabbar-selected)
(t 'tabbar-unselected))
'pointer 'arrow))
(key-label
(if (and tabbar-show-key-bindings (boundp 'tabbar-line-tabs) tabbar-line-tabs)
(let* ((mm (member tab tabbar-line-tabs) )
;; calc position (i.e., like position from cl-seq)
(index (if mm (- (length tabbar-line-tabs) (length mm)))))
(if (and index (fboundp (tabbar-key-command (+ 1 index))))
(propertize
(get (tabbar-key-command (+ 1 index)) 'label)
;(format "%s" (+ 1 index))
'mouse-face mouse-face
;; same mouse-face leads to joint mouse activation for all elements
'face (list 'tabbar-key-binding text-face) ;; does not work
)
"")
) "")))
      (concat close-button display-label key-label tabbar-separator-value)))

(defun tabbar-dummy-line-buttons (&optional noscroll)
  "Return a list of propertized strings for placeholders for the tab bar buttons.
These are used to determine the size of the tab bar -- and hence the enabled/
disabled state of the tab bar buttons -- so they always carry a disabled state.
This avoids an infinite loop. If NOSCROLL is non-nil, exclude the tabbar-scroll
buttons."
  (cons
   (cdr tabbar-home-button-value)
   (unless noscroll
     (list
      (cdr tabbar-scroll-left-button-value)
      (cdr tabbar-scroll-right-button-value)))))

(defun tabbar-line-separator ()
  "Return the display representation of a tab bar separator.
That is, a propertized string used as an `header-line-format' template
element."
  (let ((image (tabbar-find-image (cdr tabbar-separator))))
    ;; Cache the separator display value in variable
    ;; `tabbar-separator-value'.
    (setq tabbar-separator-value
          (cond
           (image
            (propertize " "
                        'face 'tabbar-separator
                        'pointer 'arrow
                        'display (tabbar-normalize-image image)))
           ((numberp (car tabbar-separator))
            (propertize " "
                        'face 'tabbar-separator
                        'pointer 'arrow
                        'display (list 'space
                                       :width (list (car tabbar-separator)))))
           ((propertize (or (car tabbar-separator) " ")
                        'face 'tabbar-separator
                        'pointer 'arrow))))
    ))

(defsubst tabbar-line-buttons (tabset &optional noscroll)
  "Return a list of propertized strings for tab bar buttons.
TABSET is the tab set used to choose the appropriate buttons. If
NOSCROLL is non-nil, exclude the tabbar-scroll buttons."
  (cons
   (if tabbar-home-function
       (car tabbar-home-button-value)
     (cdr tabbar-home-button-value))
   (if noscroll
       (list (propertize " "
                        'face 'tabbar-default
                        'display (list 'space :width (list 8)))
) ;; insert tabbar-separator-value here?
     (list (if (> (tabbar-start tabset) 0)
(car tabbar-scroll-left-button-value)
(cdr tabbar-scroll-left-button-value))
(if (tabbar-check-overflow tabset)
(car tabbar-scroll-right-button-value)
(cdr tabbar-scroll-right-button-value))
tabbar-separator-value))))

(defun tabbar-line-format (tabset)
    "Return the `header-line-format' value to display TABSET."
    (let* ((sel (tabbar-selected-tab tabset))
(tabs (tabbar-view tabset))
(padcolor (tabbar-background-color))
(noscroll t)
(tabbar-line-tabs (tabbar-tabs tabset))
atsel elts scrolled)
      ;; Initialize buttons and separator values.
      (or tabbar-separator-value
(tabbar-line-separator))
      (or tabbar-home-button-value
(tabbar-line-button 'home))
      (or tabbar-scroll-left-button-value
(tabbar-line-button 'scroll-left))
      (or tabbar-scroll-right-button-value
(tabbar-line-button 'scroll-right))
      ;; Make sure we're showing as many tabs as possible. If we're
      ;; not showing the 1st tab, and we're not overflowing the tab
      ;; bar, then scroll backward. If this leads to overflowing the
      ;; tab bar, scroll forward 1 at the end.
      (while (and (> (get tabset 'start) 0)
(not (tabbar-check-overflow tabset)))
(tabbar-scroll tabset -1)
(setq scrolled t))
      ;; if we scrolled until the tabbar overflowed, we went too far.
      ;; Back up 1 slot.
      (when (and scrolled (tabbar-check-overflow tabset))
(tabbar-scroll tabset 1))
      (when (or (> (tabbar-start tabset) 0) (tabbar-check-overflow tabset))
;; not all tabs fit -- include scroll buttons
(setq noscroll nil))
      ;; Track the selected tab to ensure it is always visible.
      (when tabbar--track-selected
(while (not (memq sel tabs))
(tabbar-scroll tabset -1)
(setq tabs (tabbar-view tabset)))
(while (and tabs (not atsel))
(setq elts (cons (tabbar-line-tab (car tabs)) elts)
atsel (eq (car tabs) sel)
tabs (cdr tabs)))
(setq elts (nreverse elts))
;; At this point the selected tab is the last elt in ELTS.
;; Scroll TABSET and ELTS until the selected tab becomes
;; visible.

;; because of the post-hoc scrolling,
;; we can't determine the line index beforehand


(with-temp-buffer
(let ((truncate-partial-width-windows nil)
(inhibit-modification-hooks t)
deactivate-mark ;; Prevent deactivation of the mark!
start)
(setq truncate-lines nil
buffer-undo-list t)
(apply 'insert (tabbar-line-buttons tabset noscroll))
(setq start (point))
(while (and (cdr elts) ;; Always show the selected tab!
(progn
(delete-region start (point-max))
(goto-char (point-max))
(apply 'insert elts)
(goto-char (point-min))
(> (vertical-motion 1) 0)))
(tabbar-scroll tabset 1)
(setq elts (cdr elts)))))
(setq elts (nreverse elts))
(setq tabbar--track-selected nil))
      ;; Format remaining tabs.
      (while tabs
(setq elts (cons (tabbar-line-tab (car tabs)) elts)
tabs (cdr tabs)))
      ;; Cache and return the new tab bar.
      (tabbar-set-template
       tabset
       (list (tabbar-line-buttons tabset noscroll)
(nreverse elts)
(propertize "%-"
'face (list :inherit 'tabbar-default
:background padcolor
:foreground padcolor)
'pointer 'arrow
'local-map (tabbar-make-tab-keymap "empty tab bar"))))
      ))

(defun tabbar-reformat-tabset (tabset)
  (tabbar-set-template tabset nil))

(defun tabbar-reformat-all-tabsets ()
  (tabbar-map-tabsets 'tabbar-reformat-tabset))
   

;; to do:
;; tabbar-expand should really be done in `tabbar-line-tab' or afterwards,
;; because only then do we know how wide (in pixels) the tab is going to be
;; as it stands, we're duplicating some functions (buffer-modified check, e.g.)
;; and we're just guessing what face is going to be used.

(defvar tabbar-char-width 5)
;; (defun tabbar-char-width (&optional tab)
;; "Big Hack."
;; ;; average width of Lucida Grande character. Hack!
;; (if (and tab (buffer-modified-p (tabbar-tab-value tab)))
;; 7 ;; in bold
;; 5))

(defun tabbar-expand (str width &optional tab)
    "Return an expanded string from STR that fits in the given display WIDTH.
WIDTH is specified in terms of character display width in the current
buffer; see also `char-width'."

    (let* ((n (length str))
(sw (string-width str))
(el "...")
(ew (string-width el))
(w 0)
(i 0))
      (cond
       ((< sw width)
(let* ((l-l (max 4 (min (- 75 (/ (* tabbar-char-width n) 2) )
(floor (/ (* (frame-char-width)
(- width sw)) 2)))))
(sp-r (propertize
" " 'display
`(space
:width
;; subtract width of numbers
(, (max 4 (- l-l
(if tabbar-show-key-bindings
7 0)))))))
(sp-l (propertize
" " 'display
`(space
:width
;; subtract the width of closer button. hard-coded for speed.
(,(max 4 (- l-l 14)))))))
(concat sp-l str sp-r)))
       (t str))))
          

;; function to unconditionally open a new tab
(defun new-tab (&optional major-mode)
  "Creates a new tab.
Turns on `tabbar-mode'."
  (interactive)
  (tabbar-mode 1)
  (tabbar-new-tab major-mode))
  
(defun new-tab-or-buffer (&optional mode)
  "Calls tabbar-new-tab-function if tabbar-mode is on; otherwise,
creates a new buffer. Mode for new buffer can optionally be specified."
    (interactive)
  (if (and (boundp tabbar-mode) tabbar-mode)
      (funcall tabbar-new-tab-function mode)
    (new-frame-with-new-scratch one-buffer-one-frame mode)))

(defun next-tab-or-buffer ()
  "Call (tabbar-forward) if tabbar-mode is on; otherwise, call (next-buffer)."
  (interactive)
  (if (and (boundp tabbar-mode) tabbar-mode)
      (tabbar-forward)
    (next-buffer)))

(defun previous-tab-or-buffer ()
  "Call (tabbar-forward) if tabbar-mode is on; otherwise, call (next-buffer)."
  (interactive)
  (if (and (boundp tabbar-mode) tabbar-mode)
      (tabbar-backward)
    (previous-buffer)))

;;; Tabbar-Mwheel mode: redefine mwheel actions
;
(defcustom tabbar-mwheel-mode-action nil
 "*Specify the behavior mouse wheel is used in tab bar.
The following options are available:

- `cycle-tabs'
Mouse wheel down/up selects next/previous tab in window's tab set.
- default
Mouse wheel scrolls current buffer."
 :group 'tabbar
 :type '(choice :tag "Mouse wheel in tab bar..."
                (const :tag "Cycles through tabs" cycle-tabs)
                (const :tag "Scrolls current buffer" nil)))

(defun tabbar-mwheel-up-action (event)
 (interactive "@e")
 (if tabbar-mwheel-mode-action
     (tabbar-mwheel-forward-tab event)
   (mwheel-scroll event)))

(defun tabbar-mwheel-down-action (event)
 (interactive "@e")
 (if tabbar-mwheel-mode-action
     (tabbar-mwheel-backward-tab event)
   (mwheel-scroll event)))

(if (get 'mouse-wheel 'event-symbol-elements)
   ;; Use one generic mouse wheel event
   (define-key tabbar-mwheel-mode-map [A-mouse-wheel]
     'tabbar-mwheel-switch-tab)
 ;; Use separate up/down mouse wheel events
 (let ((up (tabbar--mwheel-key tabbar--mwheel-up-event))
(down (tabbar--mwheel-key tabbar--mwheel-down-event)))
   (define-key tabbar-mwheel-mode-map `[header-line ,down]
     'tabbar-mwheel-down-action)
   (define-key tabbar-mwheel-mode-map `[header-line ,up]
     'tabbar-mwheel-up-action)
   (define-key tabbar-mwheel-mode-map `[header-line (control ,down)]
     nil)
   (define-key tabbar-mwheel-mode-map `[header-line (control ,up)]
     nil)
   (define-key tabbar-mwheel-mode-map `[header-line (shift ,down)]
     nil)
   (define-key tabbar-mwheel-mode-map `[header-line (shift ,up)]
     nil)))

;; default tabbar behavior (buffer tabs grouped by major-mode) can be
;; retained by setting tabbar-inhibit-window-tabs to non-nil
;; (unless (and (boundp 'tabbar-inhibit-window-tabs) tabbar-inhibit-window-tabs)
;; ;; changes behavior of "buffer tabs", so that tabs are associated with a
;; ;; window instead of a major mode.
;; (require 'tabbar-window))

;; will have to do a bit more work to make different tabbar styles work smoothly.
;; (i.e., no conditional loading of lisp!)
;; for now, stick with window tabs
(condition-case nil
(require 'tabbar-window)
(error nil))

;; start out with hidden window
(add-hook 'after-init-hook
(lambda ()
(if tabbar-mode
(add-to-list
'header-line-inhibit-window-list
(selected-window))) 'append))


(provide 'aquamacs-tabbar)
Something went wrong with that request. Please try again.