File Coverage

tlib/Test/Tech.pm

Criterion	Covered	Total	%
statement	52	104	50.0
branch	11	44	25.0
condition	1	3	33.3
subroutine	13	15	86.6
pod	0	7	0.0
total	77	173	44.5

#!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::Dumper;

use vars qw($VERSION $DATE $FILE);
$VERSION = '1.11';
$DATE = '2003/07/27';
$FILE = __FILE__;

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

#######
#
# Keep all data hidden in a local hash
#
# Too bad "Test" and "Data::Dumper" are not objectified
#
# Senseless to objectify "Test::Tech" if unless "Test" and "Data::Dumper"
# are objectified
#

my %tech = ();
my $tech_p = \%tech;  # quasi objectify by using $tech_p instead of %tech

########
# Tend to Data::Dumper variables
#
$tech_p->{Dumper} = {};
$tech_p->{Dumper}->{Terse} = \$Data::Dumper::Terse;
$tech_p->{Dumper}->{Indent} = \$Data::Indent;
$tech_p->{Dumper}->{Purity} = \$Data::Purity;
$tech_p->{Dumper}->{Pad} = \$Data::Pad;
$tech_p->{Dumper}->{Varname} = \$Data::Varname;
$tech_p->{Dumper}->{Useqq} = \$Data::Useqq;
$tech_p->{Dumper}->{Freezer} = \$Data::Freezer;
$tech_p->{Dumper}->{Toaster} = \$Data::Toaster;
$tech_p->{Dumper}->{Deepcopy} = \$Data::Deepcopy;
$tech_p->{Dumper}->{Quotekeys} = \$Data::Quotekeys;
$tech_p->{Dumper}->{Maxdepth} = \$Data::Maxdepth;

######
# Tend to Test variables
#
$tech_p->{Test}->{ntest} = \$Test::ntest;
$tech_p->{Test}->{TESTOUT} = \$Test::TESTOUT;
$tech_p->{Test}->{TestLevel} = \$Test::TestLevel;
$tech_p->{Test}->{ONFAIL} = \$Test::ONFAIL;
$tech_p->{Test}->{todo} = \%Test::todo;
$tech_p->{Test}->{history} = \%Test::history;
$tech_p->{Test}->{planned} = \$Test::planned;
$tech_p->{Test}->{FAILDETAIL} = \@Test::FAILDETAIL;
$tech_p->{Test}->{Program_Lines} = \%Test::Program_Lines if defined %Test::Program_lines;
$tech_p->{Test}->{TESTERR} = \$Test::TESTERR if defined $Test::TESTERR;
$tech_p->{Skip_Tests} = 0;

#######
# Probe for internal storage
#
# The &Data::Dumper::Dumper subroutine stringifies the iternal Perl variable.
# Different Perls keep the have different internal formats for numbers. Some
# keep them as binary numbers, while others as strings. The ones that keep
# them as strings may be well spec. In any case they have been let loose in
# the wild so the test scripts that use Data::Dumper must deal with them.
#
# This is perl, v5.6.1 built for MSWin32-x86-multi-thread
# (with 1 registered patch, see perl -V for more detail)
#
# Copyright 1987-2001, Larry Wall
#
# Binary build 631 provided by ActiveState Tool Corp. http://www.ActiveState.com
# Built 17:16:22 Jan 2 2002
#
#
# Perl may be copied only under the terms of either the Artistic License or the
# GNU General Public License, which may be found in the Perl 5 source kit.
#
# Complete documentation for Perl, including FAQ lists, should be found on
# this system using `man perl' or `perldoc perl'. If you have access to the
# Internet, point your browser at http://www.perl.com/, the Perl Home Page.
#
# ~~~~~~~
#
# Wall, Christiansen and Orwant on Perl internal storage
#
# Page 351 of Programming Perl, Third Addition, Overloadable Operators
# quote:
#
# Conversion operators: ``'', 0+, bool
#
# These three keys let you provide behaviors for Perl's automatic conversions
# to strings, numbers, and Boolean values, respectively.
#
# ~~~~~~~
#
# Internal Storage of Perls that are in the wild
#
# string - Perl v5.6.1 MSWin32-x86-multi-thread, ActiveState build 631, binary
# number - Perl version 5.008 for solaris
#
# Perls in the wild with internal storage of string may be mutants that need to
# be hunted down killed.
#
my $probe = 3;
my $actual = Dumper([0+$probe]);
if( $actual eq Dumper([3]) ) {
   $tech_p->{Internal_Number} = 'number';
}
elsif ( $actual eq Dumper(['3']) ) {
   $tech_p->{Internal_Number} = 'string';
}
else {
   $tech_p->{Internal_Number} = 'undetermine';
}


