libbio-perl-perl 1.6.924-1 / 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);

# ABSTRACT: a common base for all Bioperl test scripts
# AUTHOR:   Sendu Bala <bix@sendu.me.uk>
# OWNER:    Sendu Bala
# LICENSE:  Perl_5

# CONTRIBUTOR: Chris Fields <cjfields@bioperl.org>

=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().

=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 suppied, 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 suppied, 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 {
    return $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 {
    return $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 requirments 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;