Author: jkeenan
Date: Sat Dec 13 06:31:41 2008
New Revision: 33855
Added:
trunk/t/perl/testlib/
- copied from r33853, /branches/testparrottest/t/perl/testlib/
trunk/t/perl/testlib/answer.pir
- copied unchanged from r33853,
/branches/testparrottest/t/perl/testlib/answer.pir
trunk/t/perl/testlib/hello
- copied unchanged from r33853,
/branches/testparrottest/t/perl/testlib/hello
trunk/t/perl/testlib/hello.pasm
- copied unchanged from r33853,
/branches/testparrottest/t/perl/testlib/hello.pasm
Modified:
trunk/MANIFEST
trunk/lib/Parrot/Test.pm
trunk/t/perl/Parrot_Test.t
Log:
Merge in testparrottest branch. Refactoring in lib/Parrot/Test.pm; additional
tests of that package; some new dummy files used in testing.
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Sat Dec 13 06:31:41 2008
@@ -1,7 +1,7 @@
# ex: set ro:
# $Id$
#
-# generated by tools/dev/mk_manifest_and_skip.pl Sat Dec 13 11:12:31 2008 UT
+# generated by tools/dev/mk_manifest_and_skip.pl Sat Dec 13 14:28:34 2008 UT
#
# See tools/dev/install_files.pl for documentation on the
# format of this file.
@@ -3484,6 +3484,9 @@
t/perl/Parrot_IO.t []
t/perl/Parrot_Test.t []
t/perl/README []
+t/perl/testlib/answer.pir []
+t/perl/testlib/hello []
+t/perl/testlib/hello.pasm []
t/pharness/01-default_tests.t []
t/pharness/02-get_test_prog_args.t []
t/pharness/03-handle_long_options.t []
Modified: trunk/lib/Parrot/Test.pm
==============================================================================
--- trunk/lib/Parrot/Test.pm (original)
+++ trunk/lib/Parrot/Test.pm Sat Dec 13 06:31:41 2008
@@ -200,7 +200,7 @@
=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|kike|isnt)> sub.
+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)>
@@ -303,37 +303,10 @@
sub run_command {
my ( $command, %options ) = @_;
- # To run the command in a different directory.
- my $chdir = delete $options{CD};
+ my ( $out, $err, $chdir ) = _handle_test_options( \%options );
- while ( my ( $key, $value ) = each %options ) {
- $key =~ m/^STD(OUT|ERR)$/
- or die "I don't know how to redirect '$key' yet!";
- my $strvalue = "$value"; # filehandle `eq' string will fail
- $value = File::Spec->devnull() # on older perls, so stringify it
- if $strvalue eq '/dev/null';
- }
-
- my $out = $options{'STDOUT'} || '';
- my $err = $options{'STDERR'} || '';
-
- local $ENV;
if ($PConfig{parrot_is_shared}) {
- my $blib_path = File::Spec->catfile( $PConfig{build_dir}, 'blib',
'lib' );
- if ($^O eq 'cygwin') {
- $ENV{PATH} = $blib_path . ':' . $ENV{PATH};
- }
- elsif ($^O eq 'MSWin32') {
- $ENV{PATH} = $blib_path . ';' . $ENV{PATH};
- }
- else {
- $ENV{LD_RUN_PATH} = $blib_path;
- }
- }
-
- ## File::Temp overloads 'eq' here, so we need the quotes. RT #58840
- if ( $out and $err and "$out" eq "$err" ) {
- $err = '&STDOUT';
+ _handle_blib_path();
}
local *OLDOUT if $out; ## no critic
Variables::ProhibitConditionalDeclarations
@@ -357,11 +330,7 @@
# If $command isn't already an arrayref (because of a multi-command
# test), make it so now so the code below can treat everybody the
# same.
- $command = [$command] unless ( ref $command );
-
- if ( defined $ENV{VALGRIND} ) {
- $_ = "$ENV{VALGRIND} $_" for (@$command);
- }
+ $command = _handle_command( $command );
my $orig_dir;
if ($chdir) {
@@ -382,7 +351,7 @@
chdir $orig_dir;
}
- my $exit_code = $?;
+ my $exit_message = _prepare_exit_message();
close STDOUT or die "Can't close stdout" if $out;
close STDERR or die "Can't close stderr" if $err;
@@ -390,11 +359,7 @@
open STDOUT, ">&", \*OLDOUT or die "Can't restore stdout" if $out;
open STDERR, ">&", \*OLDERR or die "Can't restore stderr" if $err;
- return (
- ( $exit_code < 0 ) ? $exit_code
- : ( $exit_code & 0xFF ) ? "[SIGNAL $exit_code]"
- : ( $? >> 8 )
- );
+ return $exit_message;
}
sub per_test {
@@ -408,7 +373,6 @@
return $t;
}
-
sub write_code_to_file {
my ( $code, $code_f ) = @_;
@@ -537,8 +501,8 @@
}
}
-# The following methods are private.
-# They should not be used by modules inheriting from Parrot::Test.
+# The following methods are private. They should not be used by modules
+# inheriting from Parrot::Test.
sub _handle_error_output {
my ( $builder, $real_output, $expected, $desc ) = @_;
@@ -554,21 +518,13 @@
}
sub _run_test_file {
- local $SIG{__WARN__} = \&_report_odd_hash;
my ( $func, $code, $expected, $desc, %extra ) = @_;
-
my $path_to_parrot = path_to_parrot();
my $parrot = File::Spec->join( File::Spec->curdir(), 'parrot' .
$PConfig{exe} );
# Strange Win line endings
convert_line_endings($expected);
- # set up default description
- unless ($desc) {
- ( undef, my $file, my $line ) = caller();
- $desc = "($file line $line)";
- }
-
# $test_no will be part of temporary file
my $test_no = $builder->current_test() + 1;
@@ -672,29 +628,16 @@
return ( $out_f, $cmd, $exit_code );
}
-sub _report_odd_hash {
- my $warning = shift;
- if ( $warning =~ m/Odd number of elements in hash assignment/ ) {
- require Carp;
- my @args = DB::uplevel_args();
- shift @args;
- my $func = ( caller() )[2];
-
- Carp::carp("Odd $func invocation; probably missing description for
TODO test");
- }
- else {
- warn $warning;
- }
-}
-
sub _generate_test_functions {
my $package = 'Parrot::Test';
my $path_to_parrot = path_to_parrot();
- my $parrot = File::Spec->join( File::Spec->curdir(), 'parrot' .
$PConfig{exe} );
+ my $parrot = File::Spec->join( File::Spec->curdir(),
+ 'parrot' . $PConfig{exe} );
my $pirc = File::Spec->join( File::Spec->curdir(),
qw( compilers pirc ), "pirc$PConfig{exe}" );
+ ##### 1: Parrot test map #####
my %parrot_test_map = map {
$_ . '_output_is' => 'is_eq',
$_ . '_error_output_is' => 'is_eq',
@@ -713,6 +656,10 @@
my ( $code, $expected, $desc, %extra ) = @_;
my $args = $ENV{TEST_PROG_ARGS} ||
'';
+ # Due to ongoing changes in PBC format, all tests in
+ # t/native_pbc/*.t are currently being SKIPped. This means we
+ # have no tests on which to model tests of the following block.
+ # Hence, test coverage will be lacking.
if ( $func =~ /^pbc_output_/ && $args =~ /-r / ) {
# native tests with --run-pbc don't make sense
return $builder->skip("no native tests with -r");
@@ -723,7 +670,7 @@
my $meth = $parrot_test_map{$func};
my $real_output = slurp_file($out_f);
- unlink $out_f unless $ENV{POSTMORTEM};
+ _unlink_or_retain( $out_f );
# set a todo-item for Test::Builder to find
my $call_pkg = $builder->exported_to() || '';
@@ -741,14 +688,11 @@
$builder->ok( 0, $desc );
$builder->diag( "Exited with error code: $exit_code\n"
. "Received:\n$real_output\nExpected:\n$expected\n" );
-
return 0;
}
-
my $pass = $builder->$meth( $real_output, $expected, $desc );
$builder->diag("'$cmd' failed with exit code $exit_code")
if not $pass and $exit_code;
-
return $pass;
};
@@ -757,6 +701,7 @@
*{ $package . '::' . $func } = $test_sub;
}
+ ##### 2: PIR-to-PASM test map #####
my %pir_2_pasm_test_map = (
pir_2_pasm_is => 'is_eq',
pir_2_pasm_isnt => 'isnt_eq',
@@ -840,9 +785,7 @@
$builder->diag("'$cmd' failed with exit code $exit_code")
if $exit_code and not $pass;
- if ( !$ENV{POSTMORTEM} ) {
- unlink $out_f;
- }
+ _unlink_or_retain( $out_f );
return $pass;
};
@@ -852,6 +795,7 @@
*{ $package . '::' . $func } = $test_sub;
}
+ ##### 3: Language test map #####
my %builtin_language_prefix = (
PIR_IMCC => 'pir',
PASM_IMCC => 'pasm',
@@ -917,10 +861,14 @@
*{ $package . '::' . $func } = $test_sub;
}
+ ##### 4: Example test map #####
my %example_test_map = (
example_output_is => 'language_output_is',
example_output_like => 'language_output_like',
example_output_isnt => 'language_output_isnt',
+ example_error_output_is => 'language_error_output_is',
+ example_error_output_isnt => 'language_error_output_is',
+ example_error_output_like => 'language_error_output_like',
);
foreach my $func ( keys %example_test_map ) {
@@ -938,7 +886,7 @@
my ($extension) = $example_f =~ m{ [.] #
introducing extension
( pasm | pir ) # match
and capture the extension
\z # at end
of string
- }ixms or Usage();
+ }ixms;
if ( defined $extension ) {
my $code = slurp_file($example_f);
my $test_func = join( '::', $package, $example_test_map{$func}
);
@@ -951,7 +899,7 @@
);
}
else {
- fail( defined $extension, "no extension recognized for
$example_f" );
+ $builder->diag("no extension recognized for $example_f");
}
};
@@ -960,10 +908,12 @@
*{ $package . '::' . $func } = $test_sub;
}
+ ##### 5: C test map #####
my %c_test_map = (
- c_output_is => 'is_eq',
- c_output_isnt => 'isnt_eq',
- c_output_like => 'like'
+ c_output_is => 'is_eq',
+ c_output_isnt => 'isnt_eq',
+ c_output_like => 'like',
+ c_output_unlike => 'unlike',
);
foreach my $func ( keys %c_test_map ) {
@@ -1072,11 +1022,11 @@
}
}
- unless ( $ENV{POSTMORTEM} ) {
- unlink $out_f, $build_f, $exe_f, $obj_f;
- unlink per_test( '.ilk', $test_no );
- unlink per_test( '.pdb', $test_no );
- }
+ _unlink_or_retain(
+ $out_f, $build_f, $exe_f, $obj_f,
+ per_test( '.ilk', $test_no ),
+ per_test( '.pdb', $test_no ),
+ );
return $pass;
};
@@ -1089,21 +1039,69 @@
return;
}
-=head1 SEE ALSO
+sub _handle_test_options {
+ my $options = shift;
+ # To run the command in a different directory.
+ my $chdir = delete $options->{CD} || '';
-=over 4
+ while ( my ( $key, $value ) = each %{ $options } ) {
+ $key =~ m/^STD(OUT|ERR)$/
+ or die "I don't know how to redirect '$key' yet!";
+ my $strvalue = "$value"; # filehandle `eq' string will fail
+ $value = File::Spec->devnull() # on older perls, so stringify it
+ if $strvalue eq '/dev/null';
+ }
-=item F<t/harness>
+ my $out = $options->{'STDOUT'} || '';
+ my $err = $options->{'STDERR'} || '';
+ ## File::Temp overloads 'eq' here, so we need the quotes. RT #58840
+ if ( $out and $err and "$out" eq "$err" ) {
+ $err = '&STDOUT';
+ }
+ return ( $out, $err, $chdir );
+}
-=item F<docs/tests.pod>
+sub _handle_blib_path {
+ my $blib_path =
+ File::Spec->catfile( $PConfig{build_dir}, 'blib', 'lib' );
+ if ($^O eq 'cygwin') {
+ $ENV{PATH} = $blib_path . ':' . $ENV{PATH};
+ }
+ elsif ($^O eq 'MSWin32') {
+ $ENV{PATH} = $blib_path . ';' . $ENV{PATH};
+ }
+ else {
+ $ENV{LD_RUN_PATH} = $blib_path;
+ }
+}
-=item L<Test/More>
+sub _handle_command {
+ my $command = shift;
+ $command = [$command] unless ( ref $command );
-=item L<Test/Builder>
+ if ( defined $ENV{VALGRIND} ) {
+ $_ = "$ENV{VALGRIND} $_" for (@$command);
+ }
+ return $command;
+}
-=back
+sub _prepare_exit_message {
+ my $exit_code = $?;
+ return (
+ ( $exit_code < 0 ) ? $exit_code
+ : ( $exit_code & 0xFF ) ? "[SIGNAL $exit_code]"
+ : ( $? >> 8 )
+ );
+}
-=cut
+sub _unlink_or_retain {
+ my @deletables = @_;
+ my $deleted = 0;
+ unless ( $ENV{POSTMORTEM} ) {
+ $deleted = unlink @deletables;
+ }
+ return $deleted;
+}
package DB;
@@ -1115,6 +1113,22 @@
1;
+=head1 SEE ALSO
+
+=over 4
+
+=item F<t/harness>
+
+=item F<docs/tests.pod>
+
+=item L<Test/More>
+
+=item L<Test/Builder>
+
+=back
+
+=cut
+
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
Modified: trunk/t/perl/Parrot_Test.t
==============================================================================
--- trunk/t/perl/Parrot_Test.t (original)
+++ trunk/t/perl/Parrot_Test.t Sat Dec 13 06:31:41 2008
@@ -19,6 +19,11 @@
use strict;
use warnings;
use Test::More;
+use Carp;
+use File::Spec;
+use lib qw( lib );
+use Parrot::Config;
+use IO::CaptureOutput qw| capture |;
BEGIN {
eval "use Test::Builder::Tester;";
@@ -26,7 +31,7 @@
plan( skip_all => "Test::Builder::Tester not installed\n" );
exit 0;
}
- plan( tests => 66 );
+ plan( tests => 120 );
}
use lib qw( . lib ../lib ../../lib );
@@ -46,9 +51,11 @@
can_ok( 'Parrot::Test', $_ ) for qw/
c_output_is c_output_isnt
- c_output_like
+ c_output_like c_output_unlike
example_output_is example_output_isnt
example_output_like
+ example_error_output_is example_error_output_isnt
+ example_error_output_like
language_error_output_is language_error_output_isnt
language_error_output_like
language_output_is language_output_isnt
@@ -76,8 +83,6 @@
write_code_to_file
/;
-# RT#46891 test run_command()
-
# per_test
is( Parrot::Test::per_test(), undef, 'per_test() no args' );
is( Parrot::Test::per_test( undef, 0 ), undef, 'per_test() invalid first
arg' );
@@ -120,6 +125,7 @@
OUTPUT
test_test($desc);
+
$desc = 'pasm_output_isnt: success';
test_out("ok 1 - $desc");
pasm_output_isnt( <<'CODE', <<"OUTPUT", $desc );
@@ -131,9 +137,10 @@
test_test($desc);
-# The exact error output for pasm_output_isnt() depends on the version of
Test::Builder.
-# So, in order to avoid version dependent failures, be content with checking
the
-# standard output.
+# The exact error output for pasm_output_isnt() depends on the version of
+# Test::Builder. So, in order to avoid version dependent failures, be content
+# with checking the standard output.
+
$desc = 'pasm_output_isnt: failure';
test_out("not ok 1 - $desc");
test_fail(+10);
@@ -226,9 +233,9 @@
OUTPUT
test_test($desc);
-# The exact error output for pir_output_isnt() depends on the version of
Test::Builder.
-# So, in order to avoid version dependent failures, be content with checking
the
-# standard output.
+# The exact error output for pir_output_isnt() depends on the version of
+# Test::Builder. So, in order to avoid version dependent failures, be content
+# with checking the standard output.
$desc = 'pir_output_isnt: failure';
test_out("not ok 1 - $desc");
test_fail(+10);
@@ -316,6 +323,366 @@
test_test($desc);
}
+##### PIR-to-PASM output test functions #####
+
+my $pir_2_pasm_code = <<'ENDOFCODE';
+.sub _test
+ noop
+ end
+.end
+ENDOFCODE
+
+pir_2_pasm_is( <<CODE, <<'OUT', "pir_2_pasm: added return - end" );
+$pir_2_pasm_code
+CODE
+# IMCC does produce b0rken PASM files
+# see http://gu...@rt.perl.org/rt3/Ticket/Display.html?id=32392
+_test:
+ noop
+ end
+OUT
+
+pir_2_pasm_isnt( <<CODE, <<'OUT', "pir_2_pasm: added return - end" );
+$pir_2_pasm_code
+CODE
+_test:
+ noop
+ bend
+OUT
+
+pir_2_pasm_like( <<CODE, <<'OUT', "pir_2_pasm: added return - end" );
+$pir_2_pasm_code
+CODE
+/noop\s+end/s
+OUT
+
+pir_2_pasm_unlike( <<CODE, <<'OUT', "pir_2_pasm: added return - end" );
+$pir_2_pasm_code
+CODE
+/noop\s+bend/s
+OUT
+
+my $file = q{t/perl/testlib/hello.pasm};
+my $expected = qq{Hello World\n};
+example_output_is( $file, $expected );
+
+$expected = qq{Goodbye World\n};
+example_output_isnt( $file, $expected );
+
+$expected = qr{Hello World};
+example_output_like( $file, $expected );
+
+$file = q{t/perl/testlib/answer.pir};
+$expected = <<EXPECTED;
+The answer is
+42
+says Parrot!
+EXPECTED
+example_output_is( $file, $expected );
+
+# next is dying at _unlink_or_retain
+$expected = <<EXPECTED;
+The answer is
+769
+says Parrot!
+EXPECTED
+example_output_isnt( $file, $expected );
+
+$expected = qr/answer.*42.*Parrot!/s;
+example_output_like( $file, $expected );
+
+$file = q{t/perl/testlib/hello};
+$expected = qq{no extension recognized for $file};
+example_error_output_is( $file, $expected );
+
+$expected = qq{some extension recognized for $file};
+example_error_output_isnt( $file, $expected );
+
+$expected = qr{no extension recognized for $file};
+example_error_output_like( $file, $expected );
+
+##### C-output test functions #####
+
+my $c_code = <<'ENDOFCODE';
+ #include <stdio.h>
+ #include <stdlib.h>
+
+ int
+ main(int argc, char* argv[])
+ {
+ printf("Hello, World!\n");
+ exit(0);
+ }
+ENDOFCODE
+
+$desc = 'C: is hello world';
+test_out("ok 1 - $desc");
+c_output_is( <<CODE, <<'OUTPUT', $desc );
+$c_code
+CODE
+Hello, World!
+OUTPUT
+test_test($desc);
+
+$desc = 'C: isnt hello world';
+test_out("ok 1 - $desc");
+c_output_isnt( <<CODE, <<'OUTPUT', $desc );
+$c_code
+CODE
+Is Not Hello, World!
+OUTPUT
+test_test($desc);
+
+$desc = 'C: like hello world';
+test_out("ok 1 - $desc");
+c_output_like( <<CODE, <<'OUTPUT', $desc );
+$c_code
+CODE
+/Hello, World/
+OUTPUT
+test_test($desc);
+
+$desc = 'C: unlike hello world';
+test_out("ok 1 - $desc");
+c_output_unlike( <<CODE, <<'OUTPUT', $desc );
+$c_code
+CODE
+/foobar/
+OUTPUT
+test_test($desc);
+
+##### Tests for Parrot::Test internal subroutines #####
+
+# _handle_test_options()
+my ( $out, $chdir );
+( $out, $err, $chdir ) = Parrot::Test::_handle_test_options( {
+ STDOUT => '/tmp/captureSTDOUT',
+ STDERR => '/tmp/captureSTDERR',
+ CD => '/tmp',
+} );
+is($out, '/tmp/captureSTDOUT', "Got expected value for STDOUT");
+is($err, '/tmp/captureSTDERR', "Got expected value for STDERR");
+is($chdir, '/tmp', "Got expected value for working directory");
+
+( $out, $err, $chdir ) = Parrot::Test::_handle_test_options( {
+ STDOUT => '/tmp/captureSTDOUT',
+ STDERR => '',
+ CD => '/tmp',
+} );
+is($out, '/tmp/captureSTDOUT', "Got expected value for STDOUT");
+is($err, '', "Got expected value for STDERR");
+is($chdir, '/tmp', "Got expected value for working directory");
+
+( $out, $err, $chdir ) = Parrot::Test::_handle_test_options( {
+ STDOUT => '',
+ STDERR => '',
+ CD => '',
+} );
+is($out, '', "Got expected value for STDOUT");
+is($err, '', "Got expected value for STDERR");
+is($chdir, '', "Got expected value for working directory");
+
+eval {
+ ( $out, $err, $chdir ) = Parrot::Test::_handle_test_options( {
+ STDJ => '',
+ STDERR => '',
+ CD => '',
+ } );
+};
+like($@, qr/I don't know how to redirect 'STDJ' yet!/,
+ "Got expected error message for bad option");
+
+my $dn = File::Spec->devnull();
+( $out, $err, $chdir ) = Parrot::Test::_handle_test_options( {
+ STDOUT => '',
+ STDERR => '/dev/null',
+ CD => '',
+} );
+is($out, '', "Got expected value for STDOUT");
+is($err, $dn, "Got expected value for STDERR using /dev/null");
+is($chdir, '', "Got expected value for working directory");
+
+( $out, $err, $chdir ) = Parrot::Test::_handle_test_options( {
+ STDOUT => '/tmp/foobar',
+ STDERR => '/tmp/foobar',
+ CD => '',
+} );
+is($out, '/tmp/foobar', "Got expected value for STDOUT");
+is($err, '&STDOUT', "Got expected value for STDERR when same as STDOUT");
+is($chdir, '', "Got expected value for working directory");
+
+{
+ my $oldpath = $ENV{PATH};
+ my $oldldrunpath = $ENV{LD_RUN_PATH};
+ local $PConfig{build_dir} = 'foobar';
+ my $blib_path = File::Spec->catfile( $PConfig{build_dir}, 'blib', 'lib' );
+ {
+ local $^O = 'cygwin';
+ Parrot::Test::_handle_blib_path();
+ is( $ENV{PATH}, $blib_path . ':' . $oldpath,
+ "\$ENV{PATH} reset as expected for $^O");
+ $ENV{PATH} = $oldpath;
+ }
+ {
+ local $^O = 'MSWin32';
+ Parrot::Test::_handle_blib_path();
+ is( $ENV{PATH}, $blib_path . ';' . $oldpath,
+ "\$ENV{PATH} reset as expected for $^O");
+ $ENV{PATH} = $oldpath;
+ }
+ {
+ local $^O = 'not_cygwin_not_MSWin32';
+ Parrot::Test::_handle_blib_path();
+ is( $ENV{LD_RUN_PATH}, $blib_path,
+ "\$ENV{LD_RUN_PATH} reset as expected for $^O");
+ $ENV{LD_RUN_PATH} = $oldldrunpath;
+ }
+}
+
+my $command_orig;
+$command_orig = 'ls';
+is_deeply( Parrot::Test::_handle_command($command_orig), [ qw( ls ) ],
+ "Scalar command transformed into array ref as expected");
+$command_orig = [ qw( ls -l ) ];
+is( Parrot::Test::_handle_command($command_orig), $command_orig,
+ "Array ref holding multiple commands unchanged as expected");
+
+{
+ my $oldvalgrind = $ENV{VALGRIND};
+ $command_orig = 'ls';
+ my $foo = 'foobar';
+ local $ENV{VALGRIND} = $foo;
+ my $ret = Parrot::Test::_handle_command($command_orig);
+ is( $ret->[0], "$foo $command_orig",
+ "Got expected value in Valgrind environment");
+ $ENV{VALGRIND} = $oldvalgrind;
+}
+
+{
+ local $? = -1;
+ my $exit_message = Parrot::Test::_prepare_exit_message();
+ is( $exit_message, -1, "Got expected exit message" );
+}
+
+{
+ local $? = 0;
+ my $exit_message = Parrot::Test::_prepare_exit_message();
+ is( $exit_message, 0, "Got expected exit message" );
+}
+
+{
+ local $? = 1;
+ my $exit_message = Parrot::Test::_prepare_exit_message();
+ is( $exit_message, q{[SIGNAL 1]}, "Got expected exit message" );
+}
+
+{
+ local $? = 255;
+ my $exit_message = Parrot::Test::_prepare_exit_message();
+ is( $exit_message, q{[SIGNAL 255]}, "Got expected exit message" );
+}
+
+{
+ local $? = 256;
+ my $exit_message = Parrot::Test::_prepare_exit_message();
+ is( $exit_message, 1, "Got expected exit message" );
+}
+
+{
+ local $? = 512;
+ my $exit_message = Parrot::Test::_prepare_exit_message();
+ is( $exit_message, 2, "Got expected exit message" );
+}
+
+{
+ my $text = q{Hello, world};
+ my $cmd = "$^X -e 'print qq{$text\n};'";
+ my $exit_message;
+ my ($stdout, $stderr);
+ capture(
+ sub {
+ $exit_message = run_command(
+ $cmd,
+ 'CD' => '',
+ ); },
+ \$stdout,
+ \$stderr,
+ );
+ like($stdout, qr/$text/, "Captured STDOUT");
+ is($exit_message, 0, "Got 0 as exit message");
+}
+undef $out;
+undef $err;
+undef $chdir;
+
+
+SKIP: {
+ skip 'feature not DWIMming even though test passes',
+ 1;
+$desc = '';
+test_out("ok 1 - $desc");
+pasm_output_is( <<'CODE', <<'OUTPUT', $desc );
+ print "foo\n"
+ end
+CODE
+foo
+OUTPUT
+test_test($desc);
+}
+
+my $outfile = File::Spec->catfile( qw| t perl Parrot_Test_1.out | );
+{
+ unlink $outfile;
+ local $ENV{POSTMORTEM} = 1;
+ $desc = 'pir_output_is: success';
+ test_out("ok 1 - $desc");
+ pir_output_is( <<'CODE', <<'OUTPUT', $desc );
+.sub 'test' :main
+ print "foo\n"
+.end
+CODE
+foo
+OUTPUT
+ test_test($desc);
+ ok( -f $outfile,
+ "file created during test preserved due to \$ENV{POSTMORTEM}");
+ unlink $outfile;
+ ok( ! -f $outfile,
+ "file created during test has been deleted");
+}
+
+{
+ unlink $outfile;
+ local $ENV{POSTMORTEM} = 0;
+ $desc = 'pir_output_is: success';
+ test_out("ok 1 - $desc");
+ pir_output_is( <<'CODE', <<'OUTPUT', $desc );
+.sub 'test' :main
+ print "foo\n"
+.end
+CODE
+foo
+OUTPUT
+ test_test($desc);
+ ok( ! -f $outfile,
+ "file created during test was not retained");
+}
+
+
+# Cleanup t/perl/
+
+unless ( $ENV{POSTMORTEM} ) {
+ my $tdir = q{t/perl};
+ opendir my $DIRH, $tdir or croak "Unable to open $tdir for reading: $!";
+ my @need_cleanup =
+ grep { m/Parrot_Test_\d+\.(?:pir|pasm|out|c|o|build)$/ }
+ readdir $DIRH;
+ closedir $DIRH or croak "Unable to close $tdir after reading: $!";
+ for my $f (@need_cleanup) {
+ unlink qq{$tdir/$f} or croak "Unable to remove $f: $!";
+ }
+}
+
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
