#234567890123456789012345678901234567890123456789012345678901234567890 package Tk::DynaTabFrame; require 5.008; use Tk; use Tk ':variables'; use Tk::Balloon; use base qw (Tk::Derived Tk::Frame); use vars qw ($VERSION); use strict; use Carp; $VERSION = '0.23'; # # indexes of our tab properties # use constant DTF_IDX_WIDGET => 0; use constant DTF_IDX_CAPTION => 1; use constant DTF_IDX_COLOR => 2; use constant DTF_IDX_ROW => 3; use constant DTF_IDX_COL => 4; use constant DTF_IDX_FRAME => 5; use constant DTF_IDX_WIDTH => 6; use constant DTF_IDX_HEIGHT => 7; use constant DTF_IDX_RAISECOLOR => 8; use constant DTF_IDX_RAISECMD => 9; use constant DTF_IDX_LABEL => 10; use constant DTF_IDX_FLASH_COLOR => 11; use constant DTF_IDX_FLASH_INTVL => 12; use constant DTF_IDX_FLASH_TIME => 13; use constant DTF_IDX_FLASH_ID => 14; use constant DTF_IDX_FLASHED => 15; use constant DTF_IDX_HIDDEN => 16; use constant DTF_IDX_TABTIP => 17; my $close_xpm = << 'end-of-close-xpm'; /* XPM */ static char * close_xpm[] = { "8 8 3 1", " s None c None", ". c #000000000000", "X c #E0E0FFFFE0E0", ".. ..", " .. .. ", " .... ", " .. ", " .. ", " .... ", " .. .. ", ".. .."}; end-of-close-xpm my $close_xpm_6 = << 'end-of-close-xpm-6'; /* XPM */ static char * close_xpm[] = { "6 6 3 1", " s None c None", ". c #000000000000", "X c #E0E0FFFFE0E0", ".. ..", " .... ", " .. ", " .. ", " .... ", ".. ..",}; end-of-close-xpm-6 # # map of tabframe directives based on # tab orientation # use constant DTF_TAB_TABSIDE => 0; use constant DTF_TAB_TABFILL => 1; use constant DTF_TAB_TABANCHOR => 2; use constant DTF_TAB_TABSIZER => 3; use constant DTF_TAB_CLIENTSIDE => 4; my %tabalign = ( # tabframe -side, tabframe -fill, tabframe -anchor, # tabframe sizing option, clientframe -side nw => [ 'top', 'x', 'nw', '-height', 'bottom'], ne => [ 'top', 'x', 'ne', '-height', 'bottom'], sw => [ 'bottom', 'x', 'sw', '-height', 'top'], se => [ 'bottom', 'x', 'se', '-height', 'top'], en => [ 'right', 'y', 'ne', '-width', 'left'], es => [ 'right', 'y', 'se', '-width', 'left'], wn => [ 'left', 'y', 'nw', '-width', 'right'], ws => [ 'left', 'y', 'sw', '-width', 'right'], ); # # bitmaps for border requirements # based on tab orientations # bit 0 => Left # bit 1 => Right # bit 2 => Top # bit 3 => Bottom # 'p' sides are for pseudo tabs # my %borders = qw( nw 7 ne 7 sw 11 se 11 en 14 es 14 wn 13 ws 13 pnw 6 pne 5 psw 10 pse 9 pen 10 pes 6 pwn 9 pws 5 ); # # pack directives for the tab contents # [ closebtn_side, # closebtn_anchor, # button_side, # button_anchor, # pseudo_anchor # tab direction # ] # use constant DTF_ORIENT_CLOSESIDE => 0; use constant DTF_ORIENT_CLOSEANCHOR => 1; use constant DTF_ORIENT_BTNSIDE => 2; use constant DTF_ORIENT_BTNANCHOR => 3; use constant DTF_ORIENT_PSEUDOANCHOR => 4; use constant DTF_ORIENT_DIRECTION => 5; use constant DTF_ORIENT_ALIGN => 6; use constant DTF_ORIENT_DOWNWARD => 7; use constant DTF_MAX_ROWS => 20; use constant DTF_DFLT_TIPTIME => 450; my %taborient = ( 'nw', [ 'right', 'ne', 'right', 's', 'e', 1, 0, 1, ], 'ne', [ 'right', 'ne', 'right', 's', 'w', 1, 0, 1, ], 'sw', [ 'right', 'se', 'right', 'n', 'e', 1, 1, 0, ], 'se', [ 'right', 'se', 'right', 'n', 'w', 1, 1, 0, ], 'en', [ 'top', 'ne', 'top', 's', 's', 0, 0, 0, ], 'es', [ 'top', 'ne', 'top', 's', 'n', 0, 0, 0, ], 'wn', [ 'top', 'nw', 'top', 's', 's', 0, 1, 1, ], 'ws', [ 'top', 'nw', 'top', 's', 'n', 0, 1, 1, ], ); # # page options for Tk::Notebook compatibility # my %page_opts = ( '-tabcolor', DTF_IDX_COLOR, '-raisecolor', DTF_IDX_RAISECOLOR, '-image', '-image', '-label', DTF_IDX_LABEL, '-raisecmd', DTF_IDX_RAISECMD, '-state', '-state', '-tabtip', DTF_IDX_TABTIP, '-hidden', DTF_IDX_HIDDEN ); Tk::Widget->Construct ('DynaTabFrame'); sub Populate { my $this = shift; $this->ConfigSpecs( '-borderwidth' => [['SELF', 'PASSIVE'], 'borderwidth', 'BorderWidth', '1'], '-tabcurve' => [['SELF', 'PASSIVE'], 'tabcurve', 'TabCurve', 2], '-padx' => [['SELF', 'PASSIVE'], 'padx', 'padx', 5], '-pady' => [['SELF', 'PASSIVE'], 'pady', 'pady', 5], # # for Tk::Notebook compatibility # '-tabpadx' => [['SELF', 'PASSIVE'], 'tabpadx', 'tabpadx', 2], '-tabpady' => [['SELF', 'PASSIVE'], 'tabpady', 'tabpady', 2], '-font' => ['METHOD', 'font', 'Font', undef], '-current' => ['METHOD'], '-raised' => ['METHOD'], '-raised_name' => ['METHOD'], '-tabs' => ['METHOD'], '-delay' => [['SELF', 'PASSIVE'], 'delay', 'Delay', '200'], '-raisecmd' => [['SELF', 'PASSIVE'], 'raisecmd', 'RaiseCmd', undef], '-tablock' => [['SELF', 'PASSIVE'], 'tablock', 'tablock', undef], '-tabrotate' => [['SELF', 'PASSIVE'], 'tabrotate', 'tabrotate', 1], '-tabside' => ['METHOD'], '-tabclose' => ['METHOD'], '-tabscroll' => ['METHOD'], '-tabcolor' => [['SELF', 'PASSIVE'], 'tabcolor', 'tabcolor', undef], '-tabtip' => [['SELF', 'PASSIVE'], 'tabtip', 'tabtip', undef], '-tiptime' => ['METHOD'], '-tipcolor' => ['METHOD'], '-textalign' => [['SELF', 'PASSIVE'], 'textalign', 'textalign', 1], '-backpagecolor' => [['SELF', 'PASSIVE'], 'tabcolor', 'tabcolor', undef], '-raisecolor' => [['SELF', 'PASSIVE'], 'raisecolor', 'raisecolor', undef], ); $this->SUPER::Populate(@_); # # set default tab orientation # $this->{Side} = 'nw'; $this->{_tiptime} = DTF_DFLT_TIPTIME; $this->{_tipcolor} = 'white'; # # get tab alignment info # my ($tabside, $tabfill, $tabanchor, $tabsize, $clientside) = @{$tabalign{$this->{Side}}}; # # ButtonFrame is where the tabs are # my $ButtonFrame = $this->{ButtonFrame} = $this->Component( 'Frame' => 'ButtonFrame', -borderwidth => 0, -relief => 'flat', $tabsize => 40, )->pack( -anchor => $tabanchor, -side => $tabside, -fill => $tabfill, ); # # create the frame we return to the app # my $ClientFrame = $this->{ClientFrame} = $this->Component( 'Frame' => 'TabChildFrame', -relief => 'flat', -borderwidth => 0, -height => 60, )->pack( -side => $clientside, -expand => 1, -fill => 'both', ); # # a pseudo-frame used to make the raised tab smoothly connect # to the client frame # my $Connector = $this->Component( 'Frame' => 'Connector', -relief => 'flat' ); # # list of all our current clients # $this->{ClientList} = [ ]; # # a quick lookup by caption # $this->{ClientHash} = {}; # # a quick lookup of row numbers # so a raise() can just move entire rows around # create first empty row # $this->{RowList} = [ [] ]; # # plug into the configure event so we get resizes # $this->{OldWidth} = $ButtonFrame->reqwidth(); $this->{OldHeight} = $ButtonFrame->reqheight(); $this->bind("" => sub { $this->ConfigDebounce; }); # # generate the close button # my $scrwd = $this->screenwidth; $this->{CloseImage} = $this->Pixmap(-data => (($scrwd <= 1024) ? $close_xpm_6 : $close_xpm)); return $this; } sub ConfigDebounce { my ($this) = @_; my $w = $Tk::event->w; my $h = $Tk::event->h; # # only post event if we've changed width/height # return 1 if (($this->{OldWidth} == $w) && ($this->{OldHeight} == $h)); $this->{LastConfig} = Tk::timeofday; $this->{LastWidth} = $w; $this->{LastHeight} = $h; $this->afterCancel($this->{LastAfterID}) if defined($this->{LastAfterID}); $this->{LastAfterID} = $this->after(200, # $this->cget('-delay'), sub { $this->TabReconfig(); delete $this->{LastAfterID}; } ); 1; } sub TabCreate { my ($this, $Caption, $Color, $RaiseColor, $Image, $Text, $RaiseCmd) = @_; # # always add at (0,0) # my $clients = $this->{ClientList}; my $rows = $this->{RowList}; my $ButtonFrame = $this->{ButtonFrame}; # # create some pseudo tabs # note we only create DTF_MAX_ROWS, so if we have > DTF_MAX_ROWS+1 # tab rows, we're in trouble # unless ($this->{PseudoTabs}) { $this->{PseudoTabs} = [ undef ]; push @{$this->{PseudoTabs}}, $this->PseudoCreate($_) foreach (1..DTF_MAX_ROWS); } # # create default colors # $this->configure(-tabcolor => $this->Darken($this->cget(-background), 75)) unless $this->cget(-tabcolor); $this->configure(-raisecolor => $this->Darken($this->cget(-tabcolor), 130)) unless $this->cget(-raisecolor); $RaiseColor = $Color ? $this->Darken($Color, 130) : $this->cget(-raisecolor) unless $RaiseColor; $Color = $this->cget(-tabcolor) unless $Color; $RaiseCmd = $this->cget(-raisecmd) unless $RaiseCmd; # # create a new frame for the caller # my $Widget = $this->{ClientFrame}->Frame( -borderwidth => $this->cget ('-borderwidth'), -relief => 'raised'); # # create a new frame for a tab # my $TabFrame = $ButtonFrame->Component( 'Frame' => 'Button_'.$Widget, -foreground => $this->cget ('-foreground'), -relief => 'flat', -borderwidth => 0, ); $TabFrame->configure(-bg => $Color) if $Color; my $to = $taborient{$this->{Side}}; # # build a close tab for it if requested # my $CloseBtn; $CloseBtn = $TabFrame->Component( 'Button' => 'CloseBtn', -command => [ $this->{Close}, $this, $Caption ], -anchor => $to->[DTF_ORIENT_CLOSEANCHOR], -relief => 'raised', -borderwidth => 1, -takefocus => 1, -padx => 0, -pady => 0, -image => $this->{CloseImage} ) if $this->{Close}; # # build the tab for it; in future we may support images # my $font = $this->cget(-font); $font = $this->parent()->cget(-font) unless $font; my $padx = $this->cget(-tabpadx); my $pady = $this->cget(-tabpady); my $Button = $TabFrame->Component( 'Button' => 'Button', -command => sub { $this->configure (-current => $Widget);}, -anchor => 'center', -relief => 'flat', -borderwidth => 0, -takefocus => 1, -padx => 1, -pady => 1, ); $Button->configure(-bg => $Color); if (defined($Image)) { $Button->configure(-image => $Image); } else { $Button->configure(-font => $font) if $font; $Text = $Caption ||= $Widget->name() unless $Text; # # make it vertical for side tabs # $Button->configure(-text => ($this->cget(-textalign) ? ($to->[DTF_ORIENT_DIRECTION] ? $Text : RotateTabText($Text)) : ($to->[DTF_ORIENT_DIRECTION] ? RotateTabText($Text) : $Text)) ); } $TabFrame->bind('' => sub {$Button->invoke();}); # # someday we'll have to figure out how to configure these # events so rolling into a tab brightens and roling out # darkens...wo/ repeating the event ad nauseum... # # $TabFrame->bind('', [ \&OnEnter, $Button, $TabFrame ]); # $TabFrame->bind('', [ \&OnLeave, $Button, $TabFrame ]); # $Button->bind('', [ \&OnEnter, $Button, $TabFrame ]); # $Button->bind('', [ \&OnLeave, $Button, $TabFrame ]); # $Button->bind('', [ \&OnFocusOut, $TabFrame ]); # $Button->bind('', [ \&OnFocusIn, $TabFrame ]); $Button->bind('', sub {($this->children())[0]->focus();}); $Button->bind ('' => sub {$Button->invoke();}); # # decorate the tab # $this->TabBorder ($TabFrame); my $dark = $Button->Darken($Color, 50); $Button->configure(-highlightthickness => 0, -activebackground => $dark); $CloseBtn->pack( -side => $to->[DTF_ORIENT_CLOSESIDE], -anchor => $to->[DTF_ORIENT_CLOSEANCHOR], -expand => 0, -fill => 'none', -ipadx => 0, -ipady => 0, -padx => 2, -pady => 2, ) if $CloseBtn; $Button->pack( -side => $to->[DTF_ORIENT_BTNSIDE], -anchor => $to->[DTF_ORIENT_BTNANCHOR], -expand => 0, -fill => 'none', -ipadx => 0, -ipady => 0, -padx => $padx, -pady => $pady, ); # # pack tab in our rowframe 0; redraw if needed # move everything over 1 column in bottom row # $clients->[$_][DTF_IDX_COL]++ foreach (@{$rows->[0]}); unshift @{$rows->[0]}, scalar @$clients; # # save the client frame, the caption, the tabcolor, # the current row/column coords of our tab, our tabframe, # and the original height of this tab; we'll be stretching # the button later during redraws # push @$clients, [ $Widget, # our client frame $Caption, # our identifier $Color, # unraised color 0, # row number 0, # column number $TabFrame, # our tab frame ($to->[DTF_ORIENT_DIRECTION] ? # the tab width $Button->reqwidth() : $Button->reqheight() ), ($to->[DTF_ORIENT_DIRECTION] ? # the tab height $Button->reqheight() : $Button->reqwidth() ), $RaiseColor, # raised color $RaiseCmd, # callback for raise operations $Text, # tab label text 1 # start as visible ]; # # reqwidht/height don't seem to include the padx/pady # $$clients[-1][DTF_IDX_HEIGHT] += (2 * ($to->[DTF_ORIENT_DIRECTION] ? $pady : $padx)); $$clients[-1][DTF_IDX_WIDTH] += (2 * ($to->[DTF_ORIENT_DIRECTION] ? $padx : $pady)); # # map the caption to its position in the client list, # so we can raise and delete it by reference # $this->{ClientHash}{$Caption} = $#$clients; # # redraw everything # $this->TabRedraw(1); # # and raise us # $this->TabRaise($Widget); return $Widget; } sub PseudoCreate { my ($this, $row) = @_; # # create a new frame for a pseudotab # my $TabFrame = $this->{ButtonFrame}->Component( 'Frame' => "Pseudo_$row", -foreground => $this->cget ('-foreground'), -relief => 'flat', -borderwidth => 0, ); $TabFrame->Component( 'Label' => 'Button', -text => ' ', -anchor => $taborient{$this->{Side}}[DTF_ORIENT_PSEUDOANCHOR], -relief => 'flat', -borderwidth => 0, -padx => 2, -pady => 2, )->pack( -expand => 0, -fill => 'both', -ipadx => 0, -ipady => 0, -padx => 3, -pady => 3, ); # # decorate the tab # $this->TabBorder ($TabFrame, 1); return $TabFrame; } sub TabRaise { my ($this, $Widget, $silent) = (shift, @_); # # locate the tab row # if its not the first row, then we need to move rows around # and redraw # else just raise it # my $ButtonFrame = $this->{ButtonFrame}; my $TabFrame = $ButtonFrame->Subwidget('Button_'.$Widget); my $rotate = $this->cget(-tabrotate); # # find our client # my $clients = $this->{ClientList}; # # strange timing issue sometimes leaves a null # entry at our tail # pop @$clients unless defined($clients->[-1]); my $client; # # locate the currently raised tab and restore its # unraised color # foreach $client (@$clients) { last unless $this->{Raised}; next unless ($client->[DTF_IDX_WIDGET] eq $this->{Raised}); my $Button = $client->[DTF_IDX_FRAME]->Subwidget('Button'); $client->[DTF_IDX_FRAME]->configure(-bg => $client->[DTF_IDX_COLOR]); $Button->configure(-bg => $client->[DTF_IDX_COLOR], -activebackground => $client->[DTF_IDX_COLOR], ); last; } my $raised = 0; $raised++ while (($raised <= $#$clients) && ($clients->[$raised][DTF_IDX_WIDGET] ne $Widget)); return 1 unless ($raised <= $#$clients); $client = $clients->[$raised]; my ($r, $c) = ($client->[DTF_IDX_ROW], $client->[DTF_IDX_COL]); my $rows = $this->{RowList}; # # undraw the Connector # my $Connector = $this->Subwidget('Connector'); $Connector->placeForget(); # if $Connector->is_mapped; delete $this->{Raised}; if ($rotate) { # # 3 cases: # we're already at row 0, so just raise # else rotate rows off bottom to top until # raised row is bottom row # if ($r != 0) { # # middle row, or last row that fills the frame: # move the preceding to top, and move the selected row # to the bottom # my $rowcnt = $r; push(@$rows, (shift @$rows)), $rowcnt-- while ($rowcnt); # # update client coords # foreach my $i (0..$#$rows) { $clients->[$_][DTF_IDX_ROW] = $i foreach (@{$rows->[$i]}); } $this->TabRedraw; } # # first, lower everything below the raised tab # in row 0 # my $lowest = $raised; my $pseudos = $this->{PseudoTabs}; foreach (@{$rows->[0]}) { $clients->[$_][DTF_IDX_FRAME]->lower($clients->[$lowest][DTF_IDX_FRAME]), $lowest = $_ unless ($_ == $raised); } # # now lower everything below its left neighbor # foreach my $i (1..$#$rows) { $clients->[$_][DTF_IDX_FRAME]->lower($clients->[$lowest][DTF_IDX_FRAME]), $lowest = $_ foreach (@{$rows->[$i]}); } # # now make all pseudos lower # if ($#$rows > 0) { $pseudos->[1]->lower($clients->[$lowest][DTF_IDX_FRAME]); $pseudos->[$_]->lower($pseudos->[$_-1]) foreach (2..$#$rows); } $TabFrame->Subwidget('Button')->raise(); $TabFrame->raise(); } # if rotate $TabFrame->Subwidget('Button')->focus(); # # lower the current frame, and then raise the new one # !!!NOTE: we can't use pack() here, as it tends to # expand the area of our container # $Widget->place(-x => 0, -y => 0, -relheight => 1.0, -relwidth => 1.0); $this->{CurrentFrame} = $Widget; pop @$clients unless defined($clients->[-1]); foreach (0..$#$clients) { $clients->[$_][DTF_IDX_WIDGET]->lower($Widget) if ($clients->[$_] && $clients->[$_][DTF_IDX_WIDGET] && ($clients->[$_][DTF_IDX_WIDGET] ne $Widget)); } my $raisecolor = $client->[DTF_IDX_RAISECOLOR]; # # used to smoothly connect raised tab to client frame # but only if in row 0 # if ($client->[DTF_IDX_ROW] == 0) { $this->update; # make sure the tabs are redrawn my ($connectx, $connectw, $connecty, $connecth); my $horizontal = $taborient{$this->{Side}}[DTF_ORIENT_DIRECTION]; my $inside = $taborient{$this->{Side}}[DTF_ORIENT_ALIGN]; my $extra = $this->{Close} ? 12 : -3; if ($horizontal) { # $connectx = $TabFrame->x + 2; $connectw = $client->[DTF_IDX_WIDTH] + $extra; # # Y location of connector is either at top (for nw/ne) # or bottom (for sw/se) of the client frame # $connecty = $inside ? $this->{ClientFrame}->height() - 2 : # may need to adjust this offset $this->{ClientFrame}->rooty() - $this->rooty() - 7; $connecth = $this->{ClientFrame}->cget(-borderwidth) + 3; } else { # vertical # # if tabs at left, then position at left edge of client # else position at rt edge # $connectx = $inside ? $this->{ClientFrame}->rootx() - $this->rootx() - 8 : $this->{ClientFrame}->width() - 3; # may need to adjust this offset $connectw = $this->{ClientFrame}->cget(-borderwidth) + 3; $connecty = $TabFrame->y + 3; $connecth = $client->[DTF_IDX_WIDTH] + $extra; } $Connector->place( -x => $connectx, -y => $connecty, -height => $connecth, -width => $connectw, -anchor => 'nw', ); $Connector->configure(-background => $raisecolor); $Connector->raise(); } # end if raise in row 0 $this->{Raised} = $Widget; # # turn off flashing # $this->deflash($client->[DTF_IDX_CAPTION]) if $client->[DTF_IDX_FLASH_ID]; # # set raised color # $TabFrame->configure(-background => $raisecolor), $TabFrame->Subwidget('Button')->configure( -bg => $raisecolor, -activebackground => $raisecolor); # # callback if defined && allowed # unless ($silent) { my $raisecb = $client->[DTF_IDX_RAISECMD]; &$raisecb($client->[DTF_IDX_CAPTION]) if ($raisecb && (ref $raisecb) && (ref $raisecb eq 'CODE')); } return $Widget; } # # render tab borders # sub TabBorder { my ($this, $TabFrame, $forpseudo) = @_; my $LineWidth = $this->cget(-borderwidth); my $Background = $this->cget(-background); my $InnerBackground = $TabFrame->Darken($Background, 120), my $Curve = $this->cget (-tabcurve); my $mask = $forpseudo ? $borders{'p' . $this->{Side}} : $borders{$this->{Side}}; # # left border # outer: $TabFrame->Frame( -background => 'white', -borderwidth => 0, )->place( -x => 0, -y => $Curve - 1, -width => $LineWidth, -relheight => 1.0, ), # # inner: $TabFrame->Frame( -background => $InnerBackground, -borderwidth => 0, )->place( -x => $LineWidth, -y => $Curve - 1, -width => $LineWidth, -relheight => 1.0, ) if ($mask & 1); # # right border # outer: $TabFrame->Frame( -background => 'black', -borderwidth => 0, )->place( -x => - ($LineWidth), -relx => 1.0, -width => $LineWidth, -relheight => 1.0, -y => $Curve, ), # # inner: $TabFrame->Frame( -background => $TabFrame->Darken($Background, 80), -borderwidth => 0, )->place( -x => - ($LineWidth * 2), -width => $LineWidth, -relheight => 1.0, -y => $Curve / 2, -relx => 1.0, ) if ($mask & 2); # # top border # outer: $TabFrame->Frame( -background => 'white', -borderwidth => 0, )->place( -x => $Curve - 1, -y => 0, -relwidth => 1.0, -height => $LineWidth, -width => - ($Curve * 2), ), # # inner: $TabFrame->Frame( -background => $InnerBackground, -borderwidth => 0, )->place( -x => $Curve - 1, -y => $LineWidth, -relwidth => 1.0, -height => $LineWidth, -width => - ($Curve * 2), ) if ($mask & 4); # # bottom border # outer: $TabFrame->Frame( -background => $InnerBackground, -borderwidth => 0, )->place( -x => $Curve - 1, # -y => - ($LineWidth), -rely => 1.0, -relwidth => 1.0, -height => $LineWidth, -width => - ($Curve), ), # # inner: $TabFrame->Frame( -background => 'black', -borderwidth => 0, -height => $LineWidth, )->place( -x => $Curve - 1, -y => - ($LineWidth), -rely => 1.0, -relwidth => 1.0, -height => $LineWidth, -width => - ($Curve), ) if ($mask & 8); } sub TabCurrent { return defined ($_[1]) ? $_[0]->TabRaise($_[1]) : $_[0]{Raised}; } # # returns the width of a row # sub GetButtonRowWidth { my ($Width, $this, $row) = (0, shift, shift); return 0 unless ($this->{RowList} && ($#{$this->{RowList}} >= $row)); my $rowlist = $this->{RowList}[$row]; my $tablist = $this->{ClientList}; my $extra = 5 + ($this->{Close} ? 15 : 0); my $horizontal = $taborient{$this->{Side}}[DTF_ORIENT_DIRECTION]; foreach my $Client (@$rowlist) { $Width += $extra + ($tablist->[$Client][DTF_IDX_WIDTH]) if defined($tablist->[$Client]); } return $Width ? $Width - 10 : 0; } # # returns the accumulated height of all our rows # sub GetButtonRowHeight { my ($Height, $this, $row) = (0, shift, shift); return 0 unless ($this->{RowList} && ($#{$this->{RowList}} >= $row)); my $total_ht = 0; $total_ht += $this->GetRowHeight($_) foreach (0..$row); return $total_ht; } # # returns the height of a single row # sub GetRowHeight { my ($Height, $this, $row) = (0, shift, shift); my $ButtonFrame = $this->{ButtonFrame}; return 0 unless ($this->{RowList} && ($#{$this->{RowList}} >= $row)); my $rowlist = $this->{RowList}[$row]; my $tablist = $this->{ClientList}; my $total_ht = 0; my $newht = 0; foreach (@$rowlist) { next unless defined($tablist->[$_]); $newht = $tablist->[$_][DTF_IDX_HEIGHT]; $Height = $newht if ($newht > $Height); } return $Height; } sub Font { my ($this, $Font) = (shift, @_); my $font = $this->{Font}; $font = $this->parent()->cget(-font) unless $font; return ($font) unless (defined ($Font)); my $tablist = $this->{ClientList}; $_->[DTF_IDX_FRAME]->Subwidget('Button')->configure(-font => $Font) foreach (@$tablist); # # we need to redraw, since this may change our tab layout # $this->TabRedraw(1); return ($this->{Font} = $Font); } # # Reconfigure the tabs on resize event # sub TabReconfig { my $this = shift; return 1 if ($this->{Updating} || ($this->cget(-tablock) && (! $this->cget(-tabclose)))); my $buttons = $this->{ButtonFrame}; my $clients = $this->{ClientList}; # # if nothing to draw, then just update context # $this->{OldWidth} = $this->width, $this->{OldHeight} = $this->height, return 1 unless ($#$clients >= 0); # # compute current max row width # compare to current frame width # if maxrow > frame # redraw # elsif maxrow - frame > threshold # redraw # my $rows = $this->{RowList}; my $w = $buttons->width(); my $h = $buttons->height(); my $maxw = 0; foreach (0..$#$rows) { my $rw = $this->GetButtonRowWidth($_); $maxw = $rw if ($maxw < $rw); } # # return unless significantly different from old size # $this->{OldWidth} = $this->width, $this->{OldHeight} = $this->height, return 1 unless (($maxw > $w) || ($w - $maxw > 10)); # # just redraw everything # $this->{Updating} = 1; $this->TabRedraw(1); $this->{Updating} = undef; $this->{OldWidth} = $this->width; $this->{OldHeight} = $this->height; return 1; } # # redraw our tabs # sub TabRedraw { my ($this, $rearrange) = @_; # # compute new display ordering # return 1 unless ($#{$this->{ClientList}} >= 0); my $ButtonFrame = $this->{ButtonFrame}; my $clients = $this->{ClientList}; my $rows = $this->{RowList}; # # if nothing to draw, bail out # return 1 if (($#$rows < 0) || (($#$rows == 0) && ($#{$rows->[0]} < 0))); my $pseudos = $this->{PseudoTabs}; my $pseudoht; my $Raised = $this->{Raised}; # save for later my $roww = 0; my $raised_row = undef; my $horizontal = $taborient{$this->{Side}}[DTF_ORIENT_DIRECTION]; my $alignment = $taborient{$this->{Side}}[DTF_ORIENT_PSEUDOANCHOR]; my $downward = $taborient{$this->{Side}}[DTF_ORIENT_DOWNWARD]; my $extra = $this->{Close} ? 15 : 0; # # tabspace determined based on orientation # my $w = $horizontal ? $ButtonFrame->width() : $ButtonFrame->height(); $w -= 5; if ($rearrange) { # # rearrange tabs to fit new frame width # my @newrows = ([]); my @tclients = (); foreach my $row (@$rows) { foreach (@$row) { my $client = $clients->[$_]; next if $client->[DTF_IDX_HIDDEN]; my $btnw = $extra + $client->[DTF_IDX_WIDTH]; my $row = $#$rows; $roww = 0, push @newrows, [ ] if (($roww + $btnw > $w) && ($#{$newrows[0]} >= 0)); $roww += $btnw; push @{$newrows[-1]}, $_; $tclients[$_] = [ $#newrows, $#{$newrows[-1]} ]; $raised_row = $#newrows if ($Raised && $client->[DTF_IDX_WIDGET] && ($client->[DTF_IDX_WIDGET] eq $Raised)); } } # # if number of rows exceeds our limit # return undef if ($#newrows > DTF_MAX_ROWS); # # save the new row lists # $this->{RowList} = \@newrows; $rows = \@newrows; foreach my $row (@$rows) { $clients->[$_]->[DTF_IDX_ROW] = $tclients[$_][0], $clients->[$_]->[DTF_IDX_COL] = $tclients[$_][1] foreach (@$row); } } # # purge all our pseudotabs # foreach (@$pseudos) { next unless $_; $_->placeForget() if $_->ismapped(); } # # undraw all our buttons # foreach my $i (0..$#$rows) { foreach (@{$rows->[$i]}) { $clients->[$_][DTF_IDX_FRAME]->placeForget() if $clients->[$_][DTF_IDX_FRAME]->ismapped(); } } # # adjust our frame height to accomodate the rows # my $dim = $horizontal ? '-height' : '-width'; $ButtonFrame->configure( $dim => $this->GetButtonRowHeight($#$rows) + ($downward ? 5 : 7)); # # reconfig tabs to match height of tallest tab in row # my @hts = (); push @hts, $this->GetRowHeight($_) foreach (0..$#$rows); # # redraw all our buttons, starting from the top row # note: we force each button to fully fill the button frame; # this improves the visual effect when an upper tab extends # to the right of the end of the row below it # my $Connector = $this->Subwidget('Connector'); $Connector->placeForget(); # if $Connector->is_mapped(); my ($i, $x, $y, $client, $frame); if ($horizontal) { if ($downward) { # # top tabs: # draw from outermost row to innermost # $i = $#$rows; $y = 0; $x = 0; while ($i >= 0) { $x = ($alignment eq 'e') ? 0 : $ButtonFrame->width() - 8; foreach (0..$#{$rows->[$i]}) { $client = $clients->[$rows->[$i][$_]]; $frame = $client->[DTF_IDX_FRAME]; $x -= ($client->[DTF_IDX_WIDTH] + $extra) if ($alignment eq 'w'); $frame->Subwidget('Button')->configure( -height => $hts[$i]); $frame->place( -x => $x, -y => $y, -height => $hts[$i] + 6 ); $x += $client->[DTF_IDX_WIDTH] + $extra if ($alignment eq 'e'); } # # draw pseudotabs if needed # $y = $y + $this->GetRowHeight($i) if $i; $pseudoht = $this->GetButtonRowHeight($i-1) + 6, $pseudos->[$i]->place( -x => 0, -y => $y + 4, -width => $ButtonFrame->width() - 8, -height => $pseudoht) if $i; $i--; } } else { # # bottom tabs: # draw from innermost row to innermost # $i = 0; $y = 0; while ($i <= $#$rows) { $x = ($alignment eq 'e') ? 0 : $ButtonFrame->width() - 8; foreach (0..$#{$rows->[$i]}) { $client = $clients->[$rows->[$i][$_]]; $frame = $client->[DTF_IDX_FRAME]; $x -= ($client->[DTF_IDX_WIDTH] + $extra) if ($alignment eq 'w'); $frame->Subwidget('Button')->configure( -height => $hts[$i]); $frame->place( -x => $x, -y => $y, -height => $hts[$i] + 6 ); $x += $client->[DTF_IDX_WIDTH] + $extra if ($alignment eq 'e'); } # # draw pseudotabs if needed # $pseudoht = $this->GetButtonRowHeight($i-1) + 1, $pseudos->[$i]->place( -x => 0, -y => 0, -width => $ButtonFrame->width() - 8, -height => $pseudoht) if $i; $y = $y + $this->GetRowHeight($i); $i++; } # end while } # end if downward...else... } # end if horizontal else { # vertical tabs if ($downward) { # # left tabs: # draw from outermost row to innermost # $i = $#$rows; $x = 0; while ($i >= 0) { $y = ($alignment eq 's') ? 0 : $ButtonFrame->height() - 8; foreach (0..$#{$rows->[$i]}) { $client = $clients->[$rows->[$i][$_]]; $frame = $client->[DTF_IDX_FRAME]; $y -= ($client->[DTF_IDX_WIDTH] + $extra) if ($alignment eq 'n'); $frame->Subwidget('Button')->configure(-width => $hts[$i]); $frame->place( -x => $x, -y => $y, -width => $hts[$i] + 6 ); $y += $client->[DTF_IDX_WIDTH] + $extra if ($alignment eq 's'); } # # draw pseudotabs if needed # $x += $this->GetRowHeight($i); $pseudoht = $this->GetButtonRowWidth($i-1) + 6, $pseudos->[$i]->place( -x => $x + 4, -y => 0, -width => $pseudoht, -height => $ButtonFrame->height() - 8) if $i; $i--; } } else { # # right tabs: # draw from innermost row to innermost # $i = 0; $x = 0; while ($i <= $#$rows) { $y = ($alignment eq 's') ? 0 : $ButtonFrame->height() - 8; foreach (0..$#{$rows->[$i]}) { $client = $clients->[$rows->[$i][$_]]; $frame = $client->[DTF_IDX_FRAME]; $y -= ($client->[DTF_IDX_WIDTH] + $extra) if ($alignment eq 'n'); $frame->Subwidget('Button')->configure(-width => $hts[$i]); $frame->place( -x => $x, -y => $y, -width => $hts[$i] + 6 ); $y += $client->[DTF_IDX_WIDTH] + $extra if ($alignment eq 's'); } # # draw pseudotabs if needed # $pseudoht = $this->GetButtonRowHeight($i-1), $pseudos->[$i]->place( -x => $x - $pseudoht, -y => 0, -width => $pseudoht + 1, -height => $ButtonFrame->height() - 8) if $i; $x += $this->GetRowHeight($i); $i++; } # end while } # end if downward...else... } # end if horizontal...else... # # and reapply our tab order # $this->TabOrder; # # and reraise in case raised ended up somewhere other than # bottom row # $this->TabRaise($Raised, 1) if $Raised; return 1; } # # remove a single tab and re-org the tabs # sub TabRemove { my ($this, $Caption) = @_; $this->{Updating} = 1; # # remove a tab # return undef unless defined($this->{ClientHash}{$Caption}); my $rows = $this->{RowList}; my $clients = $this->{ClientList}; my $listsz = $#$clients; my $clientno = $this->{ClientHash}{$Caption}; my $client = $clients->[$clientno]; my $Widget = $client->[DTF_IDX_WIDGET]; my ($r, $c) = ($client->[DTF_IDX_ROW], $client->[DTF_IDX_COL]); # # if its the raised widget, then we need to raise # a tab to replace it (unless its the only widget) # ...whatever is left at 0,0 sounds good to me... # my $row = $rows->[$r]; my $newcurrent = ($client->[DTF_IDX_WIDGET] eq $this->{Raised}) ? 1 : undef; # # remove client from lists # delete $this->{ClientHash}{$Caption}; if ($clientno eq $#$clients) { # Perl bug ? we seem to not get spliced out at ends pop @$clients; } else { splice @$clients, $clientno, 1; } splice @$row, $c, 1; # # adjust client positions in this row # $clients->[$row->[$_]][DTF_IDX_COL]-- foreach ($c..$#$row); # # adjust client indices in the hash # foreach (keys %{$this->{ClientHash}}) { $this->{ClientHash}{$_} -= 1 if ($this->{ClientHash}{$_} > $clientno); } # # adjust all our row index lists # foreach my $row (@$rows) { foreach (0..$#$row) { $row->[$_]-- if ($row->[$_] > $clientno); } } my $TabFrame = $client->[DTF_IDX_FRAME]; $TabFrame->packForget(); $TabFrame->destroy(); $Widget->destroy(); # # if only tab in row, remove the row # and adjust the clients in following rows # if ($#$row < 0) { foreach my $i ($r+1..$#$rows) { $row = $rows->[$i]; $clients->[$_][DTF_IDX_ROW] -= 1 foreach (@$row); } splice @$rows, $r, 1; } if ($#$rows < 0) { # # no rows left, clear everything # $this->{Raised} = undef; $this->Subwidget('Connector')->placeForget(); $this->{CurrentFrame} = undef; } elsif ($newcurrent) { $this->{Raised} = $clients->[$rows->[0][0]][DTF_IDX_WIDGET]; } # # redraw everything # $this->TabRedraw(1); $this->{Updating} = undef; # # odd behavior (maybe Resize timing issue): # we occasionally end up with an undef entry at the tail # pop @$clients unless (($listsz - 1) == $#$clients); return 1; } # # reveal a previously hidden tab and re-org the tabs # sub TabReveal { my ($this, $Caption) = @_; $this->{Updating} = 1; return undef unless defined($this->{ClientHash}{$Caption}); my $clients = $this->{ClientList}; my $rows = $this->{RowList}; my $clientno = $this->{ClientHash}{$Caption}; my $client = $clients->[$clientno]; return 1 unless $client->[DTF_IDX_HIDDEN]; # # make visible and redraw; note we don't # make it raised yet # $client->[DTF_IDX_HIDDEN] = undef; # # pack tab in our rowframe 0; redraw if needed # move everything over 1 column in bottom row # $clients->[$_][DTF_IDX_COL]++ foreach (@{$rows->[0]}); unshift @{$rows->[0]}, $clientno; # # redraw everything # $this->TabRedraw(1); $this->{Updating} = undef; # # if nothing is raised, then raise us # $this->raise($Caption) unless $this->{Raised}; return 1; } # # hide a single tab and re-org the tabs # sub TabHide { my ($this, $Caption) = @_; $this->{Updating} = 1; return undef unless defined($this->{ClientHash}{$Caption}); my $rows = $this->{RowList}; my $clients = $this->{ClientList}; my $listsz = $#$clients; my $clientno = $this->{ClientHash}{$Caption}; my $client = $clients->[$clientno]; my $Widget = $client->[DTF_IDX_WIDGET]; my ($r, $c) = ($client->[DTF_IDX_ROW], $client->[DTF_IDX_COL]); # # if its the raised widget, then we need to raise # a tab to replace it (unless its the only widget) # ...whatever is left at 0,0 sounds good to me... # my $row = $rows->[$r]; my $newcurrent = ($client->[DTF_IDX_WIDGET] eq $this->{Raised}) ? 1 : undef; # # hide the client # $client->[DTF_IDX_HIDDEN] = 1; $client->[DTF_IDX_ROW] = undef; $client->[DTF_IDX_COL] = undef; splice @$row, $c, 1; # # adjust client positions in this row # $clients->[$row->[$_]][DTF_IDX_COL]-- foreach ($c..$#$row); # # adjust all our row index lists # # foreach my $row (@$rows) { # foreach (0..$#$row) { # $row->[$_]-- if ($row->[$_] > $clientno); # } # } # # force us into unraised color # my $TabFrame = $this->{ButtonFrame}->Subwidget('Button_'.$Widget); $TabFrame->configure(-background => $client->[DTF_IDX_COLOR]); $TabFrame->Subwidget('Button')->configure( -bg => $client->[DTF_IDX_COLOR], -activebackground => $client->[DTF_IDX_COLOR]); $client->[DTF_IDX_FRAME]->placeForget() if $client->[DTF_IDX_FRAME]->ismapped(); # # if only tab in row, remove the row # and adjust the clients in following rows # if ($#$row < 0) { foreach my $i ($r+1..$#$rows) { $row = $rows->[$i]; $clients->[$_][DTF_IDX_ROW] -= 1 foreach (@$row); } splice @$rows, $r, 1; } if ($#$rows < 0) { # # no rows left, clear everything # $this->{Raised} = undef; $this->Subwidget('Connector')->placeForget(); $this->{CurrentFrame} = undef; } elsif ($newcurrent) { $this->{Raised} = $clients->[$rows->[0][0]][DTF_IDX_WIDGET]; } # # redraw everything # $this->TabRedraw(1); $this->{Updating} = undef; return 1; } # # compute the tabbing traversal order # note an anomaly: # if the top row doesn't fill the frame, and a top # row button is tabbed to, it is automatically moved # to the 0,0, and its tab order it recomputed. This # means that its impossible to tab to any tab # in the top row except the first tab. We may eventually # change TabRaise to bring the entire top row down # if a top row tab is raised. # sub TabOrder { my ($this) = @_; my $rows = $this->{RowList}; my $clients = $this->{ClientList}; my ($prev, $next); foreach my $i (0..$#$rows) { my $row = $rows->[$i]; foreach my $j (0..$#$row) { if ($j == 0) { $prev = ($i == 0) ? $rows->[-1][-1] : $rows->[$i-1][-1]; $next = ($#$row == 0) ? ($i == $#$rows) ? $rows->[0][0] : $rows->[$i+1][0] : $row->[$j+1]; } elsif ($j == $#$row) { $prev = $row->[$j-1]; $next = ($i == $#$rows) ? $rows->[0][0] : $rows->[$i+1][0]; } else { $prev = $row->[$j-1]; $next = $row->[$j+1]; } my $button = $clients->[$row->[$j]][DTF_IDX_FRAME]->Subwidget('Button'); my $prevwgt = $clients->[$prev][DTF_IDX_WIDGET]; my $prevbtn = $clients->[$prev][DTF_IDX_FRAME]->Subwidget('Button'); my $nextwgt = $clients->[$next][DTF_IDX_WIDGET]; my $nextbtn = $clients->[$next][DTF_IDX_FRAME]->Subwidget('Button'); # bind us $button->bind ('', sub {$prevbtn->focus();}); $button->bind ('', sub {$this->TabRaise($prevwgt);}); $button->bind ('', sub {$nextbtn->focus();}); $button->bind ('', sub {$this->TabRaise($nextwgt);}); } } return 1; } # # create a tooltip for the tab # sub CreateTabTip { my ($this, $w, $btn, $tiptext) = @_; # # create balloon if none exists # $this->{Balloon} = $this->Component( 'Balloon' => 'Balloon', -state => 'balloon', -balloonposition => 'widget', -initwait => $this->{_tiptime}, -background => $this->{_tipcolor}) unless $this->{Balloon}; # # attach a balloon if tiptext requested # $w->[DTF_IDX_TABTIP] = $tiptext; return $this->{Balloon}->attach($btn, -balloonmsg => $tiptext); } # # change tab's tip text # sub UpdateTabTip { my ($this, $w, $btn, $tiptext) = @_; return undef unless $this->{Balloon}; # # attach a balloon if tiptext requested # $this->{Balloon}->detach($btn) if $w->[DTF_IDX_TABTIP]; $w->[DTF_IDX_TABTIP] = $tiptext; return $this->{Balloon}->attach($btn, -balloonmsg => $tiptext); } # # remove a tooltip from the tab # sub RemoveTabTip { my ($this, $w, $btn) = shift; return 1 unless $this->{Balloon}; $w->[DTF_IDX_TABTIP] = undef; return $this->{Balloon}->detach($btn); } sub current { shift->TabCurrent (@_); } sub add { my $this = shift; # # make this Notebook compatible # my $caption; $caption = shift unless ($_[0]=~/^-(caption|tabcolor|raisecolor|tabtip|hidden|state|label|image|text)$/); my %args = @_; $caption = $args{-caption} unless $caption; return undef unless defined($caption); my $frame = $this->TabCreate( $caption, delete $args{'-tabcolor'}, delete $args{'-raisecolor'}, delete $args{'-image'}, delete $args{'-label'}, delete $args{'-raisecmd'}, ); # # pick up any attributes we didn't process during creation # $this->pageconfigure($caption, %args) if ($frame && %args); return $frame; } # # turn off flashing tab # sub deflash { my ($this, $page) = @_; return undef unless defined($this->{ClientHash}{$page}); my $w = $this->{ClientList}[$this->{ClientHash}{$page}]; my $color = (defined($this->{Raised}) && ($w->[DTF_IDX_WIDGET] eq $this->{Raised})) ? $w->[DTF_IDX_RAISECOLOR] : $w->[DTF_IDX_COLOR]; my $frame = $w->[DTF_IDX_FRAME]; $frame->configure(-bg => $color), $frame->Subwidget('Button')->configure( -bg => $color, -activebackground => $color), $frame->afterCancel($w->[DTF_IDX_FLASH_ID]), $w->[DTF_IDX_FLASH_ID] = $w->[DTF_IDX_FLASHED] = $w->[DTF_IDX_FLASH_TIME] = undef if $w->[DTF_IDX_FLASH_ID]; return $this; } # # flash a tab # sub flash { my ($this, $page, %args) = @_; return undef unless defined($this->{ClientHash}{$page}); my $w = $this->{ClientList}[$this->{ClientHash}{$page}]; # # don't start new flash if we already are # return $this if $w->[DTF_IDX_FLASH_ID]; $args{-interval} = 300 unless $args{-interval}; $args{-duration} = 5000 unless $args{-duration}; $w->[DTF_IDX_FLASH_COLOR] = $args{-color} ||= 'blue'; $w->[DTF_IDX_FLASH_INTVL] = $args{-interval}; $w->[DTF_IDX_FLASH_TIME] = Tk::timeofday() + ($args{-duration}/1000); $w->[DTF_IDX_FLASH_ID] = $w->[DTF_IDX_FRAME]->repeat( $w->[DTF_IDX_FLASH_INTVL], sub { my $color = (defined($this->{Raised}) && ($w->[DTF_IDX_WIDGET] eq $this->{Raised})) ? $w->[DTF_IDX_RAISECOLOR] : $w->[DTF_IDX_COLOR]; my $frame = $w->[DTF_IDX_FRAME]; $frame->afterCancel($w->[DTF_IDX_FLASH_ID]), $frame->configure(-bg => $color), $frame->Subwidget('Button')->configure( -bg => $color, -activebackground => $color), $w->[DTF_IDX_FLASH_ID] = $w->[DTF_IDX_FLASHED] = $w->[DTF_IDX_FLASH_TIME] = undef, return 1 if (Tk::timeofday() > $w->[DTF_IDX_FLASH_TIME]); $color = $w->[DTF_IDX_FLASH_COLOR] unless $w->[DTF_IDX_FLASHED]; $frame->configure(-bg => $color); $frame->Subwidget('Button')->configure( -bg => $color, -activebackground => $color); $w->[DTF_IDX_FLASHED] = ! $w->[DTF_IDX_FLASHED]; return 1; } ); return $this; } sub raised { shift->TabCurrent (@_); } # # return caption of current raised widget # sub raised_name { my $this = shift; return undef unless $this->{Raised}; my $clients = $this->{ClientList}; foreach my $client (@$clients) { return $client->[DTF_IDX_CAPTION] if ($client->[DTF_IDX_WIDGET] eq $this->{Raised}); } return undef; } # # Notebook compatible methods # sub pagecget { my ($this, $page, $option) = @_; return undef unless (defined($this->{ClientHash}{$page}) && defined($page_opts{$option})); return $page if ($option eq '-caption'); my $w = $this->{ClientList}[$this->{ClientHash}{$page}]; return ($page_opts{$option}=~/^\d+/) ? $w->[$page_opts{$option}] : $w->[DTF_IDX_FRAME]->Subwidget('Button')->cget($page_opts{$option}); } sub pageconfigure { my ($this, $page, %args) = @_; return undef unless defined($this->{ClientHash}{$page}); # # we're forgiving here if they supply an option we don't # support # my $w = $this->{ClientList}[$this->{ClientHash}{$page}]; my $btn = $w->[DTF_IDX_FRAME]->Subwidget('Button'); foreach (keys %args) { next unless defined($page_opts{$_}); if ($_ eq '-hidden') { # # check if hiding the page # if ($args{$_}) { next if $w->[DTF_IDX_HIDDEN]; $this->TabHide($page); } else { # # restore the tab if its hidden # $this->TabReveal($page) if $w->[DTF_IDX_HIDDEN]; } next; } # # make sure we apply state to the close button too # if ($_ eq '-state') { if ($w->[DTF_IDX_FRAME]->Subwidget('CloseBtn')) { $w->[DTF_IDX_FRAME]->Subwidget('CloseBtn')->configure(-state => $args{$_}); } $btn->configure(-state => $args{$_}); } next if ($_ eq '-state'); $btn->configure($page_opts{$_} => $args{$_}), next unless ($page_opts{$_}=~/^\d+/); # # create, update, or remove the button balloon # if ($_ eq '-tabtip') { if ($w->[DTF_IDX_TABTIP]) { if (defined($args{$_})) { $this->UpdateTabTip($w, $btn, $args{$_}); } else { $this->RemoveTabTip($w, $btn); } } else { # no current tip, create one if requested $this->CreateTabTip($w, $btn, $args{$_}) if $args{$_}; } next; } $w->[$page_opts{$_}] = $args{$_}; # # update the button text; be sure to rotate if needed # $btn->configure( -text => ($taborient{$this->{Side}}[DTF_ORIENT_DIRECTION] ? $w->[DTF_IDX_LABEL] : RotateTabText($w->[DTF_IDX_LABEL])) ), next if ($_ eq '-label'); # # reconfig the button and tab colors as needed # $btn->configure(-bg => $args{$_}), $w->[DTF_IDX_FRAME]->configure(-bg => $args{$_}) if ((($_ eq '-tabcolor') && ((! defined($this->{Raised})) || ($w->[DTF_IDX_WIDGET] ne $this->{Raised}))) || (($_ eq '-raisecolor') && (defined($this->{Raised}) && ($w->[DTF_IDX_WIDGET] eq $this->{Raised})))); } 1; } sub pages { return keys %{shift->{ClientHash}}; } sub tiptime { my ($this, $time) = @_; return $this->{_tiptime} unless defined($time); $this->{_tiptime} = $time; return $this->{Balloon} ? $this->{Balloon}->configure(-initwait => $time) : 1; } sub tipcolor { my ($this, $color) = @_; return $this->{_tipcolor} unless defined($color); $this->{_tipcolor} = $color; return $this->{Balloon} ? $this->{Balloon}->configure(-background => $color) : 1; } sub font { shift->Font(@_); } # # programatically raise a tab using its caption # sub raise { my ($this, $Caption) = @_; return defined($this->{ClientHash}{$Caption}) ? $this->TabRaise($this->{ClientList}[$this->{ClientHash}{$Caption}][DTF_IDX_WIDGET]) : undef; } # # programatically remove a tab using its caption # sub delete { my ($this, $Caption) = @_; return defined($this->{ClientHash}{$Caption}) ? $this->TabRemove($Caption) : undef; } # # return a hash of our tabs keyed by caption, so the # app can e.g., attach a Balloon to them # sub tabs { my ($this) = @_; my $tabs = { }; my $clients = $this->{ClientList}; $tabs->{$_} = $clients->[$this->{ClientHash}{$_}][DTF_IDX_FRAME] foreach (keys %{$this->{ClientHash}}); return $tabs; } sub tabside { my ($this, $side) = @_; return $this->{Side} unless defined($side); # # if already populated, don't permit change # return undef unless ($side=~/^([ns][ew]?)|([ew][ns]?)$/i); # # if already populated, don't permit change # return undef if $this->{PseudoTabs}; $side = lc $side; $side .= 'w' if (($side eq 'n') || ($side eq 's')); $side .= 'n' if (($side eq 'e') || ($side eq 'w')); return $side if ($this->{Side} eq $side); my $oldside = $this->{Side}; $this->{Side} = $side; # # modify all the tabs to move their buttons and closers # my $to = $taborient{$side}; my $clients = $this->{ClientList}; my $tab; my $padx = $this->cget(-tabpadx); my $pady = $this->cget(-tabpady); foreach (keys %{$this->{ClientHash}}) { $tab = $clients->[$this->{ClientHash}{$_}]; my $btn = $tab->[DTF_IDX_FRAME]->Subwidget('Button'); $btn->packForget; if ($tab->[DTF_IDX_FRAME]->Subwidget('CloseBtn')) { # # repack close tab # my $closer = $tab->[DTF_IDX_FRAME]->Subwidget('CloseBtn'); $closer->packForget; $closer->configure( -anchor => $to->[DTF_ORIENT_CLOSEANCHOR]); $closer->pack( -side => $to->[DTF_ORIENT_CLOSESIDE], -anchor => $to->[DTF_ORIENT_CLOSEANCHOR], -expand => 0, -fill => 'none', -ipadx => 0, -ipady => 0, -padx => 1, -pady => 1, ); } # # rotate button text if needed # $btn->configure(-text => ($to->[DTF_ORIENT_DIRECTION] ? $tab->[DTF_IDX_LABEL] : RotateTabText($tab->[DTF_IDX_LABEL]))) if defined($btn->cget(-text)); # # repack the button # $btn->pack( -side => $to->[DTF_ORIENT_BTNSIDE], -anchor => $to->[DTF_ORIENT_BTNANCHOR], -expand => 0, -fill => 'none', -ipadx => 0, -ipady => 0, -padx => $padx, -pady => $pady, ); # # record new button size # $tab->[DTF_IDX_HEIGHT] = $to->[DTF_ORIENT_DIRECTION] ? $btn->reqheight + (2 * $pady) : $btn->reqwidth + (2 * $padx); $tab->[DTF_IDX_WIDTH] = $to->[DTF_ORIENT_DIRECTION] ? $btn->reqwidth + (2 * $padx) : $btn->reqheight + (2 * $pady); } ###################################################################### # # we must repack the major frame components for this to work; # but this process may have some undesirable consequences, and probably # requires that we do everything in a specific order... # ###################################################################### # # get tab alignment info # my ($tabside, $tabfill, $tabanchor, $tabsize, $clientside) = @{$tabalign{$side}}; # # unplace the pseudo tabs, # and remove their current border decorations # (do we dare to destroy here ???) # foreach (@{$this->{PseudoTabs}}) { next unless $_; $_->placeForget(); $_->destroy; } delete $this->{PseudoTabs}; # # repack the buttonframe # $this->{ButtonFrame}->packForget; $this->{ClientFrame}->packForget; $this->{ButtonFrame}->configure($tabsize => 40); $this->{ButtonFrame}->pack( -anchor => $tabanchor, -side => $tabside, -fill => $tabfill, ); # # repack the client frame # $this->{ClientFrame}->pack( -side => $clientside, -expand => 'true', -fill => 'both', ); # # prep for reconfig # $this->{OldWidth} = $this->{ButtonFrame}->reqwidth(); $this->{OldHeight} = $this->{ButtonFrame}->reqheight(); # # recreate our pseudotabs # # push @{$this->{PseudoTabs}}, $this->PseudoCreate($_) # foreach (1..DTF_MAX_ROWS); # # finally, redraw everyone # $this->TabRedraw(1); return $oldside; } sub tabscroll { my ($this, $scroll) = shift; return $this->{Scrolled} unless defined($scroll); return 1 unless ($this->{Scrolled} ^ $scroll); # # set to requested state and redraw # $this->{Scrolled} = $scroll; return $this->TabRedraw(); } sub tabclose { my ($this, $close) = @_; return $this->{Close} unless defined($close); return 1 unless ($this->{Close} || $close); my $clients = $this->{ClientList}; if ($this->{Close} && (! $close)) { # # remove close buttons from everything # delete $this->{Close}; $_->[DTF_IDX_FRAME]->Subwidget('CloseBtn')->packForget, $_->[DTF_IDX_FRAME]->Subwidget('CloseBtn')->Destroy foreach (@$clients); } elsif ($close && (! $this->{Close})) { # # add close buttons to everything # $this->{Close} = ((ref $close) && (ref $close eq 'CODE')) ? $close : \&TabRemove; $_->[DTF_IDX_FRAME]->Component( 'Button' => 'CloseBtn', -command => [ $this->{Close}, $this, $_->[DTF_IDX_CAPTION] ], -anchor => 'ne', -relief => 'raised', -borderwidth => 1, -takefocus => 1, -padx => 0, -pady => 0, -image => $this->{CloseImage} )->pack( -side => 'top', -anchor => 'ne', -expand => 0, -fill => 'none', -ipadx => 0, -ipady => 0, -padx => 0, -pady => 0, ) foreach (@$clients); } else { # # reconfig everyone's close button # $this->{Close} = ((ref $close) && (ref $close eq 'CODE')) ? $close : \&TabRemove; $_->[DTF_IDX_FRAME]->Subwidget('CloseBtn')->configure( -command => [ $this->{Close}, $this, $_->[DTF_IDX_CAPTION] ]) foreach (@$clients); } return $this->TabRedraw(1); } # # for left/right tabs, we must convert text into # vertical format # sub RotateTabText { my $text = shift; my @segments = split /\n/, $text; my $maxchars = 0; foreach (@segments) { $maxchars = length($_) if ($maxchars < length($_)); } $segments[$_] .= (' ' x ($maxchars - length($segments[$_]))) foreach (0..$#segments); my @lines = ('') x $maxchars; my @chars; foreach my $segment (@segments) { @chars = split('', $segment); $lines[$_] .= $chars[$_] . ' ' foreach (0..$#chars); } return join("\n", @lines); } sub OnEnter { my ($widget, $Button, $TabFrame, $Color) = @_; $Button->configure( -bg => $Button->Darken($Button->cget(-bg), 90)); $TabFrame->configure( -bg => $TabFrame->Darken($TabFrame->cget(-bg), 90)); $TabFrame->bind('' => undef); $TabFrame->bind('' => undef); $Button->bind('' => undef); $Button->bind('' => undef); } sub OnLeave { my ($widget, $Button, $TabFrame) = @_; #print "Leaving\n"; $Button->configure( -bg => $Button->Darken($Button->cget(-bg), 110)); $TabFrame->configure( -bg => $TabFrame->Darken($TabFrame->cget(-bg), 110)); $TabFrame->bind('' => [ \&OnEnter, $Button, $TabFrame ]); $TabFrame->bind('' => undef); $Button->bind('' => [ \&OnEnter, $Button, $TabFrame ]); $Button->bind('' => undef); } sub OnFocusIn { my ($Button, $TabFrame) = @_; print "FocusIn\n"; $Button->configure( -bg => $Button->Darken($Button->cget(-bg), 90)); $TabFrame->configure( -bg => $TabFrame->Darken($TabFrame->cget(-bg), 90)); } sub OnFocusOut { my ($Button, $TabFrame) = @_; print "FocusOut\n"; $Button->configure( -bg => $Button->Darken($Button->cget(-bg), 110)); $TabFrame->configure( -bg => $TabFrame->Darken($TabFrame->cget(-bg), 110)); } 1; __END__ =pod =head1 NAME Tk::DynaTabFrame - A NoteBook widget with orientable, dynamically stacking tabs =head1 SYNOPSIS use Tk::DynaTabFrame; $TabbedFrame = $widget->DynaTabFrame ( -font => $font, -raisecmd => \&raise_callback, -raisecolor => 'green', -tabclose => sub { my ($dtf, $caption) = @_; $dtf->delete($caption); }, -tabcolor => 'yellow', -tabcurve => 2, -tablock => undef, -tabpadx => 5, -tabpady => 5, -tabrotate => 1, -tabside => 'nw', -tabscroll => undef, -textalign => 1, -tiptime => 600, -tipcolor => 'yellow', [normal frame options...], ); =begin html

Download

Tk-DynaTabFrame-0.23.tar.gz

Screenshots

=end html =head1 DESCRIPTION [ NOTE: This module was based on Tk::TabFrame... but you probably can't tell it anymore ] A notebook widget with orientable, dynamically rearranging tabs. When the containing window is resized, the tabs will either stack or unstack as needed to fit the enclosing widget's width(height). Likewise, when tabs are added or removed, the tabs will stack/unstack as needed. Tabs may be placed either on the top (default), bottom, left, or right side of the widget, and may be aligned to either the left (default) or right edge for top or bottom tabs, or to the top or bottom edges for left or right tabs. Tabs are added at the innermost row adjacent to the tabbed frame at the alignment edge, and automatically become the "raised" tab when added. Separate B<-tabcolor> and B<-raisecolor> options may be specified for each tab. B<-tabcolor> is used for the tab if it is not the raised tab, or if no B<-raisecolor> is specified. B<-raisecolor> is used when the tab is raised. A tab can be raised by either clicking on the tab; by using left and right keyboard arrows to traverse the tabbing order; or programmatically via the B method. If L<-tabrotate|-tabrotate> is enabled, when a tab in a row other than the innermost frame-adjacent row is raised, all rows are rotated inward, with the current frame-adjacent rows wrapping to the outside, until the raised row becomes the innermost frame adjacent row. Disabling L<-tabrotate|-tabrotate> will leave the raised tab in its current location (assuming the containing window has not been resized; see the L<-tablock|-tablock> option to lock down the tabs on resize events). A small "close" button can be applied to the tabs via the B<-tabclose> option. By default, clicking the close button will delete the tab and associated frame from the DynaTabFrame. If a coderef is supplied as the B<-tabclose> value, then the coderef will be invoked instead. Either text or images can be displayed in the tab, using either the B<-image> or B<-label> page options. A future release will permit both in a single tab. If neither is specified, then the page name value will be used. A "flash" effect may be applied to a tab (i.e., switching between the defined background color and a flash color at a specified interval) using the LB<()> method. Flashing continues until either the LB<()> method is called, the tab is raised manually or programmatically, or the specified flash duration expires. A "tabtip" I<(aka balloon or tooltip)> may be attached to each tab that is displayed when the mouse hovers over the tab. The number of millseconds between the mouse entering a tab, and the display of the tabtip is determined by the L<-tiptime|-tiptime> option (default 450). The background color of the tabtips can be set by the L<-tipcolor|-tipcolor> option (default white). The text of each tabtip can be set, updated, or removed, either in the L() method, or via L(), using the L<-tabtip|-tabtip> option. Note that a L widget is not created for the DynaTabFrame widget until a L<-tiptime|-tiptime>, L<-tipcolor|-tipcolor>, or L<-tabtip|-tabtip> is configured. The widget takes all the options that a Frame does. In addition, it supports the following options: =over 4 =item B<-font> Font for tab text. =item B<-raisecmd> Code ref invoked on a raise event; passed the caption of the raised page. BThis behavior is different than L, which passes the widget to the callback. =item B<-raisecolor> Sets the default raisecolor; overridden by B option. Default is current widget background color. =item B<-tabclose> Add small close button to each tab; if set to a coderef, the coderef is invoked when the close button is pressed, and is passed both the Tk::DynaTabFrame object, and the caption of the associated tab. If set to a 'true' scalar value, invokes the L method on the associated tab. Default is no close button. When enabled with L<-tablock|-tablock> enabled, L<-tablock|-tablock> is silently ignored. =item B<-tabcolor>, B<-backpagecolor> Sets the default tabcolor; overridden by the LB<(-tabcolor)> option. Default is current widget background color. =item B<-tabcurve> Curve to use for top corners of tabs; set to the number of pixels of spacing between adjoining tab borders. Default 2; I. =item B<-tablock> Locks the resize of the tabs; when set to a true value, the tabs will not be rearranged when the enclosing window is resized; default off (ie, tabs are rearranged on resize). Silently ignored when L<-tabclose|-tabclose> is enabled. Note that this options does not effect the tab raise event behavior (tab rows rotate inward). See the L<-tabrotate|-tabrotate> option to disable that behavior. =item B<-tabpadx> Padding on left and right of the tab contents =item B<-tabpady> Padding on top and bottom of the tab contents =item B<-tabrotate> When enabled (the default), when a tab is raised in a row other than the innermost, frame-adjacent row, tab rows are rotated inward until the raised tab is frame adjacent. Disabling this option will leave the raised tab's row at its current location until a resize event occurs. (See L<-tablock|-tablock> to lock down tab locations on resize events). =item B<-tabside> Side of notebook to align tabs; acceptable values: 'nw' (default) - tabs on top, aligned to the left edge 'ne' - tabs on top, aligned to the right edge 'sw' - tabs on bottom, aligned to the left edge 'se' - tabs on bottom, aligned to the right edge 'en' - tabs on right, aligned to the top edge 'es' - tabs on right, aligned to the bottom edge 'wn' - tabs on left, aligned to the top edge 'ws' - tabs on left, aligned to the bottom edge 'n' - same as 'nw' 's' - same as 'sw' 'e' - same as 'en' 'w' - same as 'wn' B can only be set or changed prior to adding any pages; attempts to change the B<-tabside> after pages have been added will be silently ignored. =item B<-tabscroll> I<(not yet implemented)> When set to a true value, causes tabs to be restricted to a single row, with small arrow buttons placed at either end of the row to permit scrolling the tabs into/out of the window. When a tab is programmatically raised, the tabs will be scrolled until the raised tab is visible. =item B<-textalign> Aligns text to the tab orientation. When enabled (i.e., set to a 'true' scalar, the default), text in tabs is aligned to the tab orientation (i.e., top and bottom tabs have horizontal text, side tabs have vertical text). When disabled (i.e., set to undef or 0), text will be vertical for top and bottom tabs, and horizontal for side tabs. =item B<-tipcolor> Sets the background color of any tabtips (default white). Causes creation of a L widget if none yet exists. =item B<-tiptime> Sets the integer number of milliseconds to delay between the time the mouse enters a tab and the display of any defined tabtip. Default 450. Causes creation of a L widget if none yet exists. =back =head2 Additional B I<-options> =over 4 =item B<-current>, B<-raised> Returns the currently raised frame. =item B<-raised_name> Returns the page name of the currently raised frame =item B<-tabs> Returns a hashref of the tab Button widgets, keyed by the associated caption. =back =head1 METHODS The following methods may be used with a DynaTabFrame object in addition to standard methods. =over 4 =item BI<[ pageName, ]> IB<)> Adds a page with name I (if provided) to the notebook. Returns an object of type B. If no I is supplied, then the B<-caption> option value will be used. If neither is provided, then the name is the string representation of the created page's frame. Recognized I are: =back =over 8 =item B<-caption> Specifies the identifying name for the page. Also used for the tab text if no B<-label> or B<-image> is specified. If this option is specified, and the optional I argument is specified, I overrides this option. =item B<-hidden> When set to a true value, causes the resulting tab to be hidden from view; can later be set to a false value to force the tab to be visible again. =item B<-image> Specifies an image to display on the tab of this page. The image is displayed only if the B<-label> option is not specified. =item B<-label> Specifies the text string to display on the tab of this page. =item B<-raisecmd> Specifies a callback to be called whenever this page is raised by the user. Overrides the widget-level B<-raisecmd> option only for this tab. B This option's behavior is different from the L, in that the callback is passed the name of the page, rather than the widget. =item B<-raisecolor> Specifies the raised background color for the tab. Overrides the widget-level B<-raisecolor> option for only this tab. =item B<-tabcolor> Specifies the unraised background color for the tab. Overrides the widget-level B<-tabcolor/-backpagecolor> option for only this tab. =item B<-tabtip> Specifies the text of a tabtip to attach to the created tab. Causes creation of a L widget if none yet exists. =back =over 4 =item BIB<)> Turns off flashing for the specified I. =item BIB<)> Deletes the page identified by I. =item BI, IB<)> Flashes the tab for the specified I. Flashing continues until either the B<-duration> has expired, the tab is raised (either by clicking the tab, or programmatically), or L is called on the page. I include =back =over 8 =item B<-color> Color to use for flashing. Flashing alternates between the current L<-tabcolor|-tabcolor> (or L<-raisecolor|-raisecolor> if the tab is raised), and this color. Default is 'blue'. =item B<-interval> Number of milliseconds between flashes. Default is 300. =item B<-duration> Duration of the flash in milliseconds. Default is 5000 (i.e., 5 secs). =back =over 4 =item BI, I<-option>B<)> Returns the current value of the configuration option given by I<-option> in the page given by I. I<-option> may be any of the values accepted in the L method, plus the B<-state> option. =item BI, I<-option>B<)> Like configure for the page indicated by I. I<-options> may be any of the options accepted by the L method, plus the B<-state> option. Note that configuring the L<-tabtip|-tabtip> option to C will remove the tabtip from the page. =item B Returns a list consisting of the names of all currently defined pages, i.e., those created with the B method. =item BIB<)> Raise the page identified by I. Returns the Frame widget of the page. =item B, B Returns the currently raised Frame widget. B This method behavior differs from the L method of the same, which returns the page name. Use the L() method to mimic Tk::Notebook behavior. =item B Returns the page name of the currently raised frame =back =head1 CAVEATS B horizontal scrolled frames (ie, 'os') seem to cause some race conditions (Config events keep resizing the frame up, then down). Use mandatory scrollbars if you need horizontal scrollbars. Support for rotated text in left or right side tabs is lacking, due to the lack of a consistent text rotation method in Perl/Tk. While the issue can be alleviated using the L<-textalign|-textalign> option, another possible solution may be either L on Win32 platforms, or L for *nix platforms. Unfortunately, vertical text is less than aesthetically pleasing, and can consume a rather large vertical area; using images with attached balloons may be a preferable alternative. As of v. 0.20, better compatibility with L has been provided. However, DTF is not yet fully backward compatible, as some methods and options of the same name could not be changed from prior versions of DTF in order to preserve backward compatibility. As of V 0.20, the maximum number of tab rows is 21. This arbitrary limit is imposed due to odd behavior when redrawing the tabs on a resize event. "Pseudo" tabs are used to provide the illusion of tabs embedded into a frame-spanning row. If these pseudotabs are destroyed and recreated during a resize event B, the window will snap back to its original dimensions when the new pseudotabs are B. The only solution seems to be to create a fixed number of pseudotabs at startup, and B them as needed during the redraw. Eventually, a widget attribute may be added to specify the max number of rows to permit. L<-tabclose|-tabclose> and L<-tablock|-tablock> are mutually exclusive; if both are enabled, L<-tablock|-tablock> will be silently ignored. Using L objects as tab images appears to cause sizing and layout issues due to the object not reporting its true full layout size; hence, they should be avoided. =head1 TO DO =over 4 =item Canvas based tabs Currently tabs are drawn as frames with a button (plus optional close button), and the text or image is added to the button. This limits the layout of tabs to square boxes. By converting the ButtonFrame to a Canvas, and just building, binding, and moving objects on the canvas when a redraw occurs, we can have a much more flexible tab layout (image+text, nice curved tabs, etc.). =item Configurable B<-tabclose> button Currently, only a "close" button is implemented with a fixed image. In future, the button image may be configurable, e.g., set to a "minimize" image and set a minimize callback for an MDI-type notebook. =item Configurable B<-tabside> BI<-tabside>B<)> should be permitted after pages are added. =item Rotated tab text using L Newer versions of L provides better font support, with 90 degree rotation. By using L to render and rotate the tab text as an image, sideways text can be used in tabs as images. =item Single row, scrolled tabs Support for scrolling tabs, rather than stacking, should be added with small arrow buttons added at either end of the tab row when some tabs exist beyond the beginning/end of the row. =back =head1 AUTHORS Dean Arnold Portions of the POD derived from L. Initial code derived from L, included in Tk-DKW bundle by Damion K. Wilson. Copyright(c) 2003-2005, Dean Arnold, Presicient Corp., USA. All rights reserved. Portions Copyright(c) 1998-1999 Damion K. Wilson, all rights reserved. This code and documentation may be distributed under the same conditions as Perl itself. =head1 HISTORY =over 4 =item May 22, 2005 : Ver. 0.22 - added -hidden page option - added -tiptime, -tipcolor global attributes - added -tabtip page option =item January 10, 2005 : Ver. 0.20 - added -tabclose - added -tabside - added -image attribute to add() to support images in tabs - added -label attribute to add() to support alternate text in tabs - fixed -raisecolor behavior to revert color of prior raised tab - fixed "roaming" tab connector frame - code mods for performance - added -tabcolor/-backpagecolor, -raisecolor widget level options - added -raisecmd attribute to add() to support event callback - added some Tk::Notebook drop-in compatibility (pagecget(), pageconfigure(), pages(), raised()) - POD enhancements - added -textalign - added -tabrotate - added flash(), deflash() =item March 14, 2004 : Ver. 0.07 - added -raisecolor to set the color of a tab when raised - increased ConfigDebounce width threshold for ptk804.025beta =item January 16, 2004 : Ver. 0.06 - fixed programmatic raise - added (simple) install test - added programmatic raise button to demo app - added flash() =item January 13, 2004 : Ver. 0.05 - added "pseudo-tabs" to backfill the space between the right side of last tab in a row, and the right side of the enclosing frame =item January 6, 2004 : Ver. 0.04 - fixed TabRemove for remove from arbitrary position - updated demo app to exersize arbitrary position removal - fixed apparent timing issue with TabRemove and resizing that caused occasional phantom client entries =item January 5, 2004 : Ver. 0.03 - added raised_name() method/-raised_name property to return caption of currently raised page - fixed tab ordering on resize when raised tab gets moved to other than bottom row =item December 29, 2003 : Ver. 0.02 - improve raise behavior - improve tab font behavior (use platform/application default when none specified) - added tablock option =item December 25, 2003 : Ver. 0.01 - Converted from Tk::TabFrame =cut