File Coverage

blib/lib/Test/Aggregate/Base.pm

Criterion	Covered	Total	%
statement	103	115	89.5
branch	33	44	75.0
condition	9	11	81.8
subroutine	35	35	100.0
pod	0	1	0.0
total	180	206	87.3

package Test::Aggregate::Base;

use strict;
use warnings;

use Carp 'croak';
use Test::Builder::Module;
use Test::More;
use File::Find;

use vars qw(@ISA @EXPORT @EXPORT_OK);
@ISA    = qw(Test::Builder::Module);

our $VERSION = '0.373';
$VERSION = eval $VERSION;

our $_pid = $$;

BEGIN {
    $ENV{TEST_AGGREGATE} = 1;
    *CORE::GLOBAL::exit = sub {
        my ($package, $filename, $line) = caller;

      # Warn about exit being called unless there's been a fork()
      # (in which case some form of exit is expected).
      if( $_pid == $$ ){

        print STDERR <<"        END_EXIT_WARNING";
********
WARNING!
exit called under Test::Aggregate at:
File:    $filename
Package: $package
Line:    $line
WARNING!
********
        END_EXIT_WARNING

      }

        exit(@_);
    };
};

END {   # for VMS
    delete $ENV{TEST_AGGREGATE};
}

sub _code_attributes {
    qw/
        setup
        teardown
        startup
        shutdown
    /;
}

sub new {
    my ( $class, $arg_for ) = @_;

    unless ( exists $arg_for->{dirs} || exists $arg_for->{tests} ) {
        Test::More::BAIL_OUT("You must supply 'dirs' or 'tests'");
    }
    if ( exists $arg_for->{tests} && 'ARRAY' ne ref $arg_for->{tests} ) {
        Test::More::BAIL_OUT(
            "Argument for Test::Aggregate 'tests' key must be an array reference"
        );
    }

    $arg_for->{test_nowarnings} = 1 unless exists $arg_for->{test_nowarnings};
    $arg_for->{set_filenames}   = 1 unless exists $arg_for->{set_filenames};
    $arg_for->{findbin}         = 1 unless exists $arg_for->{findbin};
    my $dirs = delete $arg_for->{dirs};
    if ( defined $dirs ) {
        $dirs = [$dirs] if 'ARRAY' ne ref $dirs;
    }
    else {
        $dirs = [];
    }

    my $matching = qr//;
    if ( $arg_for->{matching} ) {
        $matching = delete $arg_for->{matching};
        unless ( 'Regexp' eq ref $matching ) {
            croak("Argument for 'matching' must be a pre-compiled regex");
        }
    }

    my $has_code_attributes;
    foreach my $attribute ( $class->_code_attributes ) {
        if ( my $ref = $arg_for->{$attribute} ) {
            if ( 'CODE' ne ref $ref ) {
                croak("Attribute ($attribute) must be a code reference");
            }
            else {
                $has_code_attributes++;
            }
        }
    }

    my $self = bless {
        dirs              => $dirs,
        matching          => $matching,
        _no_streamer      => 0,
        _packages         => [],
        aggregate_program => $0,
    } => $class;

    if ( delete $arg_for->{check_plan} ) {
        Carp::carp("'check_plan' is now deprecated and a no-op.");
    }
    $self->{$_} = delete $arg_for->{$_} foreach (
        qw/
        dry
        dump
        findbin
        no_generate_plan
        set_filenames
        shuffle
        test_nowarnings
        tests
        tidy
        verbose
        /,
        $class->_code_attributes
    );
    $self->{tests} ||= [];

    if ( my @keys = keys %$arg_for ) {
        local $" = ', ';
        croak("Unknown keys to &new:  (@keys)");
    }

    if ($has_code_attributes) {
        eval "use Data::Dump::Streamer";
        if ( my $error = $@ ) {
            $self->{_no_streamer} = 1;
            if ( my $dump = $self->_dump ) {
                warn <<"                END_WARNING";
Dump file ($dump) cannot be generated.  A code attributes was requested but
we cannot load Data::Dump::Streamer:  $error.
                END_WARNING
                $self->{dump} = '';
            }
        }
    }

    return $self;
}

# set from user data

sub _dump            { shift->{dump} || '' }
sub _dry             { shift->{dry} }
sub _should_shuffle  { shift->{shuffle} }
sub _matching        { shift->{matching} }
sub _set_filenames   { shift->{set_filenames} }
sub _findbin         { shift->{findbin} }
sub _dirs            { @{ shift->{dirs} } }
sub _startup         { shift->{startup} }
sub _shutdown        { shift->{shutdown} }
sub _setup           { shift->{setup} }
sub _teardown        { shift->{teardown} }
sub _tests           { @{ shift->{tests} } }
sub _tidy            { shift->{tidy} }
sub _test_nowarnings { shift->{test_nowarnings} }

sub _verbose        {
    my $self = shift;
    $self->{verbose} ? $self->{verbose} : 0;
}

# set from internal data
sub _no_streamer    { shift->{_no_streamer} }
sub _packages       { @{ shift->{_packages} } }

sub _get_tests {
    my $self = shift;
    my @tests;
    my $matching = $self->_matching;
    if ( $self->_dirs ) {
        find( {
                no_chdir => 1,
                wanted   => sub {
                    push @tests => $File::Find::name if /\.t\z/ && /$matching/;
                }
        }, $self->_dirs );
    }
    push @tests => $self->_tests;

    if ( $self->_should_shuffle ) {
        $self->_shuffle(@tests);
    }
    else {
        @tests = sort @tests;
    }
    return @tests;
}

sub _shuffle {
    my $self = shift;

    # Fisher-Yates shuffle
    my $i = @_;
    while ($i) {
        my $j = rand $i--;
        @_[ $i, $j ] = @_[ $j, $i ];
    }
    return;
}

sub _get_package {
    my ( $class, $file ) = @_;
    $file =~ s/\W//g;
    return $file;
}

1;

__END__

=encoding utf-8

=head1 NAME

Test::Aggregate::Base - Base class for aggregated tests.

=head1 VERSION

Version 0.373

=head1 SYNOPSIS

    use base 'Test::Aggregate::base';

    sub run { ... }


=head1 DESCRIPTION

This module is for internal use only.

=head1 AUTHOR

Curtis Poe, C<< <ovid at cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests to
C<bug-test-aggregate at rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Aggregate>.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Test::Aggregate::Base

You can also find information oneline:

L<http://metacpan.org/release/Test-Aggregate>

=head1 ACKNOWLEDGEMENTS

Many thanks to mauzo (L<http://use.perl.org/~mauzo/> for helping me find the
'skip_all' bug.

Thanks to Johan Lindström for pointing me to Apache::Registry.

=head1 COPYRIGHT & LICENSE

Copyright 2007 Curtis "Ovid" Poe, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut