# declare test inputs and expected outputs
#
# KEY MEANING DEFAULT
#
# -basename 1st part of subtest name undef
# -name 2nd part of subtest name undef
#
# -skip don't test if 1 undef
#
# -inparms parms passed to sub under test empty list ()
# -argv @ARGV set before call untouched
# -env %ENV set before call untouched
#
# -return return from sub under test 1
#
# -stdout STDOUT don't test
# -string exact string eq
# -regex regex against
# -matches number of regex matches 1
# -lines number of lines captured
#
# -stderr STDERR don't test
#
# -evalerr eval error $@ 0 (no error)
#
my @test_data = (
# test options parsing by Getopt::Long
# if *only* a bad @ARGV then no %options should be parsed out
{
-name => 'foobar-opt',
-argv => [ 'foobar' ], # bad argument
-inparms => [ $opt_flag ], # abort with \%options
-return => {}, # empty hashref in return
-stdout => 0, # expect exactly nothing
# -dump => 1,
},
# error conditions
{
-name => 'foobar',
-argv => [ 'foobar' ], # bad argument
-inparms => [ ], # normal execution
-return => 0, # perl failure
-stdout => 0, # expect exactly nothing
-stderr => {
-regex => [ qw{ bad command line usage hump help} ],
-matches => 6,
-lines => 3,
},
# -dump => 1,
},
{
-name => '-hh(help)-disp',
-inparms => [ $disp_flag ], # abort with $dispatch
-return => [ q{h}, q{help} ], # $dispatch, $do_parm
-stdout => 0, # expect exactly nothing
-stderr => 0, # expect exactly nothing
},
);
####
# execute code within Test::Hump-ish box
$self->{-capture}{-stdout}->start(); # STDOUT captured
$self->{-capture}{-stderr}->start(); # STDERR captured
{
try {
$self->{-got}{-return} = &$self->{coderef}( $self->{-inparms} );
}
catch {
$self->{-got}{-evalerr} = $_;
};
}
$self->{-capture}{-stdout}->stop(); # not captured
$self->{-capture}{-stderr}->stop(); # not captured
####
#!/run/bin/perl
# play-template.pl
# = Copyright 2010 Xiong Changnian =
# = Free Software = Artistic License 2.0 = NO WARRANTY =
# Pragmata; comment out to disable
use strict;
use warnings;
# Commonly-used modules; delete if unused
use Readonly;
use feature qw(switch say state);
use Perl6::Junction qw( all any none one );
use List::Util qw(first max maxstr min minstr reduce shuffle sum);
use File::Spec;
use File::Spec::Functions qw(
catdir
catfile
catpath
splitpath
curdir
rootdir
updir
canonpath
);
use Cwd;
use Smart::Comments '###', '####';
# Modules specially used in this script; if any
use Perl6::Form;
use Data::Dumper;
use Test::More;
#----------------------------------------------------------------------------#
# Put given test data and expected results in a table; actual results to come.
my @test_data = (
# given expected
[ 0 => 0 ],
[ 1 => 1 ],
[ 2 => 0 ],
[ 3 => 1 ],
[ 4 => 0 ],
[ 17 => 0 ],
[ 42 => 0 ],
[ PI => 0 ],
[ 4423 => 0 ],
[ -0.5 => 0 ],
);
# Implement the subroutine to test -- this could be anything
sub play_sub {
my $given = $_[0];
my $result ;
#force a demo error
if ( $given eq "PI" ) {
$result = (1-1)/(1-1);
};
$result = $given %2; # 0 if even, 1 if odd
return $result
};
#----------------------------------------------------------------------------#
# Loop through @test_data, executing play_sub() and capturing the result.
foreach my $test (@test_data) {
my $given = $test->[0];
my $expected = $test->[1];
my $actual ;
my $error ;
$actual = eval{ play_sub( $given ) };
$error = $@;
# You might insert other work here.
if ( $error && !$actual ) {
$actual = 'undef';
};
# Store results
$test->[2] = $actual;
$test->[3] = $error;
};
#----------------------------------------------------------------------------#
# Dump @test_data; choose one of the alternatives
# and delete the rest or write your own...
### Dump using Smart Comments :
### @test_data
# OR
# Dump using Data::Dumper:
say q{};
say 'Data::Dumper dump:';
{
# See D::D POD for some choices here
local $Data::Dumper::Indent = 2;
local $Data::Dumper::Purity = 0;
local $Data::Dumper::Terse = 1;
local $Data::Dumper::Sortkeys = 0;
print Dumper(@test_data);
}
say q{};
# OR
# Dump using Perl6::Form:
say 'Perl6::Form dump:';
say q*| given expected actual error |*;
say q*|-------------------------------------------------------------------|*;
foreach my $test (@test_data) {
if ( $test->[3] ) { # error may overflow field
print form
q*| {<<<<<} {<<<<<} {<<<<<} {<<<<<<<<<<<<<<<<<<<<<<<<<<<<} |*,
$test->[0], $test->[1], $test->[2], $test->[3],
q*| {VVVVVVVVVVVVVVVVVVVVVVVVVVVV} |*
;
}
else {
print form
q*| {<<<<<} {<<<<<} {<<<<<} {<<<<<<<<<<<<<<<<<<<<<<<<<<<<} |*,
$test->[0], $test->[1], $test->[2], $test->[3],
;
};
};
say q*|-------------------------------------------------------------------|*;
say q{};
# Compare expectations with actual results...
# Do it by hand:
say q{};
say 'Testing by hand:';
foreach my $test (@test_data) {
my $given = $test->[0];
my $expected = $test->[1];
my $actual = $test->[2];
my $error = $test->[3];
if ($error) {
say "Given: $given: Error: $error";
};
if ($actual ne $expected) { # $actual != $expected if num
say "Given: $given: Actual: $actual Expected: $expected";
};
};
say q{};
# OR
# Test with Test::More:
say q{};
say 'Testing with Test::More:';
my $test_counter ;
foreach my $test (@test_data) {
my $given = $test->[0];
my $expected = $test->[1];
my $actual = $test->[2];
my $error = $test->[3];
if ($error) {
fail( 'Given: ' . $given );
$test_counter++;
diag( $error );
};
is($actual, $expected, 'Given: ' . $given);
$test_counter++;
};
done_testing($test_counter);
#----------------------------------------------------------------------------#
# Report end of script execution.
say 'Done.';
__END__
=pod
Output:
### Dump using Smart Comments :
### @test_data: [
### [
### 0,
### 0,
### 0,
### ''
### ],
### [
### 1,
### 1,
### 1,
### ''
### ],
### [
### 2,
### 0,
### 0,
### ''
### ],
### [
### 3,
### 1,
### 1,
### ''
### ],
### [
### 4,
### 0,
### 0,
### ''
### ],
### [
### 17,
### 0,
### 1,
### ''
### ],
### [
### 42,
### 0,
### 0,
### ''
### ],
### [
### 'PI',
### 0,
### 'undef',
### 'Illegal division by zero at ./play-template.pl line 60.
'
### ],
### [
### 4423,
### 0,
### 1,
### ''
### ],
### [
### '-0.5',
### 0,
### 0,
### ''
### ]
### ]
Data::Dumper dump:
[
0,
0,
0,
''
]
[
1,
1,
1,
''
]
[
2,
0,
0,
''
]
[
3,
1,
1,
''
]
[
4,
0,
0,
''
]
[
17,
0,
1,
''
]
[
42,
0,
0,
''
]
[
'PI',
0,
'undef',
'Illegal division by zero at ./play-template.pl line 60.
'
]
[
4423,
0,
1,
''
]
[
'-0.5',
0,
0,
''
]
Perl6::Form dump:
| given expected actual error |
|-------------------------------------------------------------------|
| 0 0 0 |
| 1 1 1 |
| 2 0 0 |
| 3 1 1 |
| 4 0 0 |
| 17 0 1 |
| 42 0 0 |
| PI 0 undef Illegal division by zero at |
| ./play-template.pl line 60. |
| 4423 0 1 |
| -0.5 0 0 |
|-------------------------------------------------------------------|
Testing by hand:
Given: 17: Actual: 1 Expected: 0
Given: PI: Error: Illegal division by zero at ./play-template.pl line 60.
Given: PI: Actual: undef Expected: 0
Given: 4423: Actual: 1 Expected: 0
Testing with Test::More:
ok 1 - Given: 0
ok 2 - Given: 1
ok 3 - Given: 2
ok 4 - Given: 3
ok 5 - Given: 4
not ok 6 - Given: 17
# Failed test 'Given: 17'
# at ./play-template.pl line 177.
# got: '1'
# expected: '0'
ok 7 - Given: 42
not ok 8 - Given: PI
# Failed test 'Given: PI'
# at ./play-template.pl line 172.
# Illegal division by zero at ./play-template.pl line 60.
not ok 9 - Given: PI
# Failed test 'Given: PI'
# at ./play-template.pl line 177.
# got: 'undef'
# expected: '0'
not ok 10 - Given: 4423
# Failed test 'Given: 4423'
# at ./play-template.pl line 177.
# got: '1'
# expected: '0'
ok 11 - Given: -0.5
1..11
Done.
# Looks like you failed 4 tests of 11.
=cut