File Coverage

blib/lib/Tk/TabbedForm.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::TabbedForm;

use Tk;
use Tk::TabFrame;
use Tk::Frame;

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

$VERSION = '0.01';

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

*tabfont = \&Tk::TabbedForm::TabFont;
*Field = \&Tk::TabbedForm::Item;
*field = \&Tk::TabbedForm::Item;
*item = \&Tk::TabbedForm::Item;
*file = \&Tk::TabbedForm::File;

sub Populate
   {
    my $this = shift;

    my $l_TabWidget = $this->{m_TabWidget} = $this->Component
       (
        'TabFrame' => 'TabFrame',
       );

    $this->ConfigSpecs
       (
        '-TabFont' => ['METHOD', 'tabfont', 'TabFont', '-adobe-times-medium-r-normal--16-*-*-*-*-*-*-*'],
       );

    $l_TabWidget->pack
       (
        '-fill' => 'both',
        '-expand' => 'true',
       );

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

sub Item
   {
    my ($this, $p_WidgetClass, @p_Parameters) = @_;

    my %l_Hash = @p_Parameters;

    my $l_SectionName = delete $l_Hash {'-section'} || 'Undefined';
    my $l_SectionFrame = $this->SectionFrame ($l_SectionName);
    my $l_Expression = delete $l_Hash {'-rule'} || delete $l_Hash {'-expression'};
    my $l_ItemName = delete $l_Hash {'-name'} || 'Undefined_'.++$Tk::TabbedForm::g_Undefined;
    my $l_Set = delete $l_Hash {'-set'} || sub {$_[0]->delete ('0', 'end'); $_[0]->insert ('0', $_[1]);};
    my $l_Get = delete $l_Hash {'-get'} || sub {$_[0]->get();};
    my $l_Default = delete $l_Hash {'-default'};

    my $l_Label = $l_SectionFrame->Label
       (
        '-text' => $l_ItemName,
       );

    my $l_Widget = $l_SectionFrame->$p_WidgetClass
       (
        %l_Hash,
       );

    $l_Label->grid
       (
        '-row' => ++$l_SectionFrame->{m_Row},
        '-sticky' => 'nw',
        '-column' => 0,
        '-padx' => 2,
        '-pady' => 1,
       );

    $l_Widget->grid
       (
        '-row' => $l_SectionFrame->{m_Row},
        '-sticky' => 'nw',
        '-column' => 1,
        '-padx' => 2,
        '-pady' => 1,
       );

    # Add field to list of fields

    push (@{$this->{m_Fields}->{$l_SectionName}}, $l_ItemName);

    # Add widget to hash of field widgets

    $this->{'x_'.$l_ItemName} = $l_Widget;

    $l_Widget->{m_Section} = $l_SectionName;
    $l_Widget->{m_Default} = $l_Default;
    $l_Widget->{m_Name} = $l_ItemName;
    $l_Widget->{m_Get} = $l_Get;
    $l_Widget->{m_Set} = $l_Set;

    if (defined ($l_Expression))
       {
        my $l_FinalExpression = (ref ($l_Expression) eq 'ARRAY' ? ${$l_Expression}[-1] : $l_Expression);

        $l_Widget->bind
           (
            '' => sub {$this->TestExpression ($l_ItemName, $l_Expression);}
           );

        $l_Widget->bind
           (
            '' => sub {$this->TestExpression ($l_ItemName, $l_FinalExpression, 1);}
           );
       }

    $this->SetItemValue ($l_ItemName);
    return $l_Widget;
   }

sub SectionFrame
   {
    my ($this, $p_SectionName) = @_;
    my $l_Frame = $this->{m_TabWidget}->{$p_SectionName};
    my $l_SectionLabel = $p_SectionName;

    return $l_Frame if (Exists ($l_Frame));

    $l_SectionLabel =~ s/^\_//;

    $this->{m_Fields}->{$p_SectionName} = [];

    $l_Frame = $this->{m_TabWidget}->{$p_SectionName} = $this->{m_TabWidget}->Frame
       (
        '-caption' => $l_SectionLabel,
       )->Frame
       (
       )->pack
       (
        '-anchor' => 'nw',
        '-padx' => 10,
        '-pady' => 10,
        '-expand' => 'true',
        '-fill' => 'x',
       );

    push (@{$this->{'m_TemporarySectionFrameList'}}, $l_Frame);

    $l_Frame->{m_Row} = 0;

    return $l_Frame;
   }

#----------------------------- Item Value Retrieval ----------------------------------#
sub GetItemDefault
   {
    my ($this, $p_ItemName) = (shift, @_);
    my $l_Widget = $this->{'x_'.$p_ItemName};

    return unless (Exists ($l_Widget));
    return $l_Widget->{m_Default} unless (ref ($l_Widget->{m_Default}) eq 'CODE');
    return &{$l_Widget->{m_Default}} ($l_Widget);
   }

sub GetItemValue
   {
    my ($this, $p_ItemName) = (shift, @_);
    my $l_Widget = $this->{'x_'.$p_ItemName};
    my $l_TextVariable;

    return unless (Exists ($l_Widget));

    eval {$l_TextVariable = $l_Widget->cget ('-textvariable');};

    my $l_Return =
       (
        ref ($l_TextVariable) eq 'SCALAR' ? ${$l_TextVariable} :
           (
            ref ($l_Widget->{m_Get}) eq 'CODE' ? &{$l_Widget->{m_Get}} ($l_Widget) :
               (
                ref ($l_Widget->{m_Get}) eq 'SCALAR' ? ${$l_Widget->{m_Get}} :
                   (
                    $l_Widget->{m_Get}
                   )
               )
           )
       );

    $l_Return =~ s/[\n\r]+//g;
    return $l_Return;
   }

sub GetItemValueHash
   {
    my $this = shift;
    my @l_Array = ();

    foreach my $l_Section ($#_ > -1 ? @_ : $this->GetSectionNames())
       {
        foreach my $l_ItemName (@{$this->{m_Fields}->{$l_Section}})
           {
            push (@l_Array, $l_ItemName, $this->GetItemValue ($l_ItemName));
           }
       }

    return @l_Array;
   }

sub GetSectionNames
   {
    return (sort (keys %{$_[0]->{m_Fields}}));
   }

sub GetItemNames
   {
    my $this = shift;
    my %l_Hash = $this->GetItemValueHash (@_);
    return (sort (keys %l_Hash));
   }

#--------------------------------- Item Value Setting ----------------------------------#
sub SetItemValue
   {
    my ($this, $p_ItemName, $p_Value) = (shift, @_);
    my $l_Widget = $this->{'x_'.$p_ItemName};
    my $l_TextVariable;

    return unless (Exists ($l_Widget));

    $p_Value = $this->GetItemDefault ($p_ItemName) unless defined ($p_Value);
    eval {$l_TextVariable = $l_Widget->cget ('-textvariable');};

    if (ref ($l_TextVariable) eq 'SCALAR')
       {
        return ${$l_TextVariable} = $p_Value;
       }
    elsif (ref ($l_Widget->{m_Set}) eq 'CODE')
       {
        return &{$l_Widget->{m_Set}} ($l_Widget, $p_Value);
       }
    elsif (ref ($l_Widget->{m_Get}) eq 'SCALAR')
       {
        return ${$l_Widget->{m_Get}} = $p_Value;
       }
   }

sub SetItemValueHash
   {
    my $this = shift; $this->SetItemValue (shift, shift) while ($#_ > 0);
   }

#----------------------------- Field Value Qualification ----------------------------------#
sub TestExpression
   {
    my ($this, $p_ItemName, $p_Expression, $p_DontCorrect) = (shift, @_);
    my $l_Value = $this->GetItemValue ($p_ItemName);
    my $l_Widget = $this->{'x_'.$p_ItemName};

    return unless (Exists ($l_Widget) && defined ($l_Value));
    return if ($this->MatchExpression ($l_Value, $p_Expression));

    chop $l_Value until ($this->MatchExpression ($l_Value, $p_Expression));
    $this->SetItemValue ($p_ItemName, $l_Value) unless ($p_DontCorrect);
    $l_Widget->focus();
    $l_Widget->bell();
   }

sub MatchExpression
   {
    my ($l_Return, $this, $p_Value, $p_Expression) = (0, shift, @_);

    return 1 if ($p_Value eq '');

    foreach my $l_Expression (ref ($p_Expression) eq 'ARRAY' ? @{$p_Expression} : ($p_Expression))
       {
        $l_Return = 1 if ($p_Value =~ $l_Expression);
       }

    return $l_Return;
   }

sub TabFont
   {
    return $_[0]->{m_TabWidget}->cget ('-font') unless (defined ($_[1]));
    $_[0]->{m_TabWidget}->configure ('-font' => $_[1]);
    return $_[1];
   }

1;

__END__