t/perl/Parrot_Test.t

   1 #! perl
   2 # Copyright (C) 2001-2010, Parrot Foundation.
   3 # $Id$
   4
   5 =head1 NAME
   6
   7 t/perl/Parrot_Test.t - Parrot::Test unit tests
   8
   9 =head1 SYNOPSIS
  10
  11     % prove t/perl/Parrot_Test.t
  12
  13 =head1 DESCRIPTION
  14
  15 These tests cover the basic functionality of C<Parrot::Test>.
  16
  17 =cut
  18
  19 use strict;
  20 use warnings;
  21 use Test::More;
  22 use Carp;
  23 use File::Spec;
  24 use lib qw( lib );
  25 use Parrot::Config;
  26 use IO::CaptureOutput qw| capture |;
  27 use Parrot::Config '%PConfig';
  28
  29 BEGIN {
  30     eval "use Test::Builder::Tester;";
  31     if ($@) {
  32         plan( skip_all => "Test::Builder::Tester not installed\n" );
  33         exit 0;
  34     }
  35     plan( tests => 120 );
  36 }
  37
  38 use lib qw( . lib ../lib ../../lib );
  39
  40 BEGIN {
  41     my $pre_env = exists $ENV{PARROT_TEST} ? $ENV{PARROT_TEST} : undef;
  42     use_ok('Parrot::Test') or die;
  43
  44     my $post_env = exists $ENV{PARROT_TEST} ? $ENV{PARROT_TEST} : undef;
  45     if ( defined $pre_env ) {
  46         is( $post_env, $pre_env, 'PARROT_TEST env unchanged' );
  47     }
  48     else {
  49         is( $post_env, 1, 'PARROT_TEST env set' );
  50     }
  51 }
  52
  53 can_ok( 'Parrot::Test', $_ ) for qw/
  54     c_output_is                     c_output_isnt
  55     c_output_like                   c_output_unlike
  56     example_output_is               example_output_isnt
  57     example_output_like
  58     example_error_output_is         example_error_output_isnt
  59     example_error_output_like
  60     language_error_output_is        language_error_output_isnt
  61     language_error_output_like
  62     language_output_is              language_output_isnt
  63     language_output_like
  64     pasm_error_output_is            pasm_error_output_isnt
  65     pasm_error_output_like          pasm_error_output_unlike
  66     pasm_output_is                  pasm_output_isnt
  67     pasm_output_like                pasm_output_unlike
  68     pbc_error_output_is             pbc_error_output_isnt
  69     pbc_error_output_like           pbc_error_output_unlike
  70     pbc_output_is                   pbc_output_isnt
  71     pbc_output_like                 pbc_output_unlike
  72     pir_error_output_is             pir_error_output_isnt
  73     pir_error_output_like           pir_error_output_unlike
  74     pir_output_is                   pir_output_isnt
  75     pir_output_like                 pir_output_unlike
  76     pir_2_pasm_is                   pir_2_pasm_isnt
  77     pir_2_pasm_like                 pir_2_pasm_unlike
  78     generate_languages_functions
  79     per_test
  80     plan
  81     skip
  82     slurp_file
  83     run_command
  84     write_code_to_file
  85     /;
  86
  87 # per_test
  88 is( Parrot::Test::per_test(), undef, 'per_test() no args' );
  89 is( Parrot::Test::per_test( undef, 0 ),     undef, 'per_test() invalid first arg' );
  90 is( Parrot::Test::per_test( 0,     undef ), undef, 'per_test() invalid second arg' );
  91 is( Parrot::Test::per_test( undef, undef ), undef, 'per_test() two invalid args' );
  92
  93 my ( $desc, $err, $line );
  94
  95 # PASM
  96 $desc = 'pasm_output_is: success';
  97 test_out("ok 1 - $desc");
  98 pasm_output_is( <<'CODE', <<'OUTPUT', $desc );
  99     print "foo\n"
 100     end
 101 CODE
 102 foo
 103 OUTPUT
 104 test_test($desc);
 105
 106 $desc = 'pasm_output_is: failure';
 107 test_out("not ok 1 - $desc");
 108 test_fail(+9);
 109 $err = <<"ERR";
 110 #          got: 'foo
 111 # '
 112 #     expected: 'bar
 113 # '
 114 ERR
 115 chomp $err;
 116 test_err($err);
 117 pasm_output_is( <<'CODE', <<"OUTPUT", $desc );
 118     print "foo\n"
 119     end
 120 CODE
 121 bar
 122 OUTPUT
 123 test_test($desc);
 124
 125
 126 $desc = 'pasm_output_isnt: success';
 127 test_out("ok 1 - $desc");
 128 pasm_output_isnt( <<'CODE', <<"OUTPUT", $desc );
 129     print "foo\n"
 130     end
 131 CODE
 132 bar
 133 OUTPUT
 134 test_test($desc);
 135
 136
 137 # The exact error output for pasm_output_isnt() depends on the version of
 138 # Test::Builder.  So, in order to avoid version dependent failures, be content
 139 # with checking the standard output.
 140
 141 $desc = 'pasm_output_isnt: failure';
 142 test_out("not ok 1 - $desc");
 143 test_fail(+10);
 144 $err = <<"ERR";
 145 #     'foo
 146 # '
 147 #         ne
 148 #     'foo
 149 # '
 150 ERR
 151 chomp $err;
 152 test_err( $err );
 153 pasm_output_isnt( <<'CODE', <<'OUTPUT', $desc );
 154     print "foo\n"
 155     end
 156 CODE
 157 foo
 158 OUTPUT
 159 test_test(title => $desc, skip_err => 1);
 160
 161 $desc = 'pasm_output_like: success';
 162 test_out("ok 1 - $desc");
 163 pasm_output_like( <<'CODE', <<'OUTPUT', $desc );
 164     print "foo\n"
 165     end
 166 CODE
 167 /foo/
 168 OUTPUT
 169 test_test($desc);
 170
 171 $desc = 'pasm_output_like: failure';
 172 test_out("not ok 1 - $desc");
 173 test_fail(+9);
 174 $err = <<"ERR";
 175 #                   'foo
 176 # '
 177 #     doesn't match '/bar/
 178 # '
 179 ERR
 180 chomp $err;
 181 test_err($err);
 182 pasm_output_like( <<'CODE', <<"OUTPUT", $desc );
 183     print "foo\n"
 184     end
 185 CODE
 186 /bar/
 187 OUTPUT
 188 test_test($desc);
 189
 190 # PIR
 191 $desc = 'pir_output_is: success';
 192 test_out("ok 1 - $desc");
 193 pir_output_is( <<'CODE', <<'OUTPUT', $desc );
 194 .sub 'test' :main
 195     print "foo\n"
 196 .end
 197 CODE
 198 foo
 199 OUTPUT
 200 test_test($desc);
 201
 202 $desc = 'pir_output_is: failure';
 203 test_out("not ok 1 - $desc");
 204 test_fail(+9);
 205 $err = <<"ERR";
 206 #          got: 'foo
 207 # '
 208 #     expected: 'bar
 209 # '
 210 ERR
 211 chomp $err;
 212 test_err($err);
 213 pir_output_is( <<'CODE', <<"OUTPUT", $desc );
 214 .sub 'test' :main
 215     print "foo\n"
 216 .end
 217 CODE
 218 bar
 219 OUTPUT
 220 test_test($desc);
 221
 222 $desc = 'pir_output_isnt: success';
 223 test_out("ok 1 - $desc");
 224 pir_output_isnt( <<'CODE', <<"OUTPUT", $desc );
 225 .sub 'test' :main
 226     print "foo\n"
 227 .end
 228 CODE
 229 bar
 230 OUTPUT
 231 test_test($desc);
 232
 233 # The exact error output for pir_output_isnt() depends on the version of
 234 # Test::Builder.  So, in order to avoid version dependent failures, be content
 235 # with checking the standard output.
 236 $desc = 'pir_output_isnt: failure';
 237 test_out("not ok 1 - $desc");
 238 test_fail(+10);
 239 $err = <<"ERR";
 240 #     'foo
 241 # '
 242 #         ne
 243 #     'foo
 244 # '
 245 ERR
 246 chomp $err;
 247 test_err($err);
 248 pir_output_isnt( <<'CODE', <<'OUTPUT', $desc );
 249 .sub 'test' :main
 250     print "foo\n"
 251 .end
 252 CODE
 253 foo
 254 OUTPUT
 255 test_test(title => $desc, skip_err => 1);
 256
 257 $desc = 'pir_output_like: success';
 258 test_out("ok 1 - $desc");
 259 pir_output_like( <<'CODE', <<'OUTPUT', $desc );
 260 .sub 'test' :main
 261     print "foo\n"
 262 .end
 263 CODE
 264 /foo/
 265 OUTPUT
 266 test_test($desc);
 267
 268 $desc = 'pir_output_like: failure';
 269 test_out("not ok 1 - $desc");
 270 test_fail(+9);
 271 $err = <<"ERR";
 272 #                   'foo
 273 # '
 274 #     doesn't match '/bar/
 275 # '
 276 ERR
 277 chomp $err;
 278 test_err($err);
 279 pir_output_like( <<'CODE', <<"OUTPUT", $desc );
 280 .sub 'test' :main
 281     print "foo\n"
 282 .end
 283 CODE
 284 /bar/
 285 OUTPUT
 286 test_test($desc);
 287
 288 #
 289 # incorporate changes in Test::Builder after Version 0.94
 290 #
 291 if ($Test::Builder::VERSION <= eval '0.94') {
 292 $desc = 'pir_error_output_like: todo';
 293 $line = line_num(+22);
 294 my $location;
 295 if ($Test::Builder::VERSION <= eval '0.33') {
 296     $location = "in $0 at line $line";
 297 }
 298 else {
 299     $location = "at $0 line $line";
 300 }
 301 test_out("not ok 1 - $desc # TODO foo");
 302 $err = <<"ERR";
 303 #   Failed (TODO) test '$desc'
 304 #   $location.
 305 # Expected error but exited cleanly
 306 # Received:
 307 # foo
 308 #
 309 # Expected:
 310 # /bar/
 311 #
 312 ERR
 313 chomp $err;
 314 test_err($err);
 315 pir_error_output_like( <<'CODE', <<"OUTPUT", $desc, todo => 'foo' );
 316 .sub 'test' :main
 317     print "foo\n"
 318 .end
 319 CODE
 320 /bar/
 321 OUTPUT
 322 if($Test::Builder::VERSION == 0.84) {
 323     test_test(title => $desc, skip_err => 1);
 324 }
 325 else {
 326     test_test($desc);
 327 }
 328 }  #end of test for Test::Builder 0.94 or before
 329 #
 330 # Test for TEST::Builder after Version 0.94
 331 #
 332 else {
 333 $line = line_num(+14);
 334 my $location = "at $0 line $line";
 335 $desc = 'pir_output_like: todo';
 336 test_out("not ok 1 - $desc # TODO foo");
 337 $err = <<"EOUT";
 338 #   Failed (TODO) test '$desc'
 339 #   $location.
 340 #                   'foo
 341 # '
 342 #     doesn't match '/bar/
 343 # '
 344 EOUT
 345 chomp $err;
 346 test_out($err);
 347 pir_output_like( <<'CODE', <<"OUTPUT", $desc, todo => 'foo' );
 348 .sub 'test' :main
 349     print "foo\n"
 350 .end
 351 CODE
 352 /bar/
 353 OUTPUT
 354     test_test($desc);
 355 }
 356
 357 ##### PIR-to-PASM output test functions #####
 358
 359 my $pir_2_pasm_code = <<'ENDOFCODE';
 360 .sub _test
 361    noop
 362    end
 363 .end
 364 ENDOFCODE
 365
 366 pir_2_pasm_is( <<CODE, <<'OUT', "pir_2_pasm:  added return - end" );
 367 $pir_2_pasm_code
 368 CODE
 369 # IMCC does produce b0rken PASM files
 370 # see http://guest@rt.perl.org/rt3/Ticket/Display.html?id=32392
 371 _test:
 372   noop
 373   end
 374 OUT
 375
 376 pir_2_pasm_isnt( <<CODE, <<'OUT', "pir_2_pasm:  added return - end" );
 377 $pir_2_pasm_code
 378 CODE
 379 _test:
 380   noop
 381   bend
 382 OUT
 383
 384 pir_2_pasm_like( <<CODE, <<'OUT', "pir_2_pasm:  added return - end" );
 385 $pir_2_pasm_code
 386 CODE
 387 /noop\s+end/s
 388 OUT
 389
 390 pir_2_pasm_unlike( <<CODE, <<'OUT', "pir_2_pasm:  added return - end" );
 391 $pir_2_pasm_code
 392 CODE
 393 /noop\s+bend/s
 394 OUT
 395
 396 my $file = q{t/perl/testlib/hello.pasm};
 397 my $expected = qq{Hello World\n};
 398 example_output_is( $file, $expected );
 399
 400 $expected = qq{Goodbye World\n};
 401 example_output_isnt( $file, $expected );
 402
 403 $expected = qr{Hello World};
 404 example_output_like( $file, $expected );
 405
 406 $file = q{t/perl/testlib/answer.pir};
 407 $expected = <<EXPECTED;
 408 The answer is
 409 42
 410 says Parrot!
 411 EXPECTED
 412 example_output_is( $file, $expected );
 413
 414 # next is dying at _unlink_or_retain
 415 $expected = <<EXPECTED;
 416 The answer is
 417 769
 418 says Parrot!
 419 EXPECTED
 420 example_output_isnt( $file, $expected );
 421
 422 $expected = qr/answer.*42.*Parrot!/s;
 423 example_output_like( $file, $expected );
 424
 425 $file = q{t/perl/testlib/hello};
 426 $expected = qq{no extension recognized for $file};
 427 example_error_output_is( $file, $expected );
 428
 429 $expected = qq{some extension recognized for $file};
 430 example_error_output_isnt( $file, $expected );
 431
 432 $expected = qr{no extension recognized for $file};
 433 example_error_output_like( $file, $expected );
 434
 435 ##### C-output test functions #####
 436
 437 my $c_code = <<'ENDOFCODE';
 438     #include <stdio.h>
 439     #include <stdlib.h>
 440
 441     int
 442     main(int argc, char* argv[])
 443     {
 444         printf("Hello, World!\n");
 445         exit(0);
 446     }
 447 ENDOFCODE
 448
 449 $desc = 'C:  is hello world';
 450 test_out("ok 1 - $desc");
 451 c_output_is( <<CODE, <<'OUTPUT', $desc );
 452 $c_code
 453 CODE
 454 Hello, World!
 455 OUTPUT
 456 test_test($desc);
 457
 458 $desc = 'C:  isnt hello world';
 459 test_out("ok 1 - $desc");
 460 c_output_isnt( <<CODE, <<'OUTPUT', $desc );
 461 $c_code
 462 CODE
 463 Is Not Hello, World!
 464 OUTPUT
 465 test_test($desc);
 466
 467 $desc = 'C:  like hello world';
 468 test_out("ok 1 - $desc");
 469 c_output_like( <<CODE, <<'OUTPUT', $desc );
 470 $c_code
 471 CODE
 472 /Hello, World/
 473 OUTPUT
 474 test_test($desc);
 475
 476 $desc = 'C:  unlike hello world';
 477 test_out("ok 1 - $desc");
 478 c_output_unlike( <<CODE, <<'OUTPUT', $desc );
 479 $c_code
 480 CODE
 481 /foobar/
 482 OUTPUT
 483 test_test($desc);
 484
 485 ##### Tests for Parrot::Test internal subroutines #####
 486
 487 # _handle_test_options()
 488 my ( $out, $chdir );
 489 ( $out, $err, $chdir ) = Parrot::Test::_handle_test_options( {
 490     STDOUT  => '/tmp/captureSTDOUT',
 491     STDERR  => '/tmp/captureSTDERR',
 492     CD      => '/tmp',
 493 } );
 494 is($out, '/tmp/captureSTDOUT', "Got expected value for STDOUT");
 495 is($err, '/tmp/captureSTDERR', "Got expected value for STDERR");
 496 is($chdir, '/tmp', "Got expected value for working directory");
 497
 498 ( $out, $err, $chdir ) = Parrot::Test::_handle_test_options( {
 499     STDOUT  => '/tmp/captureSTDOUT',
 500     STDERR  => '',
 501     CD      => '/tmp',
 502 } );
 503 is($out, '/tmp/captureSTDOUT', "Got expected value for STDOUT");
 504 is($err, '', "Got expected value for STDERR");
 505 is($chdir, '/tmp', "Got expected value for working directory");
 506
 507 ( $out, $err, $chdir ) = Parrot::Test::_handle_test_options( {
 508     STDOUT  => '',
 509     STDERR  => '',
 510     CD      => '',
 511 } );
 512 is($out, '', "Got expected value for STDOUT");
 513 is($err, '', "Got expected value for STDERR");
 514 is($chdir, '', "Got expected value for working directory");
 515
 516 eval {
 517     ( $out, $err, $chdir ) = Parrot::Test::_handle_test_options( {
 518         STDJ    => '',
 519         STDERR  => '',
 520         CD      => '',
 521     } );
 522 };
 523 like($@, qr/I don't know how to redirect 'STDJ' yet!/,
 524     "Got expected error message for bad option");
 525
 526 my $dn = File::Spec->devnull();
 527 ( $out, $err, $chdir ) = Parrot::Test::_handle_test_options( {
 528     STDOUT  => '',
 529     STDERR  => ($^O eq 'MSWin32')? 'nul' : '/dev/null',
 530     CD      => '',
 531 } );
 532 is($out, '', "Got expected value for STDOUT");
 533 is($err, $dn, "Got expected value for STDERR using null device");
 534 is($chdir, '', "Got expected value for working directory");
 535
 536 ( $out, $err, $chdir ) = Parrot::Test::_handle_test_options( {
 537     STDOUT  => '/tmp/foobar',
 538     STDERR  => '/tmp/foobar',
 539     CD      => '',
 540 } );
 541 is($out, '/tmp/foobar', "Got expected value for STDOUT");
 542 is($err, '&STDOUT', "Got expected value for STDERR when same as STDOUT");
 543 is($chdir, '', "Got expected value for working directory");
 544
 545 {
 546     my $oldpath = $ENV{PATH};
 547     my $oldldrunpath = $ENV{LD_RUN_PATH};
 548     local $PConfig{build_dir} = 'foobar';
 549     my $blib_path = File::Spec->catfile( $PConfig{build_dir}, 'blib', 'lib' );
 550     {
 551         local $^O = 'cygwin';
 552         Parrot::Test::_handle_blib_path();
 553         is( $ENV{PATH}, $blib_path . ':' . $oldpath,
 554             "\$ENV{PATH} reset as expected for $^O");
 555         $ENV{PATH} = $oldpath;
 556     }
 557     {
 558         local $^O = 'MSWin32';
 559         Parrot::Test::_handle_blib_path();
 560         is( $ENV{PATH}, $blib_path . ';' . $oldpath,
 561             "\$ENV{PATH} reset as expected for $^O");
 562         $ENV{PATH} = $oldpath;
 563     }
 564     {
 565         local $^O = 'not_cygwin_not_MSWin32';
 566         Parrot::Test::_handle_blib_path();
 567         is( $ENV{LD_RUN_PATH}, $blib_path,
 568             "\$ENV{LD_RUN_PATH} reset as expected for $^O");
 569         $ENV{LD_RUN_PATH} = $oldldrunpath;
 570     }
 571 }
 572
 573 my $command_orig;
 574 $command_orig = 'ls';
 575 is_deeply( Parrot::Test::_handle_command($command_orig), [ qw( ls ) ],
 576     "Scalar command transformed into array ref as expected");
 577 $command_orig = [ qw( ls -l ) ];
 578 is( Parrot::Test::_handle_command($command_orig), $command_orig,
 579     "Array ref holding multiple commands unchanged as expected");
 580
 581 {
 582     my $oldvalgrind      = defined $ENV{VALGRIND} ? $ENV{VALGRIND} : '';
 583     $command_orig        = 'ls';
 584     my $foo              = 'foobar';
 585     local $ENV{VALGRIND} = $foo;
 586     my $ret              = Parrot::Test::_handle_command($command_orig);
 587
 588     is( $ret->[0], "$foo $command_orig",
 589         "Got expected value in Valgrind environment");
 590
 591     $ENV{VALGRIND} = $oldvalgrind;
 592 }
 593
 594 {
 595     local $? = -1;
 596     my $exit_message = Parrot::Test::_prepare_exit_message();
 597     is( $exit_message, -1, "Got expected exit message" );
 598 }
 599
 600 {
 601     local $? = 0;
 602     my $exit_message = Parrot::Test::_prepare_exit_message();
 603     is( $exit_message, 0, "Got expected exit message" );
 604 }
 605
 606 {
 607     local $? = 1;
 608     my $exit_message = Parrot::Test::_prepare_exit_message();
 609     is( $exit_message, q{[SIGNAL 1]}, "Got expected exit message" );
 610 }
 611
 612 {
 613     local $? = 255;
 614     my $exit_message = Parrot::Test::_prepare_exit_message();
 615     is( $exit_message, q{[SIGNAL 255]}, "Got expected exit message" );
 616 }
 617
 618 {
 619     local $? = 256;
 620     my $exit_message = Parrot::Test::_prepare_exit_message();
 621     is( $exit_message, 1, "Got expected exit message" );
 622 }
 623
 624 {
 625     local $? = 512;
 626     my $exit_message = Parrot::Test::_prepare_exit_message();
 627     is( $exit_message, 2, "Got expected exit message" );
 628 }
 629
 630 {
 631     my $q = $PConfig{PQ};
 632     my $text = q{Hello, world};
 633     my $cmd = "$^X -e ${q}print qq{$text\n};${q}";
 634     my $exit_message;
 635     my ($stdout, $stderr);
 636     capture(
 637         sub {
 638             $exit_message = run_command(
 639             $cmd,
 640             'CD' => '',
 641         ); },
 642         \$stdout,
 643         \$stderr,
 644     );
 645     like($stdout, qr/$text/, "Captured STDOUT");
 646     is($exit_message, 0, "Got 0 as exit message");
 647 }
 648 undef $out;
 649 undef $err;
 650 undef $chdir;
 651
 652
 653 SKIP: {
 654     skip 'feature not DWIMming even though test passes',
 655     1;
 656 $desc = '';
 657 test_out("ok 1 - $desc");
 658 pasm_output_is( <<'CODE', <<'OUTPUT', $desc );
 659     print "foo\n"
 660     end
 661 CODE
 662 foo
 663 OUTPUT
 664 test_test($desc);
 665 }
 666
 667 my $outfile = File::Spec->catfile( qw| t perl Parrot_Test_1.out | );
 668 {
 669     unlink $outfile;
 670     local $ENV{POSTMORTEM} = 1;
 671     $desc = 'pir_output_is: success';
 672     test_out("ok 1 - $desc");
 673     pir_output_is( <<'CODE', <<'OUTPUT', $desc );
 674 .sub 'test' :main
 675     print "foo\n"
 676 .end
 677 CODE
 678 foo
 679 OUTPUT
 680     test_test($desc);
 681     ok( -f $outfile,
 682         "file created during test preserved due to \$ENV{POSTMORTEM}");
 683     unlink $outfile;
 684     ok( ! -f $outfile,
 685         "file created during test has been deleted");
 686 }
 687
 688 {
 689     unlink $outfile;
 690     local $ENV{POSTMORTEM} = 0;
 691     $desc = 'pir_output_is: success';
 692     test_out("ok 1 - $desc");
 693     pir_output_is( <<'CODE', <<'OUTPUT', $desc );
 694 .sub 'test' :main
 695     print "foo\n"
 696 .end
 697 CODE
 698 foo
 699 OUTPUT
 700     test_test($desc);
 701     ok( ! -f $outfile,
 702         "file created during test was not retained");
 703 }
 704
 705
 706 # Cleanup t/perl/
 707
 708 unless ( $ENV{POSTMORTEM} ) {
 709     my $tdir = q{t/perl};
 710     opendir my $DIRH, $tdir or croak "Unable to open $tdir for reading: $!";
 711     my @need_cleanup =
 712         grep { m/Parrot_Test_\d+\.(?:pir|pasm|out|c|o|build)$/ }
 713         readdir $DIRH;
 714     closedir $DIRH or croak "Unable to close $tdir after reading: $!";
 715     for my $f (@need_cleanup) {
 716         unlink qq{$tdir/$f} or croak "Unable to remove $f: $!";
 717     }
 718 }
 719
 720 # Local Variables:
 721 #   mode: cperl
 722 #   cperl-indent-level: 4
 723 #   fill-column: 100
 724 # End:
 725 # vim: expandtab shiftwidth=4: