File Coverage

blib/lib/Test/Tech.pm

Criterion	Covered	Total	%
statement	100	289	34.6
branch	22	174	12.6
condition	2	33	6.0
subroutine	19	29	65.5
pod	9	12	75.0
total	152	537	28.3

#!perl
#
# Documentation, copyright and license is at the end of this file.
#
package  Test::Tech;

# use 5.001;
use strict;
use warnings;
use warnings::register;

use Test ();   # do not import the "Test" subroutines
use Data::Secs2 1.22 qw(stringify);
use Data::Str2Num 0.05;
use Data::Startup 0.03;

use vars qw($VERSION $DATE $FILE);
$VERSION = '1.26';
$DATE = '2004/05/20';
$FILE = __FILE__;

use vars qw(@ISA @EXPORT_OK);
require Exporter;
@ISA=('Exporter');
@EXPORT_OK = qw(demo finish is_skip ok ok_sub plan skip skip_sub
                skip_tests stringify tech_config);

#######
# For subroutine interface keep all data hidden in a local hash of private object
#
my $tech_p = new Test::Tech;

sub new
{

   ####################
   # $class is either a package name (scalar) or
   # an object with a data pointer and a reference
   # to a package name. A package name is also the
   # name of a class
   #
   my ($class, @args) = @_;
   $class = ref($class) if( ref($class) );
   my $self = bless {}, $class;

   ######
   # Make Test variables visible to tech_config
   #
   $self->{Test}->{ntest} = \$Test::ntest;
   $self->{Test}->{TESTOUT} = \$Test::TESTOUT;
   $self->{Test}->{TestLevel} = \$Test::TestLevel;
   $self->{Test}->{ONFAIL} = \$Test::ONFAIL;
   $self->{Test}->{TESTERR} = \$Test::TESTERR if defined $Test::TESTERR;

   $self->{TestDefault}->{TESTOUT} = $Test::TESTOUT;
   $self->{TestDefault}->{TestLevel} = $Test::TestLevel;
   $self->{TestDefault}->{ONFAIL} = $Test::ONFAIL;
   $self->{TestDefault}->{TESTERR} = $Test::TESTERR if defined $Test::TESTERR;

   ######
   # Test::Tech object data
   #
   $self->{Skip_Tests} = 0;
   $self->{test_name} = '';
   $self->{passed} = [];
   $self->{failed} = [];
   $self->{skipped} = [];
   $self->{missed} = [];
   $self->{unplanned} = [];
   $self->{last_test} = 0;
   $self->{num_tests} = 0;
   $self->{highest_test} = 0;

   ######
   # Redirect Test:: output thru Test::Tech::Output handle
   #   unless been redirected and never restored!!
   #
   unless( \*TESTOUT eq $Test::TESTOUT ) {
       $self->{test_out} = $Test::TESTOUT;
       tie *TESTOUT, 'Test::Tech::Output', $Test::TESTOUT, $self;
       $Test::TESTOUT = \*TESTOUT;
   }

   $self;

}

######
# Demo
#
sub demo
{
   use Data::Dumper;

   ######
   # This subroutine uses no object data; therefore,
   # drop any class or object.
   #
   shift if UNIVERSAL::isa($_[0],__PACKAGE__);

   my ($quoted_expression, @expression) = @_;

   #######
   # A demo trys to simulate someone typing expresssions
   # at a console.
   #

   #########
   # Print quoted expression so that see the non-executed
   # expression. The extra space is so when pasted into
   # a POD, the POD will process the line as code.
   #
   $quoted_expression =~ s/(\n+)/$1 /g;
   print $Test::TESTOUT ' ' . $quoted_expression . "\n";

   ########
   # @data is the result of the script executing the
   # quoted expression.
   #
   # The demo output most likely will end up in a pod.
   # The the process of running the generated script
   # will execute the setup. Thus the input is the
   # actual results. Putting a space in front of it
   # tells the POD that it is code.
   #
   return unless @expression;

   $Data::Dumper::Terse = 1;
   my $data = Dumper(@expression);
   $data =~ s/(\n+)/$1 #/g;
   $data =~ s/\\\\/\\/g;
   $data =~ s/\\'/'/g;

   print $Test::TESTOUT "\n # " . $data . "\n" ;

}

