Bio/Root/Test.pm

   1 package Bio::Root::Test;
   2 use strict;
   3 use warnings;
   4
   5 # According to Ovid, 'use base' can override signal handling, so use
   6 # old-fashioned way. This should be a Test::Builder::Module subclass
   7 # for consistency (as are any Test modules)
   8 use Test::Most;
   9 use Test::Builder;
  10 use Test::Builder::Module;
  11 use File::Temp qw(tempdir);
  12 use File::Spec;
  13
  14 our @ISA = qw(Test::Builder::Module);
  15
  16 =head1 SYNOPSIS
  17
  18   use lib '.'; # (for core package tests only)
  19   use Bio::Root::Test;
  20
  21   test_begin(-tests => 20,
  22              -requires_modules => [qw(IO::String XML::Parser)],
  23              -requires_networking => 1);
  24
  25   my $do_network_tests = test_network();
  26   my $output_debugging = test_debug();
  27
  28   # Bio::Root::Test rewraps Test::Most, so one can carry out tests with
  29   # Test::More, Test::Exception, Test::Warn, Test::Deep, Test::Diff syntax
  30
  31   SKIP: {
  32     # these tests need version 2.6 of Optional::Module to work
  33     test_skip(-tests => 10, -requires_module => 'Optional::Module 2.6');
  34     use_ok('Optional::Module');
  35
  36     # 9 other optional tests that need Optional::Module
  37   }
  38
  39   SKIP: {
  40     test_skip(-tests => 10, -requires_networking => 1);
  41
  42     # 10 optional tests that require internet access (only makes sense in the
  43     # context of a script that doesn't use -requires_networking in the call to
  44     # &test_begin)
  45   }
  46
  47   # in unix terms, we want to test with a file t/data/input_file.txt
  48   my $input_file = test_input_file('input_file.txt');
  49
  50   # we want the name of a file we can write to, that will be automatically
  51   # deleted when the test script finishes
  52   my $output_file = test_output_file();
  53
  54   # we want the name of a directory we can store files in, that will be
  55   # automatically deleted when the test script finishes
  56   my $output_dir = test_output_dir();
  57
  58 =head1 DESCRIPTION
  59
  60 This provides a common base for all BioPerl test scripts. It safely handles the
  61 loading of Test::Most, itself a simple wrapper around several highly used test
  62 modules: Test::More, Test::Exception, Test::Warn, Test::Deep, and Test::Diff. It
  63 also presents an interface to common needs such as skipping all tests if
  64 required modules aren't present or if network tests haven't been enabled. See
  65 test_begin().
  66
  67 In the same way, it allows you to skip just a subset of tests for those same
  68 reasons, in addition to requiring certain executables and environment variables.
  69 See test_skip().
  70
  71 It also has two further methods that let you decide if network tests should be
  72 run, and if debugging information should be printed. See test_network() and
  73 test_debug().
  74
  75 Finally, it presents a consistent way of getting the path to input and output
  76 files. See test_input_file(), test_output_file() and test_output_dir().
  77
  78 =head1 AUTHOR Sendu Bala
  79
  80 Chris Fields
  81
  82 =cut
  83
  84 # TODO: Evil magic ahead; can we clean this up?
  85
  86 {
  87     my $Tester = Test::Builder->new;
  88
  89     no warnings 'redefine';
  90
  91     sub Test::Warn::_canonical_got_warning {
  92         my ( $called_from, $msg ) = @_;
  93         my $warn_kind
  94             = $called_from eq 'Carp'
  95             ? 'carped'
  96             : ( $called_from =~ /Bio::/ ? 'Bioperl' : 'warn' );
  97
  98         my $warning;
  99         if ( $warn_kind eq 'Bioperl' ) {
 100             ($warning)
 101                 = $msg
 102                 =~ /\n--------------------- WARNING ---------------------\nMSG: (.+)\n---------------------------------------------------\n$/m;
 103             $warning ||= $msg;    # shouldn't ever happen
 104         } else {
 105             my @warning_stack = split /\n/, $msg; # some stuff of uplevel is included
 106             $warning = $warning_stack[0];
 107         }
 108
 109         return { $warn_kind => $warning };    # return only the real message
 110     }
 111
 112     sub Test::Warn::_diag_found_warning {
 113         my @warns = @_;
 114         foreach my $warn (@warns) {
 115             if ( ref($warn) eq 'HASH' ) {
 116                 ${$warn}{carped}
 117                     ? $Tester->diag("found carped warning: ${$warn}{carped}")
 118                     : (
 119                     ${$warn}{Bioperl} ? $Tester->diag(
 120                         "found Bioperl warning: ${$warn}{Bioperl}")
 121                     : $Tester->diag("found warning: ${$warn}{warn}")
 122                     );
 123             } else {
 124                 $Tester->diag("found warning: $warn");
 125             }
 126         }
 127         $Tester->diag("didn't find a warning") unless @warns;
 128     }
 129
 130     sub Test::Warn::_cmp_got_to_exp_warning {
 131         my ( $got_kind, $got_msg ) = %{ shift() };
 132         my ( $exp_kind, $exp_msg ) = %{ shift() };
 133         return 0 if ( $got_kind eq 'warn' ) && ( $exp_kind eq 'carped' );
 134
 135         my $cmp;
 136         if ( $got_kind eq 'Bioperl' ) {
 137             $cmp = $got_msg =~ /^\Q$exp_msg\E$/;
 138         } else {
 139             $cmp = $got_msg =~ /^\Q$exp_msg\E at \S+ line \d+\.?$/;
 140         }
 141
 142         return $cmp;
 143     }
 144 }
 145
 146 our @EXPORT = (
 147     @Test::Most::EXPORT,
 148
 149     #@Bio::Root::Test::Warn::EXPORT,
 150     # Test::Warn method wrappers
 151
 152     # BioPerl-specific
 153     qw(
 154         test_begin
 155         test_skip
 156         test_output_file
 157         test_output_dir
 158         test_input_file
 159         test_network
 160         test_email
 161         test_debug
 162         float_is
 163         )
 164 );
 165
 166 our $GLOBAL_FRAMEWORK = 'Test::Most';
 167 our @TEMP_FILES;
 168
 169 =head2 test_begin
 170
 171  Title   : test_begin
 172  Usage   : test_begin(-tests => 20);
 173  Function: Begin your test script, setting up the plan (skip all tests, or run
 174            them all)
 175  Returns : True if tests should be run.
 176  Args    : -tests               => int (REQUIRED, the number of tests that will
 177                                         be run)
 178            -requires_modules    => []  (array ref of module names that are
 179                                         required; if any don't load, all tests
 180                                         will be skipped. To specify a required
 181                                         version of a module, include the version
 182                                         number after the module name, separated
 183                                         by a space)
 184            -requires_module     => str (as above, but for just one module)
 185            -requires_networking => 1|0 (default 0, if true all tests will be
 186                                         skipped if network tests haven't been
 187                                         enabled in Build.PL)
 188            -requires_email      => 1   (if true the desired number of tests will
 189                                         be skipped if either network tests
 190                                         haven't been enabled in Build.PL or an
 191                                         email hasn't been entered)
 192            -excludes_os         => str (default none, if OS supplied, all tests
 193                                         will skip if running on that OS (eg.
 194                                         'mswin'))
 195            -framework           => str (default 'Test::Most', the Test module
 196                                         to load. NB: experimental, avoid using)
 197
 198            Note, supplying -tests => 0 is possible, allowing you to skip all
 199            tests in the case that a test script is testing deprecated modules
 200            that have yet to be removed from the distribution
 201
 202 =cut
 203
 204 sub test_begin {
 205     my ( $skip_all, $tests, $framework ) = _skip(@_);
 206     $GLOBAL_FRAMEWORK = $framework;
 207
 208     if ( $framework eq 'Test::Most' ) {
 209
 210        # ideally we'd delay loading Test::Most until this point, but see BEGIN
 211        # block
 212
 213         if ($skip_all) {
 214             eval "plan skip_all => '$skip_all';";
 215         } elsif ( defined $tests && $tests == 0 ) {
 216             eval
 217                 "plan skip_all => 'These modules are now probably deprecated';";
 218         } elsif ($tests) {
 219             eval "plan tests => $tests;";
 220         }
 221
 222         return 1;
 223     }
 224
 225     # go ahead and add support for other frameworks here
 226     else {
 227         die "Only Test::Most is supported at the current time\n";
 228     }
 229
 230     return 0;
 231 }
 232
 233 =head2 test_skip
 234
 235  Title   : test_skip
 236  Usage   : SKIP: {
 237                    test_skip(-tests => 10,
 238                              -requires_module => 'Optional::Module 2.01');
 239                    # 10 tests that need v2.01 of Optional::Module
 240            }
 241  Function: Skip a subset of tests for one of several common reasons: missing one
 242            or more optional modules, network tests haven't been enabled, a
 243            required binary isn't present, or an environmental variable isn't set
 244  Returns : n/a
 245  Args    : -tests               => int (REQUIRED, the number of tests that are
 246                                         to be skipped in the event one of the
 247                                         following options isn't satisfied)
 248            -requires_modules    => []  (array ref of module names that are
 249                                         required; if any don't load, the desired
 250                                         number of tests will be skipped. To
 251                                         specify a required version of a module,
 252                                         include the version number after the
 253                                         module name, separated by a space)
 254            -requires_module     => str (as above, but for just one module)
 255            -requires_executable => Bio::Tools::Run::WrapperBase instance
 256                                        (checks WrapperBase::executable for the
 257                                         presence of a binary, skips if absent)
 258            -requires_env        => str (checks %ENV for a specific env. variable,
 259                                         skips if absent)
 260            -excludes_os         => str (default none, if OS supplied, desired num
 261                                         of tests will skip if running on that OS
 262                                         (eg. 'mswin'))
 263            -requires_networking => 1   (if true the desired number of tests will
 264                                         be skipped if network tests haven't been
 265                                         enabled in Build.PL)
 266            -requires_email      => 1   (if true the desired number of tests will
 267                                         be skipped if either network tests
 268                                         haven't been enabled in Build.PL or an
 269                                         email hasn't been entered)
 270
 271 =cut
 272
 273 sub test_skip {
 274     my ( $skip, $tests, $framework ) = _skip(@_);
 275     $tests || die "-tests must be a number greater than 0";
 276
 277     if ( $framework eq 'Test::Most' ) {
 278         if ($skip) {
 279             eval "skip('$skip', $tests);";
 280         }
 281     }
 282
 283     # go ahead and add support for other frameworks here
 284     else {
 285         die "Only Test::Most is supported at the current time\n";
 286     }
 287 }
 288
 289 =head2 test_output_file
 290
 291  Title   : test_output_file
 292  Usage   : my $output_file = test_output_file();
 293  Function: Get the full path of a file suitable for writing to.
 294            When your test script ends, the file will be automatically deleted.
 295  Returns : string (file path)
 296  Args    : none
 297
 298 =cut
 299
 300 sub test_output_file {
 301     die "test_output_file takes no args\n" if @_;
 302
 303     # RT 48813
 304     my $tmp = File::Temp->new();
 305     push( @TEMP_FILES, $tmp );
 306     close($tmp);    # Windows needs this
 307     return $tmp->filename;
 308 }
 309
 310 =head2 test_output_dir
 311
 312  Title   : test_output_dir
 313  Usage   : my $output_dir = test_output_dir();
 314  Function: Get the full path of a directory suitable for storing temporary files
 315            in.
 316            When your test script ends, the directory and its contents will be
 317            automatically deleted.
 318  Returns : string (path)
 319  Args    : none
 320
 321 =cut
 322
 323 sub test_output_dir {
 324     die "test_output_dir takes no args\n" if @_;
 325
 326     return tempdir( CLEANUP => 1 );
 327 }
 328
 329 =head2 test_input_file
 330
 331  Title   : test_input_file
 332  Usage   : my $input_file = test_input_file();
 333  Function: Get the path of a desired input file stored in the standard location
 334            (currently t/data), but correct for all platforms.
 335  Returns : string (file path)
 336  Args    : list of strings (ie. at least the input filename, preceded by the
 337            names of any subdirectories within t/data)
 338            eg. for the file t/data/in.file pass 'in.file', for the file
 339            t/data/subdir/in.file, pass ('subdir', 'in.file')
 340
 341 =cut
 342
 343 sub test_input_file {
 344     return File::Spec->catfile( 't', 'data', @_ );
 345 }
 346
 347 =head2 test_network
 348
 349  Title   : test_network
 350  Usage   : my $do_network_tests = test_network();
 351  Function: Ask if network tests should be run.
 352  Returns : boolean
 353  Args    : none
 354
 355 =cut
 356
 357 sub test_network {
 358     require Module::Build;
 359     my $build = Module::Build->current();
 360     return
 361            $build->notes('network')
 362         || $ENV{AUTHOR_TESTING}
 363         || $ENV{RELEASE_TESTING};
 364 }
 365
 366 =head2 test_email
 367
 368  Title   : test_email
 369  Usage   : my $do_network_tests = test_email();
 370  Function: Ask if email address provided
 371  Returns : boolean
 372  Args    : none
 373
 374 =cut
 375
 376 sub test_email {
 377     require Module::Build;
 378     my $build = Module::Build->current();
 379
 380     # this should not be settable unless the network tests work
 381     return
 382            $build->notes('email')
 383         || $ENV{AUTHOR_TESTING}
 384         || $ENV{RELEASE_TESTING};
 385 }
 386
 387 =head2 test_debug
 388
 389  Title   : test_debug
 390  Usage   : my $output_debugging = test_debug();
 391  Function: Ask if debugging information should be output.
 392  Returns : boolean
 393  Args    : none
 394
 395 =cut
 396
 397 sub test_debug {
 398     return $ENV{'BIOPERLDEBUG'} || 0;
 399 }
 400
 401 =head2 float_is
 402
 403  Title   : float_is
 404  Usage   : float_is($val1, $val2);
 405  Function: test two floating point values for equality
 406  Returns : Boolean based on test (can use in combination with diag)
 407  Args    : two scalar values (floating point numbers) (required via prototype)
 408            test message (optional)
 409
 410 =cut
 411
 412 sub float_is ($$;$) {
 413     my ( $val1, $val2, $message ) = @_;
 414
 415     # catch any potential undefined values and directly compare
 416     if ( ! defined $val1 || ! defined $val2 ) {
 417         is( $val1, $val2, $message );
 418     } else {
 419         is( sprintf( "%g", $val1 ), sprintf( "%g", $val2 ), $message );
 420     }
 421 }
 422
 423 =head2 _skip
 424
 425 Decide if should skip and generate skip message
 426 =cut
 427
 428 sub _skip {
 429     my %args = @_;
 430
 431     # handle input strictly
 432     my $tests = $args{'-tests'};
 433
 434 #(defined $tests && $tests =~ /^\d+$/) || die "-tests must be supplied and be an int\n";
 435     delete $args{'-tests'};
 436
 437     my $req_mods = $args{'-requires_modules'};
 438     delete $args{'-requires_modules'};
 439     my @req_mods;
 440     if ($req_mods) {
 441         ref($req_mods) eq 'ARRAY'
 442             || die "-requires_modules takes an array ref\n";
 443         @req_mods = @{$req_mods};
 444     }
 445     my $req_mod = $args{'-requires_module'};
 446     delete $args{'-requires_module'};
 447     if ($req_mod) {
 448         ref($req_mod) && die "-requires_module takes a string\n";
 449         push( @req_mods, $req_mod );
 450     }
 451
 452     my $req_net = $args{'-requires_networking'};
 453     delete $args{'-requires_networking'};
 454
 455     my $req_email = $args{'-requires_email'};
 456     delete $args{'-requires_email'};
 457
 458     my $req_env = $args{'-requires_env'};
 459     delete $args{'-requires_env'};
 460
 461     # strip any leading $ in case someone passes $FOO instead of 'FOO'
 462     $req_env =~ s{^\$}{} if $req_env;
 463
 464     my $req_exe = $args{'-requires_executable'};
 465     delete $args{'-requires_executable'};
 466
 467     if ($req_exe
 468         && (   ! ref($req_exe)
 469             || ! $req_exe->isa('Bio::Tools::Run::WrapperBase') )
 470         ) {
 471         die
 472             "-requires_exe takes an argument of type Bio::Tools::Run::WrapperBase";
 473     }
 474
 475     my $os = $args{'-excludes_os'};
 476     delete $args{'-excludes_os'};
 477
 478     my $framework = $args{'-framework'} || $GLOBAL_FRAMEWORK;
 479     delete $args{'-framework'};
 480
 481     # catch user mistakes
 482     while ( my ( $key, $val ) = each %args ) {
 483         die
 484             "unknown argument '$key' supplied, did you mistake 'required...' for 'requires...'?\n";
 485     }
 486
 487     # test user requirements and return
 488     if ($os) {
 489         if ( $^O =~ /$os/i ) {
 490             return ( 'Not compatible with your Operating System',
 491                 $tests, $framework );
 492         }
 493     }
 494
 495     foreach my $mod (@req_mods) {
 496         my $skip = _check_module($mod);
 497         if ($skip) {
 498             return ( $skip, $tests, $framework );
 499         }
 500     }
 501
 502     if ( $req_net && ! test_network() ) {
 503         return ( 'Network tests have not been requested', $tests,
 504             $framework );
 505     }
 506
 507     if ( $req_email && ! test_email() ) {
 508         return ( 'Valid email not provided; required for tests',
 509             $tests, $framework );
 510     }
 511
 512     if ($req_exe) {
 513         my $eval = eval { $req_exe->executable };
 514         if ( $@ or not defined $eval ) {
 515             my $msg
 516                 = 'Required executable for '
 517                 . ref($req_exe)
 518                 . ' is not present';
 519             diag($msg);
 520             return ( $msg, $tests, $framework );
 521         }
 522     }
 523
 524     if ( $req_env && ! exists $ENV{$req_env} ) {
 525         my $msg
 526             = 'Required environment variable $' . $req_env . ' is not set';
 527         diag($msg);
 528         return ( $msg, $tests, $framework );
 529     }
 530
 531     return ( '', $tests, $framework );
 532 }
 533
 534 =head2 _check_module
 535
 536 =cut
 537
 538 sub _check_module {
 539     my $mod = shift;
 540
 541     my $desired_version;
 542     if ( $mod =~ /(\S+)\s+(\S+)/ ) {
 543         $mod             = $1;
 544         $desired_version = $2;
 545     }
 546
 547     eval "require $mod;";
 548
 549     if ($@) {
 550         if ( $@ =~ /Can't locate/ ) {
 551             return
 552                 "The optional module $mod (or dependencies thereof) was not installed";
 553         } else {
 554             return
 555                 "The optional module $mod generated the following error: \n$@";
 556         }
 557     } elsif ($desired_version) {
 558         no strict 'refs';
 559         unless ( defined ${"${mod}::VERSION"} ) {
 560             return
 561                 "The optional module $mod didn't have a version, but we want v$desired_version";
 562         } elsif ( ${"${mod}::VERSION"} < $desired_version ) {
 563             return
 564                 "The optional module $mod was out of date (wanted v$desired_version)";
 565         }
 566     }
 567
 568     return;
 569 }
 570
 571 1;