File Coverage

blib/lib/Tk/TabFrame.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

package Tk::TabFrame;

use Tk;
use Tk::ChildNotification;
use Tk::Frame;
use Tk::Label;

use base qw (Tk::Derived Tk::Frame);
use vars qw ($VERSION);
use strict;
use Carp;

$VERSION = '0.01';

Tk::Widget->Construct ('TabFrame');

sub Populate
   {
    my $this = shift;

    my $l_ButtonFrame = $this->{m_ButtonFrame} = $this->Component
       (
        'Frame' => 'ButtonFrame',
        '-borderwidth' => 0,
        '-relief' => 'flat',
        '-height' => 40,
       );

    my $l_ClientFrame = $this->{m_ClientFrame} = $this->Component
       (
        'TabChildFrame' => 'TabChildFrame',
        '-relief' => 'flat',
        '-borderwidth' => 0,
        '-height' => 60,
       );

    my $l_MagicFrame = $this->Component
       (
        'Frame' => 'MagicFrame',
       );

    $l_ButtonFrame->pack
       (
        '-anchor' => 'nw',
        '-side' => 'top',
        '-fill' => 'x',
       );

    $l_ClientFrame->pack
       (
        '-side' => 'top',
        '-expand' => 'true',
        '-fill' => 'both',
       );

    $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],
        '-font' => ['METHOD', 'font', 'Font', undef],
        '-current' => ['METHOD'],
        '-raised' => ['METHOD'],

        # These are historical. Their use is deprecated

        '-trimcolor' => ['PASSIVE', 'trimcolor','trimcolor', undef],
        '-bottomedge' => ['PASSIVE', 'bottomedge', 'BottomEdge', undef],
        '-sideedge' => ['PASSIVE', 'sideedge', 'SideEdge', undef],
        '-tabstart' => ['PASSIVE', 'tabstart', 'TabStart', undef],
       );

    $l_ClientFrame->bind ('' => sub {$this->configure ('-current' => $this->{m_Raised});});
    $this->Delegates ('Construct' => $l_ClientFrame);
    $this->SUPER::Populate (@_);
    return $this;
   }

sub TabCreate
   {
    my ($this, $p_Widget, $p_Caption, $p_Color) = (shift, @_);

    my $l_Previous =
       (
        defined (${$this->{m_ClientList}}[-1]) ?
        $this->{m_ButtonFrame}->Subwidget ('Button_'.${$this->{m_ClientList}}[-1])->Subwidget ('Button') :
        undef
       );

    my $l_TabFrame = $this->{m_ButtonFrame}->Component
       (
        'Frame' => 'Button_'.$p_Widget,
        '-foreground' => $this->cget ('-foreground'),
        '-relief' => 'flat',
        '-borderwidth' => 0,
       );

    my $l_Button = $l_TabFrame->Component
       (
        'Button' => 'Button',
        '-command' => sub {$this->configure ('-current' => $p_Widget);},
        (defined ($p_Color) ? ('-bg' => $p_Color) : ()),
        '-text' => $p_Caption || $p_Widget->name(),
        '-font' => $this->cget (-font),
        '-relief' => 'flat',
        '-borderwidth' => 0,
        '-takefocus' => 1,
        '-padx' => 2,
        '-pady' => 2,
       );

    $l_TabFrame->bind ('' => sub {$l_Button->invoke();});
    $l_Button->bind ('', sub {$l_Button->configure ('-highlightthickness' => 0);});
    $l_Button->bind ('', sub {$l_Button->configure ('-highlightthickness' => 1);});
    $l_Button->bind ('', sub {($this->children())[0]->focus();});
    $l_Button->bind ('' => sub {$l_Button->invoke();});

    if (defined ($l_Previous))
       {
        $l_Button->bind ('', sub {$l_Previous->focus();});
        $l_Button->bind ('', sub {$l_Previous->invoke();});
        $l_Previous->bind ('', sub {$l_Button->focus();});
        $l_Previous->bind ('', sub {$l_Button->invoke();});
       }

    $this->TabBorder ($l_TabFrame);

    $this->{m_ClientFrame}->configure
       (
        '-borderwidth' => $this->cget ('-borderwidth'),
        '-relief' => 'raised',
       );

    $l_Button->configure
       (
        '-highlightcolor' => $l_Button->Darken ($l_Button->cget (-background), 50),
        '-activebackground' => $l_Button->cget (-background),
       );

    $l_Button->pack
       (
        '-expand' => 'true',
        '-fill' => 'both',
        '-ipadx' => 0,
        '-ipady' => 0,
        '-padx' => 3,
        '-pady' => 3,
       );

    $l_TabFrame->place
       (
        '-width' => ($l_Button->reqwidth() || 20) + 5,
        '-x' => $this->GetButtonRowWidth(),
        '-relheight' => 1.0,
        '-anchor' => 'nw',
       );

    $this->{m_ButtonFrame}->GeometryRequest
       (
        $this->{m_ButtonFrame}->width(),
        $this->GetButtonRowHeight() + 5,
       );

    push (@{$this->{m_ClientList}}, $p_Widget);
    return $this->TabCurrent ($p_Widget);
   }

