Author: jkeenan Date: Sun Dec 7 07:36:49 2008 New Revision: 33608 Modified: branches/testparrottest/lib/Parrot/Test.pm
Log: Rearrange order of subs for easier editing. Correct one spelling error. Modified: branches/testparrottest/lib/Parrot/Test.pm ============================================================================== --- branches/testparrottest/lib/Parrot/Test.pm (original) +++ branches/testparrottest/lib/Parrot/Test.pm Sun Dec 7 07:36:49 2008 @@ -165,222 +165,6 @@ # The following methods --up until generate_languages_functions() -- are # private. They should not be used by modules inheriting from Parrot::Test. -sub _handle_error_output { - my ( $builder, $real_output, $expected, $desc ) = @_; - - my $level = $builder->level(); - $builder->level( $level + 1 ); - $builder->ok( 0, $desc ); - $builder->diag( - "Expected error but exited cleanly\n" . "Received:\n$real_output\nExpected:\n$expected\n" ); - $builder->level($level); - - return 0; -} - -sub _run_test_file { - local $SIG{__WARN__} = \&_report_odd_hash; - my ( $func, $code, $expected, $desc, %extra ) = @_; -#my $incoming_desc_status; -#if ($desc) { -# $incoming_desc_status++; -# print STDERR "desc: $desc\n"; -#} else { -# print STDERR "desc is Perl-false\n"; -#} - - 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)"; - } -#unless ($incoming_desc_status) { -# if ($desc) { -# print STDERR "desc is now: $desc\n"; -# } else { -# print STDERR "desc is still Perl-false\n"; -# } -#} - - # $test_no will be part of temporary file - my $test_no = $builder->current_test() + 1; - - # Name of the file where output is written. - # Switch to a different extension when we are generating code. - my $out_f = per_test( '.out', $test_no ); - - # Name of the file with test code. - # This depends on which kind of code we are testing. - my $code_f; - if ( $func =~ m/^pir_.*?output/ ) { - $code_f = per_test( '.pir', $test_no ); - } - elsif ( $func =~ m/^pasm_.*?output_/ ) { - $code_f = per_test( '.pasm', $test_no ); - } - elsif ( $func =~ m/^pbc_.*?output_/ ) { - $code_f = per_test( '.pbc', $test_no ); - } - else { - die "Unknown test function: $func"; - } - $code_f = File::Spec->rel2abs($code_f); - my $code_basef = basename($code_f); - - # native tests are just run, others need to write code first - if ( $code_f !~ /\.pbc$/ ) { - write_code_to_file( $code, $code_f ); - } - - # honor opt* filename to actually run code with -Ox - my $args = $ENV{TEST_PROG_ARGS} || ''; - my $opt = $code_basef =~ m!opt(.)! ? "-O$1" : ""; - $args .= " $opt"; - - my $run_exec = 0; - if ( $args =~ s/--run-exec// ) { - $run_exec = 1; - my $pbc_f = per_test( '.pbc', $test_no ); - my $o_f = per_test( '_pbcexe' . $PConfig{o}, $test_no ); - my $exe_f = - per_test( '_pbcexe' . $PConfig{exe}, $test_no ) - ; # Make cleanup and svn:ignore more simple - my $exec_f = per_test( '_pbcexe', $test_no ); # Make cleanup and svn:ignore more simple - $exe_f =~ [EMAIL PROTECTED]/:[EMAIL PROTECTED]@g; - - # RT#43751 put this into sub generate_pbc() - run_command( - qq{$parrot $args -o $pbc_f "$code_f"}, - CD => $path_to_parrot, - STDOUT => $out_f, - STDERR => $out_f - ); - if ( -e $pbc_f ) { - run_command( - qq{$parrot $args -o $o_f "$pbc_f"}, - CD => $path_to_parrot, - STDOUT => $out_f, - STDERR => $out_f - ); - if ( -e $o_f ) { - run_command( - qq{$PConfig{make} EXEC=$exec_f exec}, - CD => $path_to_parrot, - STDOUT => $out_f, - STDERR => $out_f - ); - if ( -e $exe_f ) { - run_command( - $exe_f, - CD => $path_to_parrot, - STDOUT => $out_f, - STDERR => $out_f - ); - } - } - } - } - - my ( $exit_code, $cmd ); - unless ($run_exec) { - if ( $args =~ s/--run-pbc// || $args =~ s/-r // ) { - my $pbc_f = per_test( '.pbc', $test_no ); - $args = qq{$args -o "$pbc_f"}; - - # In this case, we need to execute more than one command. Instead - # of a single scalar, build an array of commands. - $cmd = [ qq{$parrot $args "$code_f"}, qq{$parrot "$pbc_f"}, ]; - } - else { - $cmd = qq{$parrot $args "$code_f"}; - } - $exit_code = run_command( - $cmd, - CD => $path_to_parrot, - STDOUT => $out_f, - STDERR => $out_f - ); - } - - 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 _handle_test_options { - my $options = shift; - # To run the command in a different directory. - my $chdir = delete $options->{CD} || ''; - - 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'} || ''; - ## 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 ); -} - -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; - } -} - -sub _handle_command { - my $command = shift; - $command = [$command] unless ( ref $command ); - - if ( defined $ENV{VALGRIND} ) { - $_ = "$ENV{VALGRIND} $_" for (@$command); - } - return $command; -} - -sub _prepare_exit_message { - my $exit_code = $?; - return ( - ( $exit_code < 0 ) ? $exit_code - : ( $exit_code & 0xFF ) ? "[SIGNAL $exit_code]" - : ( $? >> 8 ) - ); -} - sub _generate_test_functions { my $package = 'Parrot::Test'; @@ -791,6 +575,222 @@ return; } +sub _handle_error_output { + my ( $builder, $real_output, $expected, $desc ) = @_; + + my $level = $builder->level(); + $builder->level( $level + 1 ); + $builder->ok( 0, $desc ); + $builder->diag( + "Expected error but exited cleanly\n" . "Received:\n$real_output\nExpected:\n$expected\n" ); + $builder->level($level); + + return 0; +} + +sub _run_test_file { + local $SIG{__WARN__} = \&_report_odd_hash; + my ( $func, $code, $expected, $desc, %extra ) = @_; +#my $incoming_desc_status; +#if ($desc) { +# $incoming_desc_status++; +# print STDERR "desc: $desc\n"; +#} else { +# print STDERR "desc is Perl-false\n"; +#} + + 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)"; + } +#unless ($incoming_desc_status) { +# if ($desc) { +# print STDERR "desc is now: $desc\n"; +# } else { +# print STDERR "desc is still Perl-false\n"; +# } +#} + + # $test_no will be part of temporary file + my $test_no = $builder->current_test() + 1; + + # Name of the file where output is written. + # Switch to a different extension when we are generating code. + my $out_f = per_test( '.out', $test_no ); + + # Name of the file with test code. + # This depends on which kind of code we are testing. + my $code_f; + if ( $func =~ m/^pir_.*?output/ ) { + $code_f = per_test( '.pir', $test_no ); + } + elsif ( $func =~ m/^pasm_.*?output_/ ) { + $code_f = per_test( '.pasm', $test_no ); + } + elsif ( $func =~ m/^pbc_.*?output_/ ) { + $code_f = per_test( '.pbc', $test_no ); + } + else { + die "Unknown test function: $func"; + } + $code_f = File::Spec->rel2abs($code_f); + my $code_basef = basename($code_f); + + # native tests are just run, others need to write code first + if ( $code_f !~ /\.pbc$/ ) { + write_code_to_file( $code, $code_f ); + } + + # honor opt* filename to actually run code with -Ox + my $args = $ENV{TEST_PROG_ARGS} || ''; + my $opt = $code_basef =~ m!opt(.)! ? "-O$1" : ""; + $args .= " $opt"; + + my $run_exec = 0; + if ( $args =~ s/--run-exec// ) { + $run_exec = 1; + my $pbc_f = per_test( '.pbc', $test_no ); + my $o_f = per_test( '_pbcexe' . $PConfig{o}, $test_no ); + my $exe_f = + per_test( '_pbcexe' . $PConfig{exe}, $test_no ) + ; # Make cleanup and svn:ignore more simple + my $exec_f = per_test( '_pbcexe', $test_no ); # Make cleanup and svn:ignore more simple + $exe_f =~ [EMAIL PROTECTED]/:[EMAIL PROTECTED]@g; + + # RT#43751 put this into sub generate_pbc() + run_command( + qq{$parrot $args -o $pbc_f "$code_f"}, + CD => $path_to_parrot, + STDOUT => $out_f, + STDERR => $out_f + ); + if ( -e $pbc_f ) { + run_command( + qq{$parrot $args -o $o_f "$pbc_f"}, + CD => $path_to_parrot, + STDOUT => $out_f, + STDERR => $out_f + ); + if ( -e $o_f ) { + run_command( + qq{$PConfig{make} EXEC=$exec_f exec}, + CD => $path_to_parrot, + STDOUT => $out_f, + STDERR => $out_f + ); + if ( -e $exe_f ) { + run_command( + $exe_f, + CD => $path_to_parrot, + STDOUT => $out_f, + STDERR => $out_f + ); + } + } + } + } + + my ( $exit_code, $cmd ); + unless ($run_exec) { + if ( $args =~ s/--run-pbc// || $args =~ s/-r // ) { + my $pbc_f = per_test( '.pbc', $test_no ); + $args = qq{$args -o "$pbc_f"}; + + # In this case, we need to execute more than one command. Instead + # of a single scalar, build an array of commands. + $cmd = [ qq{$parrot $args "$code_f"}, qq{$parrot "$pbc_f"}, ]; + } + else { + $cmd = qq{$parrot $args "$code_f"}; + } + $exit_code = run_command( + $cmd, + CD => $path_to_parrot, + STDOUT => $out_f, + STDERR => $out_f + ); + } + + 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 _handle_test_options { + my $options = shift; + # To run the command in a different directory. + my $chdir = delete $options->{CD} || ''; + + 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'} || ''; + ## 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 ); +} + +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; + } +} + +sub _handle_command { + my $command = shift; + $command = [$command] unless ( ref $command ); + + if ( defined $ENV{VALGRIND} ) { + $_ = "$ENV{VALGRIND} $_" for (@$command); + } + return $command; +} + +sub _prepare_exit_message { + my $exit_code = $?; + return ( + ( $exit_code < 0 ) ? $exit_code + : ( $exit_code & 0xFF ) ? "[SIGNAL $exit_code]" + : ( $? >> 8 ) + ); +} + sub generate_languages_functions { my %test_map = ( @@ -1084,7 +1084,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)>