view release on metacpan or  search on metacpan

t/Data/Test/Tech.pm  view on Meta::CPAN

    $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;

    #####

t/Data/Test/Tech.pm  view on Meta::CPAN

=head2 ok_skip

 $test_ok = skip_sub(\&subroutine, $skip_test, $actual_results, $expected_results, [@options]);
 $test_ok = skip_sub(\&subroutine, $skip_test, $actual_results, $expected_results, {@options});
 $test_ok = skip_sub(\&subroutine, $skip_test, $actual_results, $expected_results, $diagnostic, [@options]);
 $test_ok = skip_sub(\&subroutine, $skip_test, $actual_results, $expected_results, $diagnostic, {@options});
 $test_ok = skip_sub(\&subroutine, $skip_test, $actual_results, $expected_results, $diagnostic, $test_name, [@options]);
 $test_ok = skip_sub(\&subroutine, $skip_test, $actual_results, $expected_results, $diagnostic, $test_name, {@options});

The C<skip_sub> subroutine will execute the below:

 $sub_ok = &subroutine( $actual_results, $expected_results)

The C<skip_sub> subroutine will add additional information to
C<$diagnostic> and pass the C<$sub_ok> and other inputs 
along to C<skip> subroutine as follows:

 $test_ok = skip($skip_test, $sub_ok, 1, $diagnostic, $test_name, [@options]); 

=head2 skip_tests

 $skip_on = skip_tests( $on_off );
 $skip_on = skip_tests( );

The C<skip_tests> subroutine sets a flag that causes the
C<ok> and the C<skip> methods to skip testing.

=head2 stringify subroutine

 $string = stringify( $var );
 $string = stringify($var, @options); 
 $string = stringify($var, [@options]);
 $string = stringify($var, {@options});


The C<stringify> subroutine will stringify C<$var> using
the "L<Data::Secs2::stringify subroutine|Data::Secs2/stringify subroutine>" 
module only if C<$var> is a reference;
otherwise, it leaves it unchanged.

=head2 tech_config

 $old_value = tech_config( $dot_index, $new_value );

The C<tech_config> subroutine reads and writes the
below configuration variables

 dot index              contents           mode
 --------------------   --------------     --------
 Test.ntest             $Test::ntest       read only 
 Test.TESTOUT           $Test::TESTOUT     read write
 Test.TestLevel         $Test::TestLevel   read write
 Test.ONFAIL            $Test::ONFAIL      read write
 Test.TESTERR           $Test::TESTERR     read write
 Skip_Tests             # boolean          read write
 
The C<tech_config> subroutine always returns the
C<$old_value> of C<$dot_index> and only writes
the contents if C<$new_value> is defined.

The 'SCALAR' and 'ARRAY' references are transparent.
The C<tech_config> subroutine, when it senses that
the C<$dot_index> is for a 'SCALAR' and 'ARRAY' reference,
will read or write the contents instead of the reference.

The The C<tech_config> subroutine will read 'HASH" references
but will never change them. 

The variables for the top level 'Dumper' C<$dot_index> are
established by "L<Data::Dumper|Data::Dumper>" module;
for the top level 'Test', the "L<Test|Test>" module.


=head1 REQUIREMENTS

Coming soon.

=head1 DEMONSTRATION

 #########
 # perl Tech.d
 ###

~~~~~~ Demonstration overview ~~~~~

The results from executing the Perl Code 
follow on the next lines as comments. For example,

 2 + 2
 # 4

~~~~~~ The demonstration follows ~~~~~

     use File::Spec;

     use File::Package;
     my $fp = 'File::Package';

     use Text::Scrub;
     my $s = 'Text::Scrub';

     use File::SmartNL;
     my $snl = 'File::SmartNL';

     my $uut = 'Test::Tech';
 $snl->fin('techA0.t')

 # '#!perl
 ##
 ##
 #use 5.001;
 #use strict;
 #use warnings;
 #use warnings::register;
 #use vars qw($VERSION $DATE);
 #$VERSION = '0.13';
 #$DATE = '2004/04/15';

 #BEGIN {
 #   use FindBin;
 #   use File::Spec;