sub TabRaise
   {
    my ($this, $p_Widget) = (shift, @_);

    my $l_ButtonFrame = $this->{m_ButtonFrame};
    my $l_TabFrame = $l_ButtonFrame->Subwidget ('Button_'.$p_Widget);
    my $l_MagicFrame = $this->Subwidget ('MagicFrame');
    my %l_Hash = $l_TabFrame->placeInfo();

    foreach my $l_Client (@{$this->{m_ClientList}})
       {
        if ($l_Client ne $p_Widget)
           {
            my $l_TabButton = $l_ButtonFrame->Subwidget ('Button_'.$l_Client);
            $l_TabButton->place ('-height' => - 5, '-y' => 5);
            $l_TabButton->lower ($l_TabFrame);
           }
       }

    $l_MagicFrame->place
       (
        '-x' => $l_Hash {'-x'},
        '-y' => $this->{m_ClientFrame}->rooty() - $this->rooty() - 1,
        '-height' => $this->{m_ClientFrame}->cget ('-borderwidth'),
        '-width' => $l_Hash {'-width'},
        '-anchor' => 'nw',
       );

    $l_MagicFrame->configure ('-bg' => $l_TabFrame->cget ('-background'));
    $l_TabFrame->place ('-height' => - 1, '-y' => 1);
    $l_TabFrame->Subwidget ('Button')->focus();
    $l_TabFrame->Subwidget ('Button')->raise();
    $l_MagicFrame->raise ();
    $l_TabFrame->raise();

    foreach my $l_Sibling ($p_Widget->parent()->children())
       {
        $l_Sibling->lower ($p_Widget) if ($l_Sibling ne $p_Widget);
       }

    $p_Widget->raise();
    return $p_Widget;
   }

sub TabBorder
   {
    my ($this, $p_TabFrame) = (shift, @_);
    my $l_LineWidth = $this->cget ('-borderwidth');
    my $l_Background = $this->cget ('-background');
    my $l_InnerBackground = $p_TabFrame->Darken ($l_Background, 120),
    my $l_Curve = $this->cget ('-tabcurve');

    my $l_LeftOuterBorder = $p_TabFrame->Frame
       (
        '-background' => 'white',
        '-borderwidth' => 0,
       );

    my $l_LeftInnerBorder = $p_TabFrame->Frame
       (
        '-background' => $l_InnerBackground,
        '-borderwidth' => 0,
       );

    my $l_TopOuterBorder = $p_TabFrame->Frame
       (
        '-background' => 'white',
        '-borderwidth' => 0,
       );

    my $l_TopInnerBorder = $p_TabFrame->Frame
       (
        '-background' => $l_InnerBackground,
        '-borderwidth' => 0,
       );

    my $l_RightOuterBorder = $p_TabFrame->Frame
       (
        '-background' => 'black',
        '-borderwidth' => 0,
       );

    my $l_RightInnerBorder = $p_TabFrame->Frame
       (
        '-background' => $p_TabFrame->Darken ($l_Background, 80),
        '-borderwidth' => 0,
       );

    $l_LeftOuterBorder->place
       (
        '-x' => 0,
        '-y' => $l_Curve - 1,
        '-width' => $l_LineWidth,
        '-relheight' => 1.0,
       );

    $l_LeftInnerBorder->place
       (
        '-x' => $l_LineWidth,
        '-y' => $l_Curve - 1,
        '-width' => $l_LineWidth,
        '-relheight' => 1.0,
       );

    $l_TopInnerBorder->place
       (
        '-x' => $l_Curve - 1,
        '-y' => $l_LineWidth,
        '-relwidth' => 1.0,
        '-height' => $l_LineWidth,
        '-width' => - ($l_Curve * 2),
       );

    $l_TopOuterBorder->place
       (
        '-x' => $l_Curve - 1,
        '-y' => 0,
        '-relwidth' => 1.0,
        '-height' => $l_LineWidth,
        '-width' => - ($l_Curve * 2),
       );

    $l_RightOuterBorder->place
       (
        '-x' => - ($l_LineWidth),
        '-relx' => 1.0,
        '-width' => $l_LineWidth,
        '-relheight' => 1.0,
        '-y' => $l_Curve,
       );

    $l_RightInnerBorder->place
       (
        '-x' => - ($l_LineWidth * 2),
        '-width' => $l_LineWidth,
        '-relheight' => 1.0,
        '-y' => $l_Curve / 2,
        '-relx' => 1.0,
       );
   }

sub TabCurrent
   {
    return
       (
        defined ($_[1]) ?
        $_[0]->TabRaise ($_[0]->{m_Raised} = $_[1]) :
        $_[0]->{m_Raised}
       );
   }

sub GetButtonRowWidth
   {
    my ($l_Width, $this) = (0, shift, @_);
    my $l_ButtonFrame = $this->{m_ButtonFrame};

    foreach my $l_Client (@{$this->{m_ClientList}})
       {
        $l_Width += $l_ButtonFrame->Subwidget ('Button_'.$l_Client)->Subwidget ('Button')->reqwidth();
       }

    return $l_Width ? $l_Width - 10 : $l_Width;
   }

sub GetButtonRowHeight
   {
    my ($l_Height, $this) = (0, shift, @_);
    my $l_ButtonFrame = $this->{m_ButtonFrame};

    foreach my $l_Client (@{$this->{m_ClientList}})
       {
        my $l_NewHeight = $l_ButtonFrame->Subwidget ('Button_'.$l_Client)->Subwidget ('Button')->reqheight();
        $l_Height = $l_NewHeight if ($l_NewHeight > $l_Height);
       }

    return $l_Height;
   }

sub Font
   {
    my ($this, $p_Font) = (shift, @_);

    return ($this->{m_Font}) unless (defined ($p_Font));

    my $l_ButtonFrame = $this->{m_ButtonFrame};

    foreach my $l_Client (@{$this->{m_ClientList}})
       {
        $l_ButtonFrame->Subwidget ('Button_'.$l_Client)->Subwidget ('Button')->configure
           (
            '-font' => $p_Font,
           );
       }

    return ($this->{m_Font} = $p_Font);
   }

sub current
   {
    shift->TabCurrent (@_);
   }

sub raised
   {
    shift->TabCurrent (@_);
   }

sub font
   {
    shift->Font (@_);
   }

1;

package Tk::TabChildFrame;

use Tk::ChildNotification;
use Tk;

use vars qw ($VERSION @ISA);

use strict;

$VERSION = '1.01';

@ISA = qw (Tk::Widget Tk::Frame);

Tk::Widget->Construct ('TabChildFrame');

sub Populate
   {
    my ($this, $p_Parameters) = (shift, @_);

    $this->SUPER::Populate (@_);

    return $this;
   }

sub QueueLayout
   {
    $_[0]->DoWhenIdle (['ExecuteLayout', $_[0]]) unless ($_[0]->{'LayoutPending'}++);
   }

sub SlaveGeometryRequest
   {
    shift->QueueLayout();
   }

sub LostSlave
   {
    shift->QueueLayout();
   }

sub ExecuteLayout
   {
    my $this = shift;

    $this->{'LayoutPending'} = 0;

    my $l_PadX = $this->parent()->cget ('-padx');
    my $l_PadY = $this->parent()->cget ('-pady');
    my $l_Height = 0;
    my $l_Width = 0;

    foreach my $l_Child ($this->children())
       {
        next unless Exists ($l_Child);

        my @l_Dimensions =
           (
            $l_Child->reqwidth(),
            $l_Child->reqheight(),
           );

        $l_Height = $l_Dimensions [1] if ($l_Dimensions [1] > $l_Height);
        $l_Width = $l_Dimensions [0] if ($l_Dimensions [0] > $l_Width);
       }

    foreach my $l_Child ($this->children())
       {
        next unless Exists ($l_Child);

        $l_Child->MoveResizeWindow
           (
            $l_PadX,
            $l_PadY,
            $l_Width,
            $l_Height,
           );

        $l_Child->MapWindow();
       }

    $this->GeometryRequest
       (
        $l_Width + ($l_PadX * 2),
        $l_Height + ($l_PadY * 2),
       );
   }

sub ChildNotification
   {
    my ($this, $p_Child, $p_Arguments) = (shift, @_);

    $p_Child->packForget();

    $this->ManageGeometry ($p_Child);

    $this->parent()->TabCreate
       (
        $p_Child,
        delete $p_Arguments->{'-caption'},
        delete $p_Arguments->{'-tabcolor'},
       );
   }

1;

__END__