#####
# Stringify the variable and compare the string.
#
# This is the code that adds the big new capability of testing complex data
# structures to the "Test" module
#
sub stringify
{
   my ($var_p) = @_;

   return '' unless $var_p;

   my ($result, $ref);
   if($ref = ref($var_p)) {
       if( $ref eq 'ARRAY' ) {
           if( 1 < @$var_p ) {
               $result = Dumper(@$var_p);
           }
           else {
               $result = shift @$var_p;
           }
        }
        elsif( $ref eq 'HASH' ) {
           $result = Dumper(%$var_p);
        }
        else {
           $result = Dumper($var_p);
        }
   }
   else {
       $result  = $var_p;
   }
   $result;
}



######
# Cover function for &Test::plan that sets the proper 'Test::TestLevel'
# and outputs some info on the current site
#
sub plan
{
   &Test::plan( @_ );

   ###############
   #
   # Establish default for Test and Data::Dumper
   #
   # Test 1.24 resets global variables in plan which
   # never happens in 1.15
   #
   $Data::Dumper::Terse = 1;
   $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";
# Number Storage: $tech_p->{Internal_Number}
# Test::Tech    : $VERSION
# Data::Dumper  : $Data::Dumper::VERSION
# =cut
EOF

   1
}


######
#
# Cover function for &Test::ok that adds capability to test
# complex data structures.
#
sub ok
{
   my ($actual_result, $expected_result, $diagnostic, $name) = @_;

   print $Test::TESTOUT "# $name\n" if $name;
   if($tech_p->{Skip_Tests}) { # skip rest of tests switch
       print $Test::TESTOUT "# Test invalid because of previous failure.\n";
       &Test::skip( 1, 0, '');
       return 1;
   }

   &Test::ok(stringify($actual_result), stringify($expected_result), $diagnostic);
}


######
#
#
sub skip
{
   my ($mod, $actual_result, $expected_result, $diagnostic, $name) = @_;

   print $Test::TESTOUT "# $name\n" if $name;

   if($tech_p->{Skip_Tests}) {  # skip rest of tests switch
       print $Test::TESTOUT "# Test invalid because of previous failure.\n";
       &Test::skip( 1, 0, '');
       return 1;
   }

   &Test::skip($mod, stringify($actual_result), stringify($expected_result), $diagnostic);

}


######
#
#
sub skip_tests
{
   my ($value) =  @_;
   my $result = $tech_p->{Skip_Tests};
   $tech_p->{Skip_Tests} = $value if defined $value;
   $result;
}



#######
# This accesses the values in the %tech hash
#
# Use a dot notation for following down layers
# of hashes of hashes
#
sub tech_config
{
    my ($key, @values) = @_;
    my @keys = split /\./, $key;

    #########
    # Follow the hash with the current
    # dot index until there are no more
    # hashes. Hopefully the dot hash
    # notation matches the structure.
    #
    my $key_p = $tech_p;
    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};
    return $current_value if ref($current_value) eq 'HASH';
    if (defined $values[0]) {
        if(ref($key_p->{$key}) eq 'ARRAY') {
            if( ref($values[0]) eq 'ARRAY' ) {
                $key_p->{$key} = $values[0];
            }
            else {
                my @current_value = @{$key_p->{$key}};
                $key_p->{$key} = \@values;
                return @current_value;
            }
        }
        elsif( ref($key_p->{$key}) ) {
            $current_value = ${$key_p->{$key}};
            ${$key_p->{$key}} = $values[0];
        }
        else {
            $key_p->{$key} = $values[0];
        }
    }

    $current_value;

}



######
# Demo
#
sub demo
{
   my ($quoted_expression, @expression_results) = @_;

   #######
   # 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_results;

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

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

}

1


__END__