libbio-perl-perl 1.7.2-2 / usr / share / perl5 / Bio / Root / Test.pm

package Bio::Root::Test;
use strict;
use warnings;

# According to Ovid, 'use base' can override signal handling, so use
# old-fashioned way. This should be a Test::Builder::Module subclass
# for consistency (as are any Test modules)
use Test::Most;
use Test::Builder;
use Test::Builder::Module;
use File::Temp qw(tempdir);
use File::Spec;

our @ISA = qw(Test::Builder::Module);

=head1 SYNOPSIS

  use lib '.'; # (for core package tests only)
  use Bio::Root::Test;

  test_begin(-tests => 20,
             -requires_modules => [qw(IO::String XML::Parser)],
             -requires_networking => 1);

  my $do_network_tests = test_network();
  my $output_debugging = test_debug();

  # Bio::Root::Test rewraps Test::Most, so one can carry out tests with
  # Test::More, Test::Exception, Test::Warn, Test::Deep, Test::Diff syntax

  SKIP: {
    # these tests need version 2.6 of Optional::Module to work
    test_skip(-tests => 10, -requires_module => 'Optional::Module 2.6');
    use_ok('Optional::Module');

    # 9 other optional tests that need Optional::Module
  }

  SKIP: {
    test_skip(-tests => 10, -requires_networking => 1);

    # 10 optional tests that require internet access (only makes sense in the
    # context of a script that doesn't use -requires_networking in the call to
    # &test_begin)
  }

  # in unix terms, we want to test with a file t/data/input_file.txt
  my $input_file = test_input_file('input_file.txt');

  # we want the name of a file we can write to, that will be automatically
  # deleted when the test script finishes
  my $output_file = test_output_file();

  # we want the name of a directory we can store files in, that will be
  # automatically deleted when the test script finishes
  my $output_dir = test_output_dir();

=head1 DESCRIPTION

This provides a common base for all BioPerl test scripts. It safely handles the
loading of Test::Most, itself a simple wrapper around several highly used test
modules: Test::More, Test::Exception, Test::Warn, Test::Deep, and Test::Diff. It
also presents an interface to common needs such as skipping all tests if
required modules aren't present or if network tests haven't been enabled. See
test_begin().

In the same way, it allows you to skip just a subset of tests for those same
reasons, in addition to requiring certain executables and environment variables.
See test_skip().

It also has two further methods that let you decide if network tests should be
run, and if debugging information should be printed. See test_network() and
test_debug().

Finally, it presents a consistent way of getting the path to input and output
files. See test_input_file(), test_output_file() and test_output_dir().

=head1 AUTHOR Sendu Bala

Chris Fields

=cut

# TODO: Evil magic ahead; can we clean this up?

{
    my $Tester = Test::Builder->new;

    no warnings 'redefine';

    sub Test::Warn::_canonical_got_warning {
        my ( $called_from, $msg ) = @_;
        my $warn_kind
            = $called_from eq 'Carp'
            ? 'carped'
            : ( $called_from =~ /Bio::/ ? 'Bioperl' : 'warn' );

        my $warning;
        if ( $warn_kind eq 'Bioperl' ) {
            ($warning)
                = $msg
                =~ /\n--------------------- WARNING ---------------------\nMSG: (.+)\n---------------------------------------------------\n$/m;
            $warning ||= $msg;    # shouldn't ever happen
        } else {
            my @warning_stack = split /\n/, $msg; # some stuff of uplevel is included
            $warning = $warning_stack[0];
        }

        return { $warn_kind => $warning };    # return only the real message
    }

    sub Test::Warn::_diag_found_warning {
        my @warns = @_;
        foreach my $warn (@warns) {
            if ( ref($warn) eq 'HASH' ) {
                ${$warn}{carped}
                    ? $Tester->diag("found carped warning: ${$warn}{carped}")
                    : (
                    ${$warn}{Bioperl} ? $Tester->diag(
                        "found Bioperl warning: ${$warn}{Bioperl}")
                    : $Tester->diag("found warning: ${$warn}{warn}")
                    );
            } else {
                $Tester->diag("found warning: $warn");
            }
        }
        $Tester->diag("didn't find a warning") unless @warns;
    }

    sub Test::Warn::_cmp_got_to_exp_warning {
        my ( $got_kind, $got_msg ) = %{ shift() };
        my ( $exp_kind, $exp_msg ) = %{ shift() };
        return 0 if ( $got_kind eq 'warn' ) && ( $exp_kind eq 'carped' );

        my $cmp;
        if ( $got_kind eq 'Bioperl' ) {
            $cmp = $got_msg =~ /^\Q$exp_msg\E$/;
        } else {
            $cmp = $got_msg =~ /^\Q$exp_msg\E at \S+ line \d+\.?$/;
        }

        return $cmp;
    }
}

