File Coverage

File:lib/Parrot/Test.pm
Coverage:75.0%

linestmtbrancondsubcode
1# Copyright (C) 2004-2008, The Perl Foundation.
2# $Id: Test.pm 33855 2008-12-13 14:31:41Z jkeenan $
3
4 - 257
=head1 NAME

Parrot::Test - testing routines for Parrot and language implementations

=head1 SYNOPSIS

Set the number of tests to be run like this:

    use Parrot::Test tests => 8;

Write individual tests like this:

    pasm_output_is(<<'CODE', <<'OUTPUT', "description of test");
    print "this is ok\n"
    end
    CODE
    this is ok
    OUTPUT

=head1 DESCRIPTION

This module provides various Parrot-specific test functions.

=head2 Functions

The parameter C<$language> is the language of the code.
The parameter C<$code> is the code that should be executed or transformed.
The parameter C<$expected> is the expected result.
The parameter C<$unexpected> is the unexpected result.
The parameter C<$description> should describe the test.

Any optional parameters can follow.  For example, to mark a test as a TODO test
(where you know the implementation does not yet work), pass:

    todo => 'reason to consider this TODO'

at the end of the argument list.  Valid reasons include C<bug>,
C<unimplemented>, and so on.

B<Note:> you I<must> use a C<$description> with TODO tests.

=over 4

=item C<language_output_is( $language, $code, $expected, $description)>

=item C<language_error_output_is( $language, $code, $expected, $description)>

Runs a language test and passes the test if a string comparison
of the output with the expected result it true.
For C<language_error_output_is()> the exit code also has to be non-zero.

=item C<language_output_like( $language, $code, $expected, $description)>

=item C<language_error_output_like( $language, $code, $expected, $description)>

Runs a language test and passes the test if the output matches the expected
result.
For C<language_error_output_like()> the exit code also has to be non-zero.

=item C<language_output_isnt( $language, $code, $expected, $description)>

=item C<language_error_output_isnt( $language, $code, $expected, $description)>

Runs a language test and passes the test if a string comparison
if a string comparison of the output with the unexpected result is false.
For C<language_error_output_isnt()> the exit code also has to be non-zero.

=item C<pasm_output_is($code, $expected, $description)>

Runs the Parrot Assembler code and passes the test if a string comparison of
the output with the expected result it true.

=item C<pasm_error_output_is($code, $expected, $description)>

Runs the Parrot Assembler code and passes the test if a string comparison of
the output with the expected result it true I<and> if Parrot exits with a
non-zero exit code.

=item C<pasm_output_like($code, $expected, $description)>

Runs the Parrot Assembler code and passes the test if the output matches
C<$expected>.

=item C<pasm_error_output_like($code, $expected, $description)>

Runs the Parrot Assembler code and passes the test if the output matches
C<$expected> I<and> if Parrot exits with a non-zero exit code.

=item C<pasm_output_isnt($code, $unexpected, $description)>

Runs the Parrot Assembler code and passes the test if a string comparison of
the output with the unexpected result is false.

=item C<pasm_error_output_isnt($code, $unexpected, $description)>

Runs the Parrot Assembler code and passes the test if a string comparison of
the output with the unexpected result is false I<and> if Parrot exits with a
non-zero exit code.

=item C<pir_output_is($code, $expected, $description)>

Runs the PIR code and passes the test if a string comparison of output with the
expected result is true.

=item C<pir_error_output_is($code, $expected, $description)>

Runs the PIR code and passes the test if a string comparison of output with the
expected result is true I<and> if Parrot exits with a non-zero exit code.

=item C<pir_output_like($code, $expected, $description)>

Runs the PIR code and passes the test if output matches the expected result.

=item C<pir_error_output_like($code, $expected, $description)>

Runs the PIR code and passes the test if output matches the expected result
I<and> if Parrot exits with a non-zero exit code.

=item C<pir_output_isnt($code, $unexpected, $description)>

Runs the PIR code and passes the test if a string comparison of the output with
the unexpected result is false.

=item C<pir_error_output_isnt($code, $unexpected, $description)>

Runs the PIR code and passes the test if a string comparison of the output with
the unexpected result is false I<and> if Parrot exits with a non-zero exit
code.

=item C<pbc_output_is($code, $expected, $description)>

Runs the Parrot Bytecode and passes the test if a string comparison of output
with the expected result is true.

=item C<pbc_error_output_is($code, $expected, $description)>

Runs the Parrot Bytecode and passes the test if a string comparison of the output
with the expected result is true I<and> if Parrot exits with a non-zero exit code.

=item C<pbc_output_like($code, $expected, $description)>

Runs the Parrot Bytecode and passes the test if output matches the expected
result.

=item C<pbc_error_output_like($code, $expected, $description)>

Runs the Parrot Bytecode and passes the test if output matches the expected
result I<and> if Parrot exits with a non-zero exit code.

=item C<pbc_output_isnt($code, $unexpected, $description)>

Runs the Parrot Bytecode and passes the test if a string comparison of output
with the unexpected result is false.

=item C<pbc_error_output_isnt($code, $unexpected, $description)>

Runs the Parrot Bytecode and passes the test if a string comparison of output
with the unexpected result is false I<and> if Parrot exits with a non-zero exit
code.

=item C<pir_2_pasm_is($code, $expected, $description)>

Compile the Parrot Intermediate Representation and generate Parrot Assembler Code.
Pass if the generated PASM is $expected.

=item C<pir_2_pasm_like($code, $expected, $description)>

Compile the Parrot Intermediate Representation and generate Parrot Assembler Code.
Pass if the generated PASM matches $expected.

=item C<pir_2_pasm_isnt($code, $unexpected, $description)>

Compile the Parrot Intermediate Representation and generate Parrot Assembler
Code.  Pass unless the generated PASM is $expected.

=item C<c_output_is($code, $expected, $description, %options)>

Compiles and runs the C code, passing the test if a string comparison of output
with the expected result it true.  Valid options are 'todo' => 'reason' to mark
a TODO test.

=item C<c_output_like($code, $expected, $description, %options)>

Compiles and runs the C code, passing the test if output matches the expected
result.  Valid options are 'todo' => 'reason' to mark a TODO test.

=item C<c_output_isnt($code, $unexpected, $description, %options)>

Compiles and runs the C code, passing the test if a string comparison of output
with the unexpected result is false.  Valid options are 'todo' => 'reason' to
mark a TODO test.

=item C<example_output_is( $example_f, $expected, @todo )>

=item C<example_output_like( $example_f, $expected, @todo )>

=item C<example_output_isnt( $example_f, $expected, @todo )>

Determines the language, PIR or PASM, from the extension of C<$example_f> and runs
the appropriate C<^language_output_(is|like|isnt)> sub.
C<$example_f> is used as a description, so don't pass one.

=item C<skip($why, $how_many)>

Use within a C<SKIP: { ... }> block to indicate why and how many tests to skip,
just like in Test::More.

=item C<run_command($command, %options)>

Run the given $command in a cross-platform manner.

%options include...

    STDOUT    name of file to redirect STDOUT to
    STDERR    name of file to redirect STDERR to
    CD        directory to run the command in

For example:

    # equivalent to "cd some_dir && make test"
    run_command("make test", CD => "some_dir");

=item C<slurp_file($file_name)>

Read the whole file $file_name and return the content as a string.

=item C<convert_line_endings($text)>

Convert Win32 style line endins with Unix style line endings.

=item C<path_to_parrot()>

Construct an absolute path to the parrot root dir.

=item C<per_test( $ext, $test_no )>

Construct a path for a temporary files.
Takes C<$0> into account.

=item C<write_code_to_file($code, $code_f)>

Writes C<$code> into the file C<$code_f>.

=item C<generate_languages_functions>

Generate functions that are only used by a couple of
Parrot::Test::<lang> modules.
See RT#43266.
This implementation is experimental and currently only works
for languages/pipp.

=back

=cut
258
259package Parrot::Test;
260
261
1
1
1
1
use strict;
262
1
1
1
1
use warnings;
263
264
1
1
1
1
use Cwd;
265
1
1
1
1
use File::Spec;
266
1
1
1
1
use File::Basename;
267
1
1
1
1
use Memoize ();
268
269
1
1
1
1
use Parrot::Config;
270
271require Exporter;
272require Test::Builder;
273require Test::More;
274
275our @EXPORT = qw( plan run_command skip slurp_file);
276
277
1
1
1
1
use base qw( Exporter );
278
279# Memoize functions with a fixed output
280Memoize::memoize('path_to_parrot');
281
282# Tell parrot it's being tested--disables searching of installed libraries.
283# (see Parrot_get_runtime_prefix in src/library.c).
284$ENV{PARROT_TEST} = 1 unless defined $ENV{PARROT_TEST};
285
286my $builder = Test::Builder->new();
287
288# Generate subs where the name serves as an
289# extra parameter.
290_generate_test_functions();
291
292sub import {
293
1
1
    my ( $class, $plan, @args ) = @_;
294
295
1
    $builder->plan( $plan, @args );
296
297
1
    __PACKAGE__->export_to_level( 2, __PACKAGE__ );
298}
299
300# this kludge is an hopefully portable way of having
301# redirections ( tested on Linux and Win2k )
302# An alternative is using Test::Output
303sub run_command {
304
38
38
    my ( $command, %options ) = @_;
305
306
38
    my ( $out, $err, $chdir ) = _handle_test_options( \%options );
307
308
38
50
    if ($PConfig{parrot_is_shared}) {
309
38
        _handle_blib_path();
310    }
311
312
38
100
    local *OLDOUT if $out; ## no critic Variables::ProhibitConditionalDeclarations
313
38
100
    local *OLDERR if $err; ## no critic Variables::ProhibitConditionalDeclarations
314
315    # Save the old filehandles; we must not let them get closed.
316
38
100
50
    open OLDOUT, '>&STDOUT' ## no critic InputOutput::ProhibitBarewordFileHandles
317        or die "Can't save stdout"
318        if $out;
319
38
100
50
    open OLDERR, '>&STDERR' ## no critic InputOutput::ProhibitBarewordFileHandles
320        or die "Can't save stderr"
321        if $err;
322
323
38
100
50
    open STDOUT, '>', $out or die "Can't redirect stdout to $out" if $out;
324
325    # See 'Obscure Open Tricks' in perlopentut
326
38
100
50
    open STDERR, ">$err" ## no critic InputOutput::ProhibitTwoArgOpen
327        or die "Can't redirect stderr to $err"
328        if $err;
329
330    # If $command isn't already an arrayref (because of a multi-command
331    # test), make it so now so the code below can treat everybody the
332    # same.
333
38
    $command = _handle_command( $command );
334
335
38
    my $orig_dir;
336
38
100
    if ($chdir) {
337
25
        $orig_dir = cwd;
338
25
        chdir $chdir;
339    }
340
341    # Execute all commands
342    # [#42161] [BUG] Parrot::Test throws "Can't spawn" warning on windows
343    # ...if a system call returns a negative value
344    # removed exec warnings to prevent this warning from messing up test results
345    {
346
1
1
1
38
1
        no warnings 'exec';
347
38
38
38
        system($_) for ( @{$command} );
348    }
349
350
38
100
    if ($chdir) {
351
25
        chdir $orig_dir;
352    }
353
354
38
    my $exit_message = _prepare_exit_message();
355
356
38
100
50
    close STDOUT or die "Can't close stdout" if $out;
357
38
100
50
    close STDERR or die "Can't close stderr" if $err;
358
359
38
100
50
    open STDOUT, ">&", \*OLDOUT or die "Can't restore stdout" if $out;
360
38
100
50
    open STDERR, ">&", \*OLDERR or die "Can't restore stderr" if $err;
361
362
38
    return $exit_message;
363}
364
365sub per_test {
366
82
82
    my ( $ext, $test_no ) = @_;
367
368
82
100
100
    return unless defined $ext and defined $test_no;
369
370
78
    my $t = $0; # $0 is name of the test script
371
78
    $t =~ s/\.t$/_$test_no$ext/;
372
373
78
    return $t;
374}
375
376sub write_code_to_file {
377
29
29
    my ( $code, $code_f ) = @_;
378
379
29
50
    open my $CODE, '>', $code_f or die "Unable to open '$code_f'";
380
29
    binmode $CODE;
381
29
    print $CODE $code;
382
29
    close $CODE;
383
384
29
    return;
385}
386
387# We can inherit from Test::More, so we do it.
388*plan = \&Test::More::plan;
389*skip = \&Test::More::skip;
390
391# What about File::Slurp?
392sub slurp_file {
393
35
35
    my ($file_name) = @_;
394
395
35
50
    open( my $SLURP, '<', $file_name ) or die "open '$file_name': $!";
396
35
    local $/ = undef;
397
35
    my $file = <$SLURP> . '';
398
35
    $file =~ s/\cM\cJ/\n/g;
399
35
    close $SLURP;
400
401
35
    return $file;
402}
403
404sub convert_line_endings {
405
29
29
    my ($text) = @_;
406
407
29
    $text =~ s/\cM\cJ/\n/g;
408
409
29
    return;
410}
411
412sub path_to_parrot {
413
414    my $path = $INC{'Parrot/Config.pm'};
415    $path =~ s{ /lib/Parrot/Config.pm \z}{}xms;
416
417    return Cwd::realpath( $path );
418}
419
420sub generate_languages_functions {
421
422
0
0
    my %test_map = (
423        output_is => 'is_eq',
424        error_output_is => 'is_eq',
425        output_like => 'like',
426        error_output_like => 'like',
427        output_isnt => 'isnt_eq',
428        error_output_isnt => 'isnt_eq',
429    );
430
431
0
    foreach my $func ( keys %test_map ) {
432
433        my $test_sub = sub {
434
0
0
            local *__ANON__ = $func;
435
0
            my $self = shift;
436
0
            my ( $code, $expected, $desc, %options ) = @_;
437
438            # set a todo-item for Test::Builder to find
439
0
0
            my $call_pkg = $self->{builder}->exported_to() || '';
440
441
1
1
1
1
            no strict 'refs';
442
443
0
0
0
            local *{ $call_pkg . '::TODO' } = ## no critic Variables::ProhibitConditionalDeclarations
444                \$options{todo}
445                if defined $options{todo};
446
447
0
            my $count = $self->{builder}->current_test() + 1;
448
449            # These are the thing that depend on the actual language implementation
450
0
            my $out_f = $self->get_out_fn( $count, \%options );
451
0
            my $lang_f = $self->get_lang_fn( $count, \%options );
452
0
            my $cd = $self->get_cd( \%options );
453
0
            my @test_prog = $self->get_test_prog( $count, \%options );
454
455
0
            Parrot::Test::write_code_to_file( $code, $lang_f );
456
457            # set a todo-item for Test::Builder to find
458
0
            my $skip_why = $self->skip_why( \%options );
459
0
0
            if ($skip_why) {
460
0
                $self->{builder}->skip($skip_why);
461            }
462            else {
463
464                # STDERR is written into same output file
465
0
                my $exit_code = Parrot::Test::run_command(
466                    \@test_prog,
467                    CD => $cd,
468                    STDOUT => $out_f,
469                    STDERR => $out_f
470                );
471
0
                my $real_output = slurp_file($out_f);
472
473
0
0
0
                if ( $func =~ m/^ error_/xms ) {
474
0
0
                    return _handle_error_output( $self->{builder}, $real_output, $expected, $desc )
475                        unless $exit_code;
476                }
477                elsif ($exit_code) {
478
0
                    $self->{builder}->ok( 0, $desc );
479
480
0
                    my $test_prog = join ' && ', @test_prog;
481
0
                    $self->{builder}->diag("'$test_prog' failed with exit code $exit_code.");
482
483
0
                    return 0;
484                }
485
486
0
                my $meth = $test_map{$func};
487
0
                $self->{builder}->$meth( $real_output, $expected, $desc );
488            }
489
490            # The generated files are left in the t/* directories.
491            # Let 'make clean' and 'svn:ignore' take care of them.
492
493
0
            return;
494
0
        };
495
496
0
        my ($package) = caller();
497
498
1
1
1
1
        no strict 'refs';
499
500
0
0
        *{ $package . '::' . $func } = $test_sub;
501    }
502}
503
504# The following methods are private. They should not be used by modules
505# inheriting from Parrot::Test.
506
507sub _handle_error_output {
508
1
1
    my ( $builder, $real_output, $expected, $desc ) = @_;
509
510
1
    my $level = $builder->level();
511
1
    $builder->level( $level + 1 );
512
1
    $builder->ok( 0, $desc );
513
1
    $builder->diag(
514        "Expected error but exited cleanly\n" . "Received:\n$real_output\nExpected:\n$expected\n" );
515
1
    $builder->level($level);
516
517
1
    return 0;
518}
519
520sub _run_test_file {
521
21
21
    my ( $func, $code, $expected, $desc, %extra ) = @_;
522
21
    my $path_to_parrot = path_to_parrot();
523
21
    my $parrot = File::Spec->join( File::Spec->curdir(), 'parrot' . $PConfig{exe} );
524
525    # Strange Win line endings
526
21
    convert_line_endings($expected);
527
528    # $test_no will be part of temporary file
529
21
    my $test_no = $builder->current_test() + 1;
530
531    # Name of the file where output is written.
532    # Switch to a different extension when we are generating code.
533
21
    my $out_f = per_test( '.out', $test_no );
534
535    # Name of the file with test code.
536    # This depends on which kind of code we are testing.
537
21
    my $code_f;
538
21
100
50
0
    if ( $func =~ m/^pir_.*?output/ ) {
539
12
        $code_f = per_test( '.pir', $test_no );
540    }
541    elsif ( $func =~ m/^pasm_.*?output_/ ) {
542
9
        $code_f = per_test( '.pasm', $test_no );
543    }
544    elsif ( $func =~ m/^pbc_.*?output_/ ) {
545
0
        $code_f = per_test( '.pbc', $test_no );
546    }
547    else {
548
0
        die "Unknown test function: $func";
549    }
550
21
    $code_f = File::Spec->rel2abs($code_f);
551
21
    my $code_basef = basename($code_f);
552
553    # native tests are just run, others need to write code first
554
21
50
    if ( $code_f !~ /\.pbc$/ ) {
555
21
        write_code_to_file( $code, $code_f );
556    }
557
558    # honor opt* filename to actually run code with -Ox
559
21
50
    my $args = $ENV{TEST_PROG_ARGS} || '';
560
21
50
    my $opt = $code_basef =~ m!opt(.)! ? "-O$1" : "";
561
21
    $args .= " $opt";
562
563
21
    my $run_exec = 0;
564
21
50
    if ( $args =~ s/--run-exec// ) {
565
0
        $run_exec = 1;
566
0
        my $pbc_f = per_test( '.pbc', $test_no );
567
0
        my $o_f = per_test( '_pbcexe' . $PConfig{o}, $test_no );
568
0
        my $exe_f =
569            per_test( '_pbcexe' . $PConfig{exe}, $test_no )
570            ; # Make cleanup and svn:ignore more simple
571
0
        my $exec_f = per_test( '_pbcexe', $test_no ); # Make cleanup and svn:ignore more simple
572
0
        $exe_f =~ s@[\\/:]@$PConfig{slash}@g;
573
574        # RT#43751 put this into sub generate_pbc()
575
0
        run_command(
576            qq{$parrot $args -o $pbc_f "$code_f"},
577            CD => $path_to_parrot,
578            STDOUT => $out_f,
579            STDERR => $out_f
580        );
581
0
0
        if ( -e $pbc_f ) {
582
0
            run_command(
583                qq{$parrot $args -o $o_f "$pbc_f"},
584                CD => $path_to_parrot,
585                STDOUT => $out_f,
586                STDERR => $out_f
587            );
588
0
0
            if ( -e $o_f ) {
589
0
                run_command(
590                    qq{$PConfig{make} EXEC=$exec_f exec},
591                    CD => $path_to_parrot,
592                    STDOUT => $out_f,
593                    STDERR => $out_f
594                );
595
0
0
                if ( -e $exe_f ) {
596
0
                    run_command(
597                        $exe_f,
598                        CD => $path_to_parrot,
599                        STDOUT => $out_f,
600                        STDERR => $out_f
601                    );
602                }
603            }
604        }
605    }
606
607
21
    my ( $exit_code, $cmd );
608
21
50
    unless ($run_exec) {
609
21
50
33
        if ( $args =~ s/--run-pbc// || $args =~ s/-r // ) {
610
0
            my $pbc_f = per_test( '.pbc', $test_no );
611
0
            $args = qq{$args -o "$pbc_f"};
612
613            # In this case, we need to execute more than one command. Instead
614            # of a single scalar, build an array of commands.
615
0
            $cmd = [ qq{$parrot $args "$code_f"}, qq{$parrot "$pbc_f"}, ];
616        }
617        else {
618
21
            $cmd = qq{$parrot $args "$code_f"};
619        }
620
21
        $exit_code = run_command(
621            $cmd,
622            CD => $path_to_parrot,
623            STDOUT => $out_f,
624            STDERR => $out_f
625        );
626    }
627
628
21
    return ( $out_f, $cmd, $exit_code );
629}
630
631sub _generate_test_functions {
632
633
1
1
    my $package = 'Parrot::Test';
634
1
    my $path_to_parrot = path_to_parrot();
635
1
    my $parrot = File::Spec->join( File::Spec->curdir(),
636                            'parrot' . $PConfig{exe} );
637
1
    my $pirc = File::Spec->join( File::Spec->curdir(),
638                            qw( compilers pirc ), "pirc$PConfig{exe}" );
639
640    ##### 1: Parrot test map #####
641
3
    my %parrot_test_map = map {
642
1
        $_ . '_output_is' => 'is_eq',
643        $_ . '_error_output_is' => 'is_eq',
644        $_ . '_output_isnt' => 'isnt_eq',
645        $_ . '_error_output_isnt' => 'isnt_eq',
646        $_ . '_output_like' => 'like',
647        $_ . '_error_output_like' => 'like',
648        $_ . '_output_unlike' => 'unlike',
649        $_ . '_error_output_unlike' => 'unlike',
650    } qw( pasm pbc pir );
651
1
    for my $func ( keys %parrot_test_map ) {
652
24
        push @EXPORT, $func;
653
654        my $test_sub = sub {
655
21
21
            local *__ANON__ = $func;
656
21
            my ( $code, $expected, $desc, %extra ) = @_;
657
21
50
            my $args = $ENV{TEST_PROG_ARGS} || '';
658
659            # Due to ongoing changes in PBC format, all tests in
660            # t/native_pbc/*.t are currently being SKIPped. This means we
661            # have no tests on which to model tests of the following block.
662            # Hence, test coverage will be lacking.
663
21
50
33
            if ( $func =~ /^pbc_output_/ && $args =~ /-r / ) {
664                # native tests with --run-pbc don't make sense
665
0
                return $builder->skip("no native tests with -r");
666            }
667
668
21
            my ( $out_f, $cmd, $exit_code ) = _run_test_file( $func, @_ );
669
670
21
            my $meth = $parrot_test_map{$func};
671
21
            my $real_output = slurp_file($out_f);
672
673
21
            _unlink_or_retain( $out_f );
674
675            # set a todo-item for Test::Builder to find
676
21
50
            my $call_pkg = $builder->exported_to() || '';
677
678
1
1
1
1
            no strict 'refs';
679
21
1
100
            local *{ $call_pkg . '::TODO' } = ## no critic Variables::ProhibitConditionalDeclarations
680                \$extra{todo}
681                if defined $extra{todo};
682
683
21
100
50
            if ( $func =~ /_error_/ ) {
684
1
50
                return _handle_error_output( $builder, $real_output, $expected, $desc )
685                    unless $exit_code;
686            }
687            elsif ($exit_code) {
688
0
                $builder->ok( 0, $desc );
689
0
                $builder->diag( "Exited with error code: $exit_code\n"
690                        . "Received:\n$real_output\nExpected:\n$expected\n" );
691
0
                return 0;
692            }
693
20
            my $pass = $builder->$meth( $real_output, $expected, $desc );
694
20
50
67
            $builder->diag("'$cmd' failed with exit code $exit_code")
695                if not $pass and $exit_code;
696
20
            return $pass;
697
24
        };
698
699
1
1
1
1
        no strict 'refs';
700
701
24
24
        *{ $package . '::' . $func } = $test_sub;
702    }
703
704    ##### 2: PIR-to-PASM test map #####
705
1
    my %pir_2_pasm_test_map = (
706        pir_2_pasm_is => 'is_eq',
707        pir_2_pasm_isnt => 'isnt_eq',
708        pir_2_pasm_like => 'like',
709        pir_2_pasm_unlike => 'unlike',
710
711        pirc_2_pasm_is => 'is_eq',
712        pirc_2_pasm_isnt => 'isnt_eq',
713        pirc_2_pasm_like => 'like',
714        pirc_2_pasm_unlike => 'unlike',
715    );
716
717
1
    foreach my $func ( keys %pir_2_pasm_test_map ) {
718
8
        push @EXPORT, $func;
719
1
1
1
1
        no strict 'refs';
720
721        my $test_sub = sub {
722
4
4
            local *__ANON__ = $func;
723
4
            my ( $code, $expected, $desc, %extra ) = @_;
724
725            # Strange Win line endings
726
4
            convert_line_endings($expected);
727
728            # set up default description
729
4
50
            unless ($desc) {
730
0
                ( undef, my $file, my $line ) = caller();
731
0
                $desc = "($file line $line)";
732            }
733
734            # $test_no will be part of temporary file
735
4
            my $test_no = $builder->current_test() + 1;
736
737            # Name of the file with test code.
738
4
            my $code_f = File::Spec->rel2abs( per_test( '.pir', $test_no ) );
739
4
            my $code_basef = basename($code_f);
740
741            # output file
742
4
            my $out_f = per_test( '.pasm', $test_no );
743
744
4
            my $cmd;
745
746
4
50
0
            if ($func =~ /^pir_/) {
747
4
50
                my $opt = $code_basef =~ m!opt(.)! ? "-O$1" : "-O1";
748
4
50
                my $args = $ENV{TEST_PROG_ARGS} || '';
749
4
                $args .= " $opt --output=$out_f";
750
4
                $args =~ s/--run-exec//;
751
4
                $cmd = qq{$parrot $args "$code_f"};
752            } elsif ($func =~ /^pirc_/) {
753
0
                $cmd = qq{$pirc -p "$code_f"};
754            }
755
756
4
            write_code_to_file( $code, $code_f );
757
758
4
            my $exit_code = run_command(
759                $cmd,
760                CD => $path_to_parrot,
761                STDOUT => $out_f,
762                STDERR => $out_f
763            );
764
765
4
            my $meth = $pir_2_pasm_test_map{$func};
766
4
            my $real_output = slurp_file($out_f);
767            {
768
769                # The parrot open '--outfile=file.pasm' seems to create unnecessary whitespace
770
4
4
                $real_output =~ s/^\s*$//gm;
771
4
                $real_output =~ s/[\t ]+/ /gm;
772
4
                $real_output =~ s/ +$//gm;
773
774
4
                $expected =~ s/[\t ]+/ /gm;
775            }
776
777            # set a todo-item for Test::Builder to find
778
4
50
            my $call_pkg = $builder->exported_to() || '';
779
780
4
0
50
            local *{ $call_pkg . '::TODO' } = ## no critic Variables::ProhibitConditionalDeclarations
781                \$extra{todo}
782                if defined $extra{todo};
783
784
4
            my $pass = $builder->$meth( $real_output, $expected, $desc );
785
4
50
33
            $builder->diag("'$cmd' failed with exit code $exit_code")
786                if $exit_code and not $pass;
787
788
4
            _unlink_or_retain( $out_f );
789
790
4
            return $pass;
791
8
        };
792
793
1
1
1
1
        no strict 'refs';
794
795
8
8
        *{ $package . '::' . $func } = $test_sub;
796    }
797
798    ##### 3: Language test map #####
799
1
    my %builtin_language_prefix = (
800        PIR_IMCC => 'pir',
801        PASM_IMCC => 'pasm',
802    );
803
804
1
    my %language_test_map = (
805        language_output_is => 'output_is',
806        language_error_output_is => 'error_output_is',
807        language_output_like => 'output_like',
808        language_error_output_like => 'error_output_like',
809        language_output_isnt => 'output_isnt',
810        language_error_output_isnt => 'error_output_isnt',
811    );
812
813
1
    foreach my $func ( keys %language_test_map ) {
814
6
        push @EXPORT, $func;
815
816        my $test_sub = sub {
817
6
6
            local *__ANON__ = $func;
818
6
            my ( $language, @remaining ) = @_;
819
820
6
            my $meth = $language_test_map{$func};
821
6
50
            if ( my $prefix = $builtin_language_prefix{$language} ) {
822
823                # builtin languages are no tested with the example_output_xx() functions
824
6
                my $level = $builder->level();
825
6
                $builder->level( $level + 2 );
826
6
                my $test_func = "${package}::${prefix}_${meth}";
827
828
1
1
1
1
                no strict 'refs';
829
830
6
                $test_func->(@remaining);
831
6
                $builder->level($level);
832            }
833            else {
834
835
0
                $language = ucfirst($language);
836
837                # make sure todo-items will work, by telling Test::Builder which
838                # package the .t file is in (one more than usual, due to the
839                # extra layer of package indirection
840
0
                my $level = $builder->level();
841
0
                $builder->level(2);
842
843                # Load module that knows how to test the language implementation
844
0
                require "Parrot/Test/$language.pm";
845
0
                my $class = "Parrot::Test::${language}";
846
847                # set the builder object, and parrot config.
848
0
                my $obj = $class->new();
849
0
                $obj->{builder} = $builder;
850
0
                $obj->{relpath} = $path_to_parrot;
851
0
                $obj->{parrot} = $parrot;
852
0
                $obj->$meth(@remaining);
853
854                # restore prior level, just in case.
855
0
                $builder->level($level);
856            }
857
6
        };
858
859
1
1
1
1
        no strict 'refs';
860
861
6
6
        *{ $package . '::' . $func } = $test_sub;
862    }
863
864    ##### 4: Example test map #####
865
1
    my %example_test_map = (
866        example_output_is => 'language_output_is',
867        example_output_like => 'language_output_like',
868        example_output_isnt => 'language_output_isnt',
869        example_error_output_is => 'language_error_output_is',
870        example_error_output_isnt => 'language_error_output_is',
871        example_error_output_like => 'language_error_output_like',
872    );
873
874
1
    foreach my $func ( keys %example_test_map ) {
875
6
        push @EXPORT, $func;
876
877        my $test_sub = sub {
878
9
9
            local *__ANON__ = $func;
879
9
            my ( $example_f, $expected, @options ) = @_;
880
881
9
            my %lang_for_extension = (
882                pasm => 'PASM_IMCC',
883                pir => 'PIR_IMCC',
884            );
885
886
9
            my ($extension) = $example_f =~ m{ [.] # introducing extension
887                                               ( pasm | pir ) # match and capture the extension
888                                               \z # at end of string
889                                             }ixms;
890
9
100
            if ( defined $extension ) {
891
6
                my $code = slurp_file($example_f);
892
6
                my $test_func = join( '::', $package, $example_test_map{$func} );
893
894
1
1
1
1
                no strict 'refs';
895
896
6
                $test_func->(
897                    $lang_for_extension{$extension},
898                    $code, $expected, $example_f, @options
899                );
900            }
901            else {
902
3
                $builder->diag("no extension recognized for $example_f");
903            }
904
6
        };
905
906
1
1
1
1
        no strict 'refs';
907
908
6
6
        *{ $package . '::' . $func } = $test_sub;
909    }
910
911    ##### 5: C test map #####
912
1
    my %c_test_map = (
913        c_output_is => 'is_eq',
914        c_output_isnt => 'isnt_eq',
915        c_output_like => 'like',
916        c_output_unlike => 'unlike',
917    );
918
919
1
    foreach my $func ( keys %c_test_map ) {
920
4
        push @EXPORT, $func;
921
922        my $test_sub = sub {
923
4
4
            local *__ANON__ = $func;
924
4
            my ( $source, $expected, $desc, %options ) = @_;
925
926            # $test_no will be part of temporary files
927
4
            my $test_no = $builder->current_test() + 1;
928
929
4
            convert_line_endings($expected);
930
931
4
            my $obj_f = per_test( $PConfig{o}, $test_no );
932
4
            my $exe_f = per_test( $PConfig{exe}, $test_no );
933
4
            $exe_f =~ s@[\\/:]@$PConfig{slash}@g;
934
4
            my $out_f = per_test( '.out', $test_no );
935
4
            my $build_f = per_test( '.build', $test_no );
936
937            # set todo-option before trying to compile or link
938
4
            local *main::TODO;
939
4
50
            *main::TODO = \$options{todo} if $options{todo};
940
941            # compile the source
942            {
943
4
4
                my $source_f = per_test( '.c', $test_no );
944
4
                write_code_to_file( $source, $source_f );
945
946
4
                my $cmd =
947                      "$PConfig{cc} $PConfig{ccflags} $PConfig{cc_debug} "
948                    . " -I./include -c "
949                    . "$PConfig{cc_o_out}$obj_f $source_f";
950
4
                my $exit_code = run_command(
951                    $cmd,
952                    'STDOUT' => $build_f,
953                    'STDERR' => $build_f
954                );
955
4
50
                $builder->diag("'$cmd' failed with exit code $exit_code")
956                    if $exit_code;
957
958
4
50
                if ( !-e $obj_f ) {
959
0
                    $builder->diag( "Failed to build '$obj_f': " . slurp_file($build_f) );
960
0
                    unlink $build_f;
961
0
                    $builder->ok( 0, $desc );
962
963
0
                    return 0;
964                }
965            }
966
967            # link the compiled source, get an executable
968            {
969
4
4
                my $cfg = File::Spec->join( 'src', "parrot_config$PConfig{o}" );
970
4
50
                my $iculibs = $PConfig{has_icu} ? $PConfig{icu_shared} : q{};
971
4
50
50
                my $libparrot =
972                    $PConfig{parrot_is_shared}
973                    ? "$PConfig{rpath_blib} -L$PConfig{blib_dir} "
974                    . (
975                      $^O =~ m/MSWin32/
976                    ? $PConfig{libparrot_ldflags}
977                    : "-lparrot"
978                    )
979                    : File::Spec->join( $PConfig{blib_dir}, $PConfig{libparrot_static} );
980
4
                my $cmd =
981                      "$PConfig{link} $PConfig{linkflags} $PConfig{ld_debug} "
982                    . "$obj_f $cfg $PConfig{ld_out}$exe_f "
983                    . "$libparrot $iculibs $PConfig{libs}";
984
4
                my $exit_code = run_command(
985                    $cmd,
986                    'STDOUT' => $build_f,
987                    'STDERR' => $build_f
988                );
989
4
50
                $builder->diag("'$cmd' failed with exit code $exit_code")
990                    if $exit_code;
991
992
4
50
                if ( !-e $exe_f ) {
993
0
                    $builder->diag( "Failed to build '$exe_f': " . slurp_file($build_f) );
994
0
                    unlink $build_f;
995
0
                    $builder->ok( 0, $desc );
996
997
0
                    return 0;
998                }
999            }
1000
1001            # run the generated executable
1002
4
            my $pass;
1003            {
1004
4
4
                my $cmd = File::Spec->join( File::Spec->curdir(), $exe_f );
1005
4
                my $exit_code = run_command(
1006                    $cmd,
1007                    'STDOUT' => $out_f,
1008                    'STDERR' => $out_f
1009                );
1010
4
                my $output = slurp_file($out_f);
1011
1012
4
50
                if ($exit_code) {
1013
0
                    $pass = $builder->ok( 0, $desc );
1014
0
                    $builder->diag( "Exited with error code: $exit_code\n"
1015                            . "Received:\n$output\nExpected:\n$expected\n" );
1016                }
1017                else {
1018
4
                    my $meth = $c_test_map{$func};
1019
4
                    $pass = $builder->$meth( $output, $expected, $desc );
1020
4
50
                    $builder->diag("'$cmd' failed with exit code $exit_code")
1021                        unless $pass;
1022                }
1023            }
1024
1025            _unlink_or_retain(
1026
4
                $out_f, $build_f, $exe_f, $obj_f,
1027                per_test( '.ilk', $test_no ),
1028                per_test( '.pdb', $test_no ),
1029            );
1030
1031
4
            return $pass;
1032
4
        };
1033
1034
1
1
1
1
        no strict 'refs';
1035
1036
4
4
        *{ $package . '::' . $func } = $test_sub;
1037    }
1038
1039
1
    return;
1040}
1041
1042sub _handle_test_options {
1043
44
44
    my $options = shift;
1044    # To run the command in a different directory.
1045
44
100
    my $chdir = delete $options->{CD} || '';
1046
1047
44
129
    while ( my ( $key, $value ) = each %{ $options } ) {
1048
86
100
        $key =~ m/^STD(OUT|ERR)$/
1049            or die "I don't know how to redirect '$key' yet!";
1050
85
        my $strvalue = "$value"; # filehandle `eq' string will fail
1051
85
100
        $value = File::Spec->devnull() # on older perls, so stringify it
1052            if $strvalue eq '/dev/null';
1053    }
1054
1055
43
100
    my $out = $options->{'STDOUT'} || '';
1056
43
100
    my $err = $options->{'STDERR'} || '';
1057    ## File::Temp overloads 'eq' here, so we need the quotes. RT #58840
1058
43
100
100
    if ( $out and $err and "$out" eq "$err" ) {
1059
38
        $err = '&STDOUT';
1060    }
1061
43
    return ( $out, $err, $chdir );
1062}
1063
1064sub _handle_blib_path {
1065
41
41
    my $blib_path =
1066        File::Spec->catfile( $PConfig{build_dir}, 'blib', 'lib' );
1067
41
100
100
    if ($^O eq 'cygwin') {
1068
1
        $ENV{PATH} = $blib_path . ':' . $ENV{PATH};
1069    }
1070    elsif ($^O eq 'MSWin32') {
1071
1
        $ENV{PATH} = $blib_path . ';' . $ENV{PATH};
1072    }
1073    else {
1074
39
        $ENV{LD_RUN_PATH} = $blib_path;
1075    }
1076}
1077
1078sub _handle_command {
1079
41
41
    my $command = shift;
1080
41
100
    $command = [$command] unless ( ref $command );
1081
1082
41
100
    if ( defined $ENV{VALGRIND} ) {
1083
1
1
        $_ = "$ENV{VALGRIND} $_" for (@$command);
1084    }
1085
41
    return $command;
1086}
1087
1088sub _prepare_exit_message {
1089
44
44
    my $exit_code = $?;
1090    return (
1091
44
100
100
          ( $exit_code < 0 ) ? $exit_code
1092        : ( $exit_code & 0xFF ) ? "[SIGNAL $exit_code]"
1093        : ( $? >> 8 )
1094    );
1095}
1096
1097sub _unlink_or_retain {
1098
29
29
    my @deletables = @_;
1099
29
    my $deleted = 0;
1100
29
100
    unless ( $ENV{POSTMORTEM} ) {
1101
28
        $deleted = unlink @deletables;
1102    }
1103
29
    return $deleted;
1104}
1105
1106package DB;
1107
1108sub uplevel_args {
1109
0
0
    my @foo = caller(2);
1110
1111
0
    return @DB::args;
1112}
1113
11141;
1115
1116 - 1130
=head1 SEE ALSO

=over 4

=item F<t/harness>

=item F<docs/tests.pod>

=item L<Test/More>

=item L<Test/Builder>

=back

=cut
1131
1132# Local Variables:
1133# mode: cperl
1134# cperl-indent-level: 4
1135# fill-column: 100
1136# End:
1137# vim: expandtab shiftwidth=4: