develooper Front page | perl.cvs.parrot | Postings from December 2008

[svn:parrot] r33855 - in trunk: . lib/Parrot t/perl t/perl/testlib

From:
jkeenan
Date:
December 13, 2008 06:31
Subject:
[svn:parrot] r33855 - in trunk: . lib/Parrot t/perl t/perl/testlib
Message ID:
20081213143142.A2536CB9AF@x12.develooper.com
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://guest@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



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About