#####
# Restore the Test:: moduel variable back to where they were when found
#
sub finish
{
    $tech_p = Test::Tech->new() unless $tech_p;
    my $self = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift @_ : $tech_p;
    $self = ref($self) ? $self : $tech_p;

    return undef unless $Test::TESTOUT;  # if IO::Handle object may be destroyed and undef
    return undef unless $Test::planned;

    my $missing = $self->{last_test} + 1;
    $self->{test_name} = '';
    while($missing <= $self->{num_tests}) {
        $self->{Skip_Diag} = '' unless $self->{Skip_Diag};
        print $Test::TESTOUT "not ok $missing Not Performed # missing $self->{Skip_Diag}\n";
        if( 1.20 < $Test::VERSION ) {
            print $Test::TESTERR "# Test $missing got: (Missing)\n";
            print $Test::TESTERR "# Expected: (Missing)\n";
        }
        else {
            print $Test::TESTOUT "# Test $missing got: (Missing)\n";
            print $Test::TESTOUT "# Expected: (Missing)\n";
        }
        push @{$self->{missed}}, $missing++;
    }

    $Test::TESTOUT = $self->{TestDefault}->{TESTOUT};
    $Test::TestLevel = $self->{TestDefault}->{TestLevel};
    $Test::ONFAIL = $self->{TestDefault}->{ONFAIL};
    $Test::TESTERR = $self->{TestDefault}->{TESTERR} if defined $Test::TESTERR;

    if(@{$self->{unplanned}}) {
        print $Test::TESTOUT '# Extra  : ' . (join ' ', @{$self->{unplanned}}) . "\n";
    }
    if(@{$self->{missed}}) {
        print $Test::TESTOUT '# Missing: ' . (join ' ', @{$self->{missed}}) . "\n";
    }
    if(@{$self->{skipped}}) {
        print $Test::TESTOUT '# Skipped: ' . (join ' ', @{$self->{skipped}}) . "\n";
    }
    if(@{$self->{failed}}) {
        print $Test::TESTOUT '# Failed : ' . (join ' ', @{$self->{failed}}) . "\n";
    }
    use integer;

    my $total = $self->{num_tests} if $self->{num_tests};
    $total = $self->{last_test} if $self->{last_test} && $self->{num_tests} < $self->{last_test};
    $total -= @{$self->{skipped}};

    my $passed =  @{$self->{passed}};
    print $Test::TESTOUT '# Passed : ' . "$passed/$total " . ((100*$passed)/$total) . "%\n" if $total;

    ######
    # Only once per test run.
    #
    $Test::planned = 0;

    return ($total,$self->{unplanned},$self->{missed},$self->{skipped},$self->{passed},$self->{failed})
          if wantarray;

    $passed ? 1 : 0;
}

# *finish = &*Test::Tech::DESTORY; # DESTORY is alias for finish
sub DESTORY
{
    finish( @_ );

}


######
#
#
sub is_skip
{
    $tech_p = Test::Tech->new() unless $tech_p;
    my $self = (UNIVERSAL::isa($_[0],__PACKAGE__) && ref($_[0])) ? shift @_ : $tech_p;
    $self = ref($self) ? $self : $tech_p;
    return ($self->{Skip_Tests}, $self->{Skip_Diag}) if wantarray;
    $self->{Skip_Tests};

}

######
# Cover function for &Test::ok that adds capability to test
# complex data structures.
#
sub ok
{
  $Test::TestLevel++;
  my $results = ok_sub('',@_);
  $Test::TestLevel--;
  $results;
}

######
# Cover function for &Test::ok that adds capability to test
# complex data structures.
#
sub ok_sub
{

    ######
    # If no object, use the default $tech_p object.
    #
    $tech_p = Test::Tech->new() unless $tech_p;
    my $self = (UNIVERSAL::isa($_[0],__PACKAGE__) && ref($_[0])) ? shift @_ : $tech_p;
    $self = ref($self) ? $self : $tech_p;

    my ($diagnostic,$name) = ('','');
    my $options = Data::Startup->new(pop @_) if (3 < @_) && ref($_[-1]);

    $diagnostic = $options->{diagnostic} if defined $options->{diagnostic};
    $name = $options->{name} if defined $options->{name};

    my ($subroutine, $actual_result, $expected_result, $diagnostic_in, $name_in) = @_;

    #########
    # Fill in undefined inputs
    #
    $diagnostic = $diagnostic_in if defined $diagnostic_in;
    $name = $name_in if defined $name_in;
    $diagnostic = $name unless defined $diagnostic;
    $self->{test_name} = $name;  # used by tied handle Test::Tech::Output

    if($self->{Skip_Tests}) { # skip rest of tests switch
        &Test::skip( 1, '', '', $self->{Skip_Diag});
        return 1;
    }

    my $str_actual_result = stringify($actual_result);
    my $str_expected_result = stringify($expected_result);
    foreach ($str_actual_result,$str_expected_result) {
        if(ref($_)) {
            $$_ =~ s/\n\n/\n# /g;
            $$_ =~ s/\n([^#])/\n# $1/g;
            $diagnostic = 'Test::Tech::stringify() broken.';
            $self->{test_name} .= ' # ' . $diagnostic;
            &Test::ok($$_,'',$diagnostic,$diagnostic);
            return 0;
        }
    }
    if($subroutine) {
        $diagnostic .= "\n" unless substr($diagnostic,-1,1) eq "\n";
        $str_actual_result =~ s/\n/\n /g;
        $str_expected_result =~ s/\n/\n /g;
        $diagnostic .=
           " got: $str_actual_result\n" .
           " expected: $str_expected_result\n";
        $str_actual_result = &$subroutine($actual_result,$expected_result);
        $str_expected_result = 1;
    }

    &Test::ok($str_actual_result, $str_expected_result, $diagnostic);

}


######
# Cover function for &Test::plan that sets the proper 'Test::TestLevel'
# and outputs some info on the current site
#
sub plan
{
    ######
    # This subroutine uses no object data; therefore,
    # drop any class or object.
    #
    $tech_p = Test::Tech->new() unless $tech_p;
    my $self = (UNIVERSAL::isa($_[0],__PACKAGE__) && ref($_[0])) ? shift @_ : $tech_p;
    $self = ref($self) ? $self : $tech_p;

    &Test::plan( @_ );

    ###############
    #
    # Establish default for Test
    #
    # Test 1.24 resets global variables in plan which
    # never happens in 1.15
    #
    $Test::TestLevel = 1;

    my $loctime = localtime();
    my $gmtime = gmtime();

    my $perl = "$]";
    if(defined(&Win32::BuildNumber) and defined &Win32::BuildNumber()) {
       $perl .= " Win32 Build " . &Win32::BuildNumber();
    }
    elsif(defined $MacPerl::Version) {
       $perl .= " MacPerl version " . $MacPerl::Version;
    }

    print $Test::TESTOUT <<"EOF" unless 1.20 < $Test::VERSION ;
# OS             : $^O
# Perl           : $perl
# Local Time     : $loctime
# GMT Time       : $gmtime
# Test           : $Test::VERSION
EOF

    print $Test::TESTOUT <<"EOF";
# Test::Tech     : $VERSION
# Data::Secs2    : $Data::Secs2::VERSION
# Data::Startup  : $Data::Startup::VERSION
# Data::Str2Num  : $Data::Str2Num::VERSION
# Number of tests: $self->{num_tests}
# =cut
EOF

   1
}


######
#
#
sub skip {
  $Test::TestLevel++;
  my $results = skip_sub( '', @_ );
  $Test::TestLevel--;
  $results;

};


######
#
#
sub skip_sub
{

    ######
    # If no object, use the default $tech_p object.
    #
    $tech_p = Test::Tech->new() unless $tech_p;
    my $self = (UNIVERSAL::isa($_[0],__PACKAGE__) && ref($_[0])) ? shift @_ : $tech_p;
    $self = ref($self) ? $self : $tech_p;

    my ($diagnostic,$name) = ('','');
    my $options = Data::Startup->new(pop @_) if (4 < @_) && ref($_[-1]);

    $diagnostic = $options->{diagnostic} if $options->{diagnostic};
    $name = $options->{name} if $options->{name};

    my ($subroutine, $mod, $actual_result, $expected_result, $diagnostic_in, $name_in) = @_;

    $diagnostic = $diagnostic_in if defined $diagnostic_in;
    $name = $name_in if defined $name_in;
    $diagnostic = $name unless defined $diagnostic;
    $self->{test_name} = $name;  # used by tied handle Test::Tech::Output

    if($self->{Skip_Tests}) {  # skip rest of tests switch
        &Test::skip( 1, '', '', $self->{Skip_Diag});
        return 1;
    }

    my $str_actual_result = stringify($actual_result);
    my $str_expected_result = stringify($expected_result);
    foreach ($str_actual_result,$str_expected_result) {
        if(ref($_)) {
            $$_ =~ s/\n\n/\n# /g;
            $$_ =~ s/\n([^#])/\n# $1/g;
            $diagnostic = 'Test::Tech::stringify() broken.';
            $self->{test_name} .= ' # ' . $diagnostic;
            &Test::ok($$_,'',$diagnostic,$diagnostic);
            return 0;
        }
    }

    if($subroutine) {
        $diagnostic .= "\n" unless substr($diagnostic,-1,1) eq "\n";
        $str_actual_result =~ s/\n/\n /g;
        $str_expected_result =~ s/\n/\n /g;
        $diagnostic .=
           " got: $str_actual_result\n" .
           " expected: $str_expected_result\n";
        $str_actual_result = &$subroutine($actual_result,$expected_result);
        $str_expected_result = 1;
    }

    &Test::skip($mod, $str_actual_result, $str_expected_result, $diagnostic);
}


######
#
#
sub skip_tests
{

    ######
    # If no object, use the default $tech_p object.
    #
    $tech_p = Test::Tech->new() unless $tech_p;
    my $self = (UNIVERSAL::isa($_[0],__PACKAGE__) && ref($_[0])) ? shift @_ : $tech_p;
    $self = ref($self) ? $self : $tech_p;

    my ($value,$diagnostic) =  @_;
    my $result = $self->{Skip_Tests};
    $value = 1 unless (defined $value);
    $self->{Skip_Tests} = $value;
    $diagnostic = 'Test not performed because of previous failure.' unless defined $diagnostic;
    $self->{Skip_Diag} = $value ? $diagnostic : '';
    $result;

}


#######
# This accesses the values in the %tech hash
#
# Use a dot notation for following down layers
# of hashes of hashes
#
sub tech_config
{

    ######
    # If no object, use the default $tech_p object.
    #
    $tech_p = Test::Tech->new() unless $tech_p;
    my $self = (UNIVERSAL::isa($_[0],__PACKAGE__) && ref($_[0])) ? shift @_ : $tech_p;
    $self = ref($self) ? $self : $tech_p;

    my ($key, $value) = @_;
    my @keys = split /\./, $key;

    #########
    # Follow the hash with the current
    # dot index until there are no more
    # hashes. For success, the dot hash
    # notation must match the structure.
    #
    my $key_p = $self;
    while (@keys) {

        $key = shift @keys;

        ######
        # Do not allow creation of new configs
        #
        if( defined( $key_p->{$key}) ) {

            ########
            # Follow the hash
            #
            if( ref($key_p->{$key}) eq 'HASH' ) {
                $key_p  = $key_p->{$key};
            }
            else {
               if(@keys) {
                   warn( "More key levels than hashes.\n");
                   return undef;
               }
               last;
            }
        }
    }


    #########
    # References to arrays and scalars in the config may
    # be transparent.
    #
    my $current_value = $key_p->{$key};
    if( ref($current_value) eq 'SCALAR') {
        $current_value = $$current_value;
    }
    if (defined $value && $key ne 'ntest') {
        if( ref($value) eq 'SCALAR' ) {
            ${$key_p->{$key}} = $$value;
        }
        else {
            ${$key_p->{$key}} = $value;
        }
    }

    $current_value;
}


########
# Handle Tie to catch the Test module output
# so that it may be modified.
#
package Test::Tech::Output;
use Tie::Handle;
use vars qw(@ISA);
@ISA=('Tie::Handle');

#####
# Tie
#
sub TIEHANDLE
{
     my($class, $test_handle, $tech) = @_;
     $class = ref($class) if ref($class);
     bless {test_out => $test_handle, tech => $tech}, $class;
}


#####
#  Print out the test output
#
sub PRINT
{
    my $self = shift;
    my $buf = join(defined $, ? $, : '',@_);
    $buf .= $\ if defined $\;
    my $test_name = $self->{tech}->{test_name};
    my $skip_diag = $self->{tech}->{Skip_Diag};

    #####
    # Insert test name after ok or not ok
    #
    $buf =~ s/(ok \d+)/$1 - $test_name /g if($test_name);

    ######
    # Insert skip diag after a skip comment
    #
    $buf =~ s/(# skip.*?)(\s*|\n)/$1 - $skip_diag$2/ig if $skip_diag;

    #####
    # Keep stats on what tests that pass, failed, skip, todo
    #
    $self->stats($buf);

    #####
    # Output the modified buffer
    #
    my $handle = $self->{test_out};
    print $handle $buf;
}

#####
#
#
sub PRINTF
{
    my $self = shift;
    $self->PRINT (sprintf(shift,@_));
}

sub stats
{
    my ($self,$buf) = @_;
    #####
    # Stats
    my $tech = $self->{tech};
    my $test_num;
    if($buf =~ /^\s*(not ok|ok)\s*(\d+)/) {
        $test_num = $2;
    }
    if($test_num) {
        if( $tech->{num_tests} < $test_num) {
            push @{$tech->{unplanned}},$test_num;
        }
        if($tech->{last_test} + 1 != $test_num) {
            push @{$tech->{missing}},$test_num;
        }
        $tech->{last_test} = $test_num;
    }
    if($buf =~ /^\d+\.\.(\d+)/) {
        $tech->{num_tests} = $1;
    }
    elsif ($buf =~ /^\s*ok\s*(\d+).*?\#\s*skip/i) {
        push @{$tech->{skipped}},$1;
    }
    elsif ($buf =~ /^\s*not ok\s*(\d+)/i) {
       push @{$tech->{failed}},$1;
    }
    elsif ($buf =~ /^\s*ok\s*(\d+)/i) {
       push @{$tech->{passed}},$1;
    }
}

1

__END__