From 6cdf6f9fd8c79aa50b8f9a12a0b5ab77a6141578 Mon Sep 17 00:00:00 2001 From: kyle Date: Wed, 7 Oct 2009 03:25:08 +0000 Subject: [PATCH] spruce up Test::Util::is_run git-svn-id: http://svn.pugscode.org/pugs@28647 c213334d-75ef-0310-aa23-eaa082d1ae64 --- packages/Test/Util.pm | 141 +++++++++++++++++++++++++++++++++++------- 1 file changed, 119 insertions(+), 22 deletions(-) diff --git a/packages/Test/Util.pm b/packages/Test/Util.pm index c6038e0dd5..f5c3578d92 100644 --- a/packages/Test/Util.pm +++ b/packages/Test/Util.pm @@ -1,28 +1,44 @@ module Test::Util; -# XXX This code hasn't been successfully tested. +# Tests for this testing code may be in the pugs repo under t/03-test-util/ # This seems necessary, and yet it crashes Rakudo. #use Test; -# is_run 'say "hello"', { status => 0, out => "hello\n", err => '' }, 'say hello'; +# No input, no test name +multi sub is_run( Str $code, %expected ) is export(:DEFAULT) { + return is_run( $code, '', %expected, '' ); +} + +# Has input, but not a test name +multi sub is_run( Str $code, Str $input, %expected ) is export(:DEFAULT) { + return is_run( $code, $input, %expected, '' ); +} + +# No input, named +multi sub is_run( Str $code, %expected, Str $name ) is export(:DEFAULT) { + return is_run( $code, '', %expected, $name ); +} multi sub is_run( Str $code, Str $input, %expected, Str $name ) is export(:DEFAULT) { my %got = get_out( $code, $input // '' ); - # The test wasn't executed because the collection of kluges died. + # The test may have executed, but if so, the results couldn't be collected. if %got { - skip 1, %got; + return skip 1, 'test died: ' ~ %got; } my $ok = ?1; my $tests_aggregated = 0; + my @diag_q; + # We check each of the attributes and pass the test only if all are good. for -> $attr { # Attributes not specified are not tested. next if ! %expected.exists( $attr ); my $attr_good; + my $diag_ok = 0; given %expected{$attr} { when Regex { $attr_good = %got{$attr} ~~ %expected{$attr}; @@ -32,35 +48,36 @@ multi sub is_run( Str $code, Str $input, %expected, Str $name ) is export(:DEFAU } default { $attr_good = %got{$attr} eq %expected{$attr}; + $diag_ok = 1; } } - + + # The check for this attribute failed. + # Note why for a diag() after the test failure is reported. if !$attr_good { - diag " got $attr: {%got{$attr}}"; - diag "expected $attr: {%expected{$attr}}"; + @diag_q.push( " got $attr: {%got{$attr}.perl}" ); + if $diag_ok { + @diag_q.push( "expected $attr: {%expected{$attr}.perl}" ); + } } $ok &&= $attr_good; $tests_aggregated++; } - if $tests_aggregated > 0 { - proclaim(?$ok, $name); - } - else { - skip 1, 'nothing tested'; + if $tests_aggregated == 0 { + return skip 1, 'nothing tested'; } -} -multi sub get_out( Str $code ) { - return get_out( $code, '' ); -} + ok ?$ok, $name; + diag $_ for @diag_q; -multi sub get_out( Str $code, Str $input ) { - my $bin = $*EXECUTABLE_NAME; + return; +} +sub get_out( Str $code, Str $input? ) is export { my $fnbase = 'getout-'; - $fnbase ~= try { $*PID } // 1_000.rand.Int; + $fnbase ~= $*PID // 1_000_000.rand.Int; my $clobber = sub { my $fh = open $^a, :w @@ -72,14 +89,16 @@ multi sub get_out( Str $code, Str $input ) { my %out; try { - $clobber( "$fnbase.in", $input ); + $clobber( "$fnbase.in", $input // '' ); $clobber( "$fnbase.code", $code ); - %out = run( "$bin $fnbase.code < $fnbase.in > $fnbase.out 2> $fnbase.err" ); + my $perl6 = $*EXECUTABLE_NAME; + + %out = run( "$perl6 $fnbase.code < $fnbase.in > $fnbase.out 2> $fnbase.err" ); %out = slurp "$fnbase.out"; %out = slurp "$fnbase.err"; - CATCH { %out = $! } + CATCH { %out = ~$! } } # Try to delete all the temp files written. If any survive, die. @@ -94,3 +113,81 @@ multi sub get_out( Str $code, Str $input ) { return %out; } + +=pod + +=head1 NAME + +Test::Util - Extra utility code for testing + +=head1 SYNOPSIS + + use Test; + use Test::Util; + + is_run( 'say $*IN.lines', # code to run + 'GIGO', # input for code + { out => "GIGO\n", err => '', status => 0 }, # results expected + 'input comes back out' ); # test name + +=head1 DESCRIPTION + +This module is for test code that would be useful +across Perl 6 implementations. + +=head1 FUNCTIONS + +=head2 is_run( Str $code, Str $input?, %wanted, Str $name? ) + +It runs the code given, feeding it the input given, and collects results +in the form of its stdout, stderr, and exit status. The %wanted hash +specifies which of these to check and what to check them against. +Every item in the hash must "match" for the is_run() test to pass. +For example: + + { + out => "Hello world!\n", # outputs Hello world! + err => '', # no error output + status => 0, # standard successful exit + }, + +Any of those items not present in the %wanted hash will not be tested +(that is, the test passes regardless of the results of those items). +For example, if 'status' is not specified, the test passes regardless +of what the code's exit status was. + +Each item can be a string, a Regexp, or a Callable. Strings must match +exactly. + +A Callable is passed the result, and the test passes +if the Callable returns a true value. +For example: + + is_run( 'rand.say', { out => sub { $^a > 0 && $^a < 1 }, err => '' }, + 'output of rand is between zero and one' ); + +=head3 Errors + +If the underlying code could not be executed properly (e.g., because +temp files could not be accessed), is_run() will skip(). + +If the %wanted hash passed in does not contain any of the items it checks, +is_run() will skip() (but it will still execute the code not being tested). + +is_run() depends on get_out(), which might die. In that case, it dies +also (this error is not trapped). + +=head2 get_out( Str $code, Str $input? ) + +This is what is_run() uses to do its work. It returns a hash with the +'status', 'err', and 'out' of the code run. In addition, if the hash +it returns has an element named 'test_died', that means it failed to +either run the code or collect the results. Any other elements of the +hash should be disregarded. + +=head3 Errors + +This will die if it can't clean up the temp files it uses to do its work. +All other errors should be trapped and reported via the 'test_died' item. + +=cut