our @EXPORT = (
    @Test::Most::EXPORT,

    #@Bio::Root::Test::Warn::EXPORT,
    # Test::Warn method wrappers

    # BioPerl-specific
    qw(
        test_begin
        test_skip
        test_output_file
        test_output_dir
        test_input_file
        test_network
        test_email
        test_debug
        float_is
        )
);

our $GLOBAL_FRAMEWORK = 'Test::Most';
our @TEMP_FILES;

=head2 test_begin

 Title   : test_begin
 Usage   : test_begin(-tests => 20);
 Function: Begin your test script, setting up the plan (skip all tests, or run
           them all)
 Returns : True if tests should be run.
 Args    : -tests               => int (REQUIRED, the number of tests that will
                                        be run)
           -requires_modules    => []  (array ref of module names that are
                                        required; if any don't load, all tests
                                        will be skipped. To specify a required
                                        version of a module, include the version
                                        number after the module name, separated
                                        by a space)
           -requires_module     => str (as above, but for just one module)
           -requires_networking => 1|0 (default 0, if true all tests will be
                                        skipped if network tests haven't been
                                        enabled in Build.PL)
           -requires_email      => 1   (if true the desired number of tests will
                                        be skipped if either network tests
                                        haven't been enabled in Build.PL or an
                                        email hasn't been entered)
           -excludes_os         => str (default none, if OS supplied, all tests
                                        will skip if running on that OS (eg.
                                        'mswin'))
           -framework           => str (default 'Test::Most', the Test module
                                        to load. NB: experimental, avoid using)

           Note, supplying -tests => 0 is possible, allowing you to skip all
           tests in the case that a test script is testing deprecated modules
           that have yet to be removed from the distribution

=cut

sub test_begin {
    my ( $skip_all, $tests, $framework ) = _skip(@_);
    $GLOBAL_FRAMEWORK = $framework;

    if ( $framework eq 'Test::Most' ) {

       # ideally we'd delay loading Test::Most until this point, but see BEGIN
       # block

        if ($skip_all) {
            eval "plan skip_all => '$skip_all';";
        } elsif ( defined $tests && $tests == 0 ) {
            eval
                "plan skip_all => 'These modules are now probably deprecated';";
        } elsif ($tests) {
            eval "plan tests => $tests;";
        }

        return 1;
    }

    # go ahead and add support for other frameworks here
    else {
        die "Only Test::Most is supported at the current time\n";
    }

    return 0;
}

=head2 test_skip

 Title   : test_skip
 Usage   : SKIP: {
                   test_skip(-tests => 10,
                             -requires_module => 'Optional::Module 2.01');
                   # 10 tests that need v2.01 of Optional::Module
           }
 Function: Skip a subset of tests for one of several common reasons: missing one
           or more optional modules, network tests haven't been enabled, a
           required binary isn't present, or an environmental variable isn't set
 Returns : n/a
 Args    : -tests               => int (REQUIRED, the number of tests that are
                                        to be skipped in the event one of the
                                        following options isn't satisfied)
           -requires_modules    => []  (array ref of module names that are
                                        required; if any don't load, the desired
                                        number of tests will be skipped. To
                                        specify a required version of a module,
                                        include the version number after the
                                        module name, separated by a space)
           -requires_module     => str (as above, but for just one module)
           -requires_executable => Bio::Tools::Run::WrapperBase instance
                                       (checks WrapperBase::executable for the
                                        presence of a binary, skips if absent)
           -requires_env        => str (checks %ENV for a specific env. variable,
                                        skips if absent)
           -excludes_os         => str (default none, if OS supplied, desired num
                                        of tests will skip if running on that OS
                                        (eg. 'mswin'))
           -requires_networking => 1   (if true the desired number of tests will
                                        be skipped if network tests haven't been
                                        enabled in Build.PL)
           -requires_email      => 1   (if true the desired number of tests will
                                        be skipped if either network tests
                                        haven't been enabled in Build.PL or an
                                        email hasn't been entered)

=cut

sub test_skip {
    my ( $skip, $tests, $framework ) = _skip(@_);
    $tests || die "-tests must be a number greater than 0";

    if ( $framework eq 'Test::Most' ) {
        if ($skip) {
            eval "skip('$skip', $tests);";
        }
    }

    # go ahead and add support for other frameworks here
    else {
        die "Only Test::Most is supported at the current time\n";
    }
}

=head2 test_output_file

 Title   : test_output_file
 Usage   : my $output_file = test_output_file();
 Function: Get the full path of a file suitable for writing to.
           When your test script ends, the file will be automatically deleted.
 Returns : string (file path)
 Args    : none

=cut

sub test_output_file {
    die "test_output_file takes no args\n" if @_;

    # RT 48813
    my $tmp = File::Temp->new();
    push( @TEMP_FILES, $tmp );
    close($tmp);    # Windows needs this
    return $tmp->filename;
}

=head2 test_output_dir

 Title   : test_output_dir
 Usage   : my $output_dir = test_output_dir();
 Function: Get the full path of a directory suitable for storing temporary files
           in.
           When your test script ends, the directory and its contents will be
           automatically deleted.
 Returns : string (path)
 Args    : none

=cut

sub test_output_dir {
    die "test_output_dir takes no args\n" if @_;

    return tempdir( CLEANUP => 1 );
}

=head2 test_input_file

 Title   : test_input_file
 Usage   : my $input_file = test_input_file();
 Function: Get the path of a desired input file stored in the standard location
           (currently t/data), but correct for all platforms.
 Returns : string (file path)
 Args    : list of strings (ie. at least the input filename, preceded by the
           names of any subdirectories within t/data)
           eg. for the file t/data/in.file pass 'in.file', for the file
           t/data/subdir/in.file, pass ('subdir', 'in.file')

=cut

sub test_input_file {
    return File::Spec->catfile( 't', 'data', @_ );
}

=head2 test_network

 Title   : test_network
 Usage   : my $do_network_tests = test_network();
 Function: Ask if network tests should be run.
 Returns : boolean
 Args    : none

=cut

sub test_network {
    require Module::Build;
    my $build = Module::Build->current();
    return
           $build->notes('network')
        || $ENV{AUTHOR_TESTING}
        || $ENV{RELEASE_TESTING};
}

=head2 test_email

 Title   : test_email
 Usage   : my $do_network_tests = test_email();
 Function: Ask if email address provided
 Returns : boolean
 Args    : none

=cut

sub test_email {
    require Module::Build;
    my $build = Module::Build->current();

    # this should not be settable unless the network tests work
    return
           $build->notes('email')
        || $ENV{AUTHOR_TESTING}
        || $ENV{RELEASE_TESTING};
}

=head2 test_debug

 Title   : test_debug
 Usage   : my $output_debugging = test_debug();
 Function: Ask if debugging information should be output.
 Returns : boolean
 Args    : none

=cut

sub test_debug {
    return $ENV{'BIOPERLDEBUG'} || 0;
}

=head2 float_is

 Title   : float_is
 Usage   : float_is($val1, $val2);
 Function: test two floating point values for equality
 Returns : Boolean based on test (can use in combination with diag)
 Args    : two scalar values (floating point numbers) (required via prototype)
           test message (optional)

=cut

sub float_is ($$;$) {
    my ( $val1, $val2, $message ) = @_;

    # catch any potential undefined values and directly compare
    if ( ! defined $val1 || ! defined $val2 ) {
        is( $val1, $val2, $message );
    } else {
        is( sprintf( "%g", $val1 ), sprintf( "%g", $val2 ), $message );
    }
}

=head2 _skip

Decide if should skip and generate skip message
=cut

sub _skip {
    my %args = @_;

    # handle input strictly
    my $tests = $args{'-tests'};

#(defined $tests && $tests =~ /^\d+$/) || die "-tests must be supplied and be an int\n";
    delete $args{'-tests'};

    my $req_mods = $args{'-requires_modules'};
    delete $args{'-requires_modules'};
    my @req_mods;
    if ($req_mods) {
        ref($req_mods) eq 'ARRAY'
            || die "-requires_modules takes an array ref\n";
        @req_mods = @{$req_mods};
    }
    my $req_mod = $args{'-requires_module'};
    delete $args{'-requires_module'};
    if ($req_mod) {
        ref($req_mod) && die "-requires_module takes a string\n";
        push( @req_mods, $req_mod );
    }

    my $req_net = $args{'-requires_networking'};
    delete $args{'-requires_networking'};

    my $req_email = $args{'-requires_email'};
    delete $args{'-requires_email'};

    my $req_env = $args{'-requires_env'};
    delete $args{'-requires_env'};

    # strip any leading $ in case someone passes $FOO instead of 'FOO'
    $req_env =~ s{^\$}{} if $req_env;

    my $req_exe = $args{'-requires_executable'};
    delete $args{'-requires_executable'};

    if ($req_exe
        && (   ! ref($req_exe)
            || ! $req_exe->isa('Bio::Tools::Run::WrapperBase') )
        ) {
        die
            "-requires_exe takes an argument of type Bio::Tools::Run::WrapperBase";
    }

    my $os = $args{'-excludes_os'};
    delete $args{'-excludes_os'};

    my $framework = $args{'-framework'} || $GLOBAL_FRAMEWORK;
    delete $args{'-framework'};

    # catch user mistakes
    while ( my ( $key, $val ) = each %args ) {
        die
            "unknown argument '$key' supplied, did you mistake 'required...' for 'requires...'?\n";
    }

    # test user requirements and return
    if ($os) {
        if ( $^O =~ /$os/i ) {
            return ( 'Not compatible with your Operating System',
                $tests, $framework );
        }
    }

    foreach my $mod (@req_mods) {
        my $skip = _check_module($mod);
        if ($skip) {
            return ( $skip, $tests, $framework );
        }
    }

    if ( $req_net && ! test_network() ) {
        return ( 'Network tests have not been requested', $tests,
            $framework );
    }

    if ( $req_email && ! test_email() ) {
        return ( 'Valid email not provided; required for tests',
            $tests, $framework );
    }

    if ($req_exe) {
        my $eval = eval { $req_exe->executable };
        if ( $@ or not defined $eval ) {
            my $msg
                = 'Required executable for '
                . ref($req_exe)
                . ' is not present';
            diag($msg);
            return ( $msg, $tests, $framework );
        }
    }

    if ( $req_env && ! exists $ENV{$req_env} ) {
        my $msg
            = 'Required environment variable $' . $req_env . ' is not set';
        diag($msg);
        return ( $msg, $tests, $framework );
    }

    return ( '', $tests, $framework );
}

=head2 _check_module

=cut

sub _check_module {
    my $mod = shift;

    my $desired_version;
    if ( $mod =~ /(\S+)\s+(\S+)/ ) {
        $mod             = $1;
        $desired_version = $2;
    }

    eval "require $mod;";

    if ($@) {
        if ( $@ =~ /Can't locate/ ) {
            return
                "The optional module $mod (or dependencies thereof) was not installed";
        } else {
            return
                "The optional module $mod generated the following error: \n$@";
        }
    } elsif ($desired_version) {
        no strict 'refs';
        unless ( defined ${"${mod}::VERSION"} ) {
            return
                "The optional module $mod didn't have a version, but we want v$desired_version";
        } elsif ( ${"${mod}::VERSION"} < $desired_version ) {
            return
                "The optional module $mod was out of date (wanted v$desired_version)";
        }
    }

    return;
}

1;