#!/usr/bin/perl
use warnings;
use strict;
use File::Temp;
use Test::More tests => 28;
use Test::LectroTest::Generator ':all';
use Test::LectroTest::Property;
use Test::LectroTest::TestRunner;
BEGIN { unshift @INC, 't/lib'; }
use CaptureOutput;
=head1 NAME
t/runner.t - tests for Property and TestRunner
=head1 SYNOPSIS
perl -Ilib t/runner.t
=head1 DESCRIPTION
This test suite excercises Property and TestRunner, which work
hand in hand.
=head2 SET UP
First, we declare a few helper functions.
=cut
sub check($@) {
my $property = shift;
my $runner = Test::LectroTest::TestRunner->new( @_ );
my $details = $runner->run( $property )->details;
return $details;
}
=pod
Next, we declare a few simple properties to check.
=cut
my $except_gen = Gen { die "gen go boom!" };
my $null_1gens = Property { ##[ ]## 1 };
my $null_2gens = Property { ##[ ], [ ]## 1 };
my $null_retry = Property { ##[ ]## $tcon->retry };
my $except_prop1 = Property { ##[ ]## die "prop go boom!" };
my $except_prop2 = Property { ##[ x <- $except_gen ]## 1 };
my $except_prop3 = Property { ##[ x <- Int ], [ x <- $except_gen ]## 1 };
my $ex_retry = Property { ##[ x <- Int ], [ x <- $except_gen ]##
$tcon->retry };
=pod
=head2 TRIALS
Some tests to see if the C<trials> control knob is working.
=cut
like( check( $null_1gens, trials => 1 ),
qr/^ok.*1 attempts/,
"1 gen set + trials=>1 --> 1 trial" );
like( check( $null_2gens, trials => 1 ),
qr/^ok.*2 attempts/,
"2 gen set + trials=>1 --> 2 trials" );
=pod
=head2 RETRIES
Some tests to see if the C<retries> control knob is working.
=cut
# should not finish the first trial but abort after 10 retries
like( check( $null_retry, trials => 1, retries => 10 ),
qr/^not ok.*incomplete/,
"retry-always prop --> incomplete" );
# we should exhaust all of our retries on the first property check
# (using the first set of bindings) and never get to the second, which
# uses a generator that will throw an exception; therefore the
# check should be marked "incomplete"
like( check( $ex_retry, trials => 1, retries => 10 ),
qr/^not ok.*incomplete/,
"retry before exception prop --> incomplete" );
=pod
=head2 EXCEPTION HANDLING
Some tests to see if exceptions are caught and reported properly:
=cut
for (qw(1 2 3)) {
my $prop_str = '$except_prop' . $_;
my $prop = eval $prop_str or die "can't get $prop_str";
like( check( $prop, trials => 1, retries => 10),
qr/^not ok.*exception/s,
"$prop_str dies and is caught" );
}
=pod
=head2 LABELING
Some tests to observe labeling properties.
=cut
unlike( check( ( Property { ##[ x <- Unit(0) ]##
$tcon->label(); 1 } )
, trials => 10 )
, qr/%/s,
, "labeling every trial with an empty label yields no label output" );
like( check( ( Property { ##[ x <- Unit(0) ]##
$tcon->label("all"); 1 } )
, trials => 10 )
, qr/^ok.*100% all/s,
, "labeling every trial --> 100%" );
like( check( ( Property { ##[ x <- Unit(0) ], [ x <- Unit(1) ]##
$tcon->label("odd") if $x; 1 } )
, trials => 10 )
, qr/^ok.*50% odd/s,
, "labeling half of trials --> 50%" );
sub labler {
my @labels = @_;
my $count = 0;
return Property {
##[ ]##
$tcon->label( $labels[$count++] );
$count = 0 if $count == @labels;
1;
};
}
# the following test assumes that the number of trials
# is a multiple of 4
like( check( labler(qw|a a a b|), trials => 1000 ),
qr/ 75% a.*25% b/s,
"75/25 labeling case checks" );
# the following test assumes that the number of trials
# is a multiple of 10
like( check( labler(qw|a a a a a a a b b c|), trials => 1000),
qr/ 70% a.*20% b.*10% c/s,
"70/20/10 labeling case checks" );
my $trivial = Property { ##[ #]##
$tcon->trivial;
1;
};
like( check($trivial, trials => 100),
qr/100% trivial/,
"100% trivial labeling case checks" );
=pod
=pod
=head2 COUNTEREXAMPLE NOTES
Now we check to see whether notes attached to a failing
trial are emitted as part of a counterexample.
=cut
# notes should be emitted only when the property check fails
unlike( check( ( Property { ##[ x <- Unit(0) ]##
$tcon->note("XXXX"); 1 } )
, trials => 10 )
, qr/XXXX/s,
, "notes appear only when a check fails"
);
unlike( check( ( Property { ##[ x <- Unit(0) ]##
$tcon->dump(0, "XXXX"); 1 } )
, trials => 10 )
, qr/XXXX/s,
, "dump notes appear only when a check fails"
);
# when the check fails, all notes must be emitted, in order
unlike( check( ( Property { ##[ x <- Unit(0) ]##
$tcon->note(1,2,3,4,5); 0 } )
, trials => 10 )
, qr/Notes:\s+1\s+2\s+3\s+4\s+5/s,
, "all notes are emitted, in order, when check fails"
);
unlike( check( ( Property { ##[ x <- Unit(0) ]##
$tcon->dump("XXX", "x");
$tcon->dump("YYY", "y");
0 } )
, trials => 10 )
, qr/Notes:\s+\$x = "XXX";\s+\$y = "YYY"/s,
, "dump notes are emitted, in order, when check fails"
);
unlike( check( ( Property { ##[ x <- Unit(0) ]##
$tcon->dump("XXX");
$tcon->dump("YYY");
0 } )
, trials => 10 )
, qr/Notes:\s+\$VAR1 = "XXX";\s+\$VAR2 = "YYY"/s,
, "unnamed dump notes are emitted, in order, when check fails"
);
=head2 SCALEFN
Here we check to see whether our scaling function is being
used.
=cut
my $gen_scale = Gen { $_[0] }; # return scaling guidance as gen'd value
sub prop_scale($) {
my $scale = shift;
Property { ##[ x <- $gen_scale ]##
$tcon->label("desired scale") if $x == $scale;
1
}
}
for (qw(0 1 10)) {
my $scale = $_;
like( check( prop_scale($_), scalefn => sub { $scale }, trials => 10 )
, qr/^ok.*100% desired scale/s,
, "desired scale $_ --> 100%" );
}
=pod
=head2 TEST NUMBERING
Here we see whether we can override the TestRunner's built in
numbering.
=cut
like( Test::LectroTest::TestRunner->new->run($null_1gens, 123)->summary,
qr/ok 123/, "TestRunner->run(x,N) respects given test number N"
);
=pod
=head2 VERBOSITY
Now we check to see whether the verbosity indicator is respected.
=cut
# this sub captures the output for a suite of property checks
for ([1, \&like, "does"], [0, \&unlike, "does not"]) {
my ($verbose, $testfn, $does) = @$_;
$testfn->( check_suite( verbose => $verbose,
trials => 10,
Property { ##[ x <- Unit(0) ]##
$tcon->label("all"); 1 } ),
, qr/%/s,
, "verbose=>$verbose $does include label statistics"
);
}
for ([1, \&like, "does"], [0, \&unlike, "does not"]) {
my ($verbose, $testfn, $does) = @$_;
$testfn->( check_suite( verbose => $verbose,
trials => 10,
Property { ##[ x <- Unit(0) ]##
$x > 0 } ),
, qr/counterexample/i,
, "verbose=>$verbose $does include counterexample"
);
}
=pod
=head2 FAILURE RECORDING
Now we check to see if we can record failures and play them
back as regression tests.
=cut
{
my $tmp = File::Temp->new();
my @vals;
my $prop_fail = Property { ##[ x <- Int ]## push @vals, $x; 0 };
my $prop_succ = Property { ##[ x <- Int ]## push @vals, $x; 1 };
my $checkit = sub {
my $prop = shift;
check_suite(($prop) x 10, trials => 1, @_);
};
# record ten failures into the regression file and save the
# values of x for each in @vals
$checkit->($prop_fail, record_failures => $tmp->filename);
my @recorded_vals = @vals;
@vals = ();
# check ten successful properties using the regression file from
# earlier; because these properties have the same name as the
# failing properties checked above ("Unnamed"), the ten recorded
# failure cases will be tried for each of these properties, in
# addition to the one random case that would normally be tried
# for each
$checkit->($prop_succ, playback_failures => $tmp->filename);
# now @vals should contain 10 played-back failues and 1 random
# trial for *each* for the ten successful property checks; here we
# remove the random-trial value for each property check so
# that we may compare the played back recording to the original
splice(@vals, 11 * $_ + 10, 1) for reverse 0..9;
is_deeply( \@vals,
[ (@recorded_vals) x 10 ],
"recorded failures are played back as regression tests" );
my $prop_newname = Property { ##[ x <- Int ]## push @vals, $x; 1 },
name => "a new name";
@vals = ();
$checkit->($prop_newname, playback_failures => $tmp->filename);
is( scalar @vals, 10,
"failures recorded for a different prop are ignored" );
}
=pod
=head2 HELPER FUNCTIONS
The following helper checks the given properties as a suite
and returns the test output as a string.
=cut
sub check_suite {
my @props = grep is_prop($_), @_;
my @opts = grep !is_prop($_), @_;
my $recorder = capture(*STDOUT);
Test::LectroTest::TestRunner->new(@opts)->run_suite(@props);
return $recorder->();
}
sub is_prop {
ref $_[0] eq 'Test::LectroTest::Property';
}
=head1 AUTHOR
Tom Moertel (tom@moertel.com)
=head1 COPYRIGHT and LICENSE
Copyright (C) 2004 by Thomas G Moertel. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.