App-Test-Generator/lib/App/Test/Generator/Template.pm
package App::Test::Generator::Template;
use strict;
use warnings;
use autodie qw(:all);
use utf8;
use Data::Section::Simple;
our $VERSION = '0.16';
=head1 NAME
App::Test::Generator::Template - Template for the test file generated by App::Test::Generator
=head1 VERSION
Version 0.16
=head1 SYNOPSIS
The template for the test file generated by App::Test::Generator.
=head1 METHODS
get_data_section($template_file)
Returns a reference to the template.
The only value for C<$template_file>, for now, is test.tt.
=cut
sub get_data_section
{
if($_[0] && ($_[0] eq __PACKAGE__)) {
shift;
}
return \Data::Section::Simple::get_data_section($_[0]);
}
1;
=head1 AUTHOR
Nigel Horne, C<< <njh at nigelhorne.com> >>
Portions of this module's initial design and documentation were created with the
assistance of L<ChatGPT|https://openai.com/> (GPT-5), with final curation
and authorship by Nigel Horne.
=cut
__DATA__
@@ test.tt
#!/usr/bin/env perl
use strict;
use warnings;
use utf8;
use open qw(:std :encoding(UTF-8)); # https://github.com/nigelhorne/App-Test-Generator/issues/1
use Data::Dumper;
use Data::Random qw(:all);
use Data::Random::String;
use Data::Random::String::Matches 0.02;
use Data::Random::Structure;
use Test::Most;
use Test::Returns 0.02;
if($^O ne 'MSWin32') {
close(STDIN);
open(STDIN, '<', '/dev/null');
}
# TODO: add more, and remove magic numbers
# perhaps allow them to be configurable?
use constant {
PROB_LOWERCASE => 0.72,
PROB_EDGE_CASE => 0.4,
};
[% setup_code %]
[% IF module %]
diag('[% module %]->[% function %] test case created by https://github.com/nigelhorne/App-Test-Generator');
[% ELSE %]
diag('[% function %] test case created by https://github.com/nigelhorne/App-Test-Generator');
[% END %]
# Edge-case maps injected from config (optional)
my %edge_cases = (
[% edge_cases_code %]
);
my @edge_case_array = (
[% edge_case_array_code %]
);
my %type_edge_cases = (
[% type_edge_cases_code %]
);
my %config = (
[% config_code %]
);
# Seed for reproducible fuzzing (if provided)
[% seed_code %]
my %input = (
[% input_code %]
);
my %output = (
[% output_code %]
);
my %transforms = (
[% transforms_code %]
);
# Candidates for regex comparisons
my @candidate_good = ('123', 'abc', 'A1B2', '0');
my @candidate_bad = (
"😊", # emoji
"１２３", # full-width digits
"١٢٣", # Arabic digits
'..', # regex metachars
"a\nb", # newline in middle
"é", # E acute
'x' x 5000, # huge string
# Added later if the configuration says so
# '', # empty
# undef, # undefined
# "\0", # null byte
);
# --- Fuzzer helpers ---
sub _pick_from {
my $arrayref = $_[0];
return undef unless $arrayref && ref $arrayref eq 'ARRAY' && @$arrayref;
return $arrayref->[ int(rand(scalar @$arrayref)) ];
}
sub rand_ascii_str {
my $len = shift || int(rand(10)) + 1;
# join '', map { chr(97 + int(rand(26))) } 1..$len;
return Data::Random::String->create_random_string(length => $len, contains => 'alphanumeric');
}
my @unicode_codepoints = (
0x00A9, # ©
0x00AE, # ®
0x03A9, # Ω
0x20AC, # €
0x2013, # – (en-dash)
0x0301, # combining acute accent
0x0308, # combining diaeresis
0x1F600, # 😀 (emoji)
0x1F62E, # 😮
0x1F4A9, # 💩 (yes)
);
# Tests for matches or nomatch
my @regex_tests = (
'match123',
'nope',
'/fullpath',
'/',
'/etc/passwd',
'../../etc/passwd',
"/etc/passwd\0",
"D:\\dos_path",
"I:\\",
);
sub rand_unicode_char {
my $cp = $unicode_codepoints[ int(rand(@unicode_codepoints)) ];
return chr($cp);
}
# Generate a string: mostly ASCII, sometimes unicode, sometimes nul bytes or combining marks
sub rand_str
{
my $len = shift || int(rand(10)) + 1;
my @chars;
for (1..$len) {
my $r = rand();
if ($r < PROB_LOWERCASE) {
push @chars, chr(97 + int(rand(26))); # a-z
} elsif ($r < 0.88) {
push @chars, chr(65 + int(rand(26))); # A-Z
} elsif ($r < 0.95) {
push @chars, chr(48 + int(rand(10))); # 0-9
} elsif ($r < 0.975) {
push @chars, rand_unicode_char(); # occasional emoji/marks
} elsif($config{'test_nuls'}) {
push @chars, chr(0); # nul byte injection
} else {
push @chars, chr(97 + int(rand(26))); # a-z
}
}
# Occasionally prepend/append a combining mark to produce combining sequences
if (rand() < 0.08) {
unshift @chars, chr(0x0301);
}
if (rand() < 0.08) {
push @chars, chr(0x0308);
}
return join('', @chars);
}
# Random character either upper or lower case
# sub rand_char
# {
# return rand_chars(set => 'all', min => 1, max => 1);
# my $char = '';
# my $upper_chars = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';
# my $lower_chars = 'abcdefghijklmnopqrstuvwxyz';
# my $combined_chars = $upper_chars . $lower_chars;
# # Generate a random index between 0 and the length of the string minus 1
# my $rand_index = int(rand(length($combined_chars)));
# # Get the character at that index
# return substr($combined_chars, $rand_index, 1);
# }
# Integer generator: mix typical small ints with large limits
sub rand_int {
my $r = rand();
if ($r < 0.75) {
return int(rand(200)) - 100; # -100 .. 100 (usual)
} elsif ($r < 0.9) {
return int(rand(2**31)) - 2**30; # 32-bit-ish
} elsif ($r < 0.98) {
return (int(rand(2**63)) - 2**62); # 64-bit-ish
} else {
# very large/suspicious values
return 2**63 - 1;
}
}
sub rand_bool { rand() > 0.5 ? 1 : 0 }
# Number generator (floating), includes tiny/huge floats
sub rand_num {
my $r = rand();
if ($r < 0.7) {
return (rand() * 200 - 100); # -100 .. 100
} elsif ($r < 0.9) {
return (rand() * 1e12) - 5e11; # large-ish
} elsif ($r < 0.98) {
return (rand() * 1e308) - 5e307; # very large floats
} else {
return 1e-308 * (rand() * 1000); # tiny float, subnormal-like
}
}
sub rand_arrayref {
my $len = shift || int(rand(3)) + 1; # small arrays
return Data::Random::Structure->new(max_elements => $len, max_depth => 1)->generate_array();
# return [ map { rand_str() } 1..$len ];
}
sub rand_hashref {
my $len = shift || int(rand(3)) + 1; # small hashes
return Data::Random::Structure->new(max_elements => $len, max_depth => 1)->generate_hash();
# my %h;
# for (1..$len) {
# $h{rand_str(3)} = rand_str(5);
# }
# return \%h;
}
sub rand_email
{
my $len = shift || int(rand(10));
my $l;
my @name;
my @tlds = qw(com org net edu gov io co uk de fr);
for($l = 0; $l < $len; $l++) {
push @name, pack('c', (int(rand 26))+97);
}
push @name, '@';
$len = rand(10);
for($l = 0; $l < $len; $l++) {
push @name, pack('c', (int(rand 26))+97);
}
push @name, '.';
$len = rand($#tlds+1);
push @name, $tlds[$len];
return join('', @name);
}
sub fuzz_inputs
{
my @cases;
# Are any options manadatory?
my $all_optional = 1;
my %mandatory_strings; # List of mandatory strings to be added to all tests, always put at start so it can be overwritten
my %mandatory_objects;
my %mandatory_numbers;
my $class_simple_loaded;
foreach my $field (keys %input) {
my $spec = $input{$field} || {};
if((ref($spec) eq 'HASH') && (!$spec->{optional})) {
$all_optional = 0;
if($spec->{'type'} eq 'string') {
local $config{'test_undef'} = 0;
local $config{'test_nuls'} = 0;
local $config{'test_empty'} = 0;
$mandatory_strings{$field} = rand_ascii_str();
} elsif($spec->{'type'} eq 'object') {
my $method = $spec->{'can'};
if(!$class_simple_loaded) {
require_ok('Class::Simple');
eval {
Class::Simple->import();
$class_simple_loaded = 1;
};
}
my $obj = new_ok('Class::Simple');
$obj->$method(1);
$mandatory_objects{$field} = $obj;
$config{'dedup'} = 0; # FIXME: Can't yet dedup with class method calls
} elsif(($spec->{'type'} eq 'float') || ($spec->{'type'} eq 'number')) {
my $min = $spec->{'min'};
my $max = $spec->{'max'};
my $number;
if(defined($min)) {
$number = rand($min);
} else {
$number = rand(100000);
}
if(defined($max)) {
if($number > $max) {
$number = $max;
}
}
$mandatory_numbers{$field} = $number;
} else {
die 'TODO: type = ', $spec->{'type'};
}
}
}
my %mandatory_args = (%mandatory_strings, %mandatory_objects, %mandatory_numbers);
if(($all_optional) || ((scalar keys %input) > 1)) {
# Basic test cases
if(((scalar keys %input) == 1) && exists($input{'type'}) && !ref($input{'type'})) {
# our %input = ( type => 'string' );
my $type = $input{'type'};
foreach my $field(keys %input) {
if(!grep({ $_ eq $field } ('type', 'min', 'max', 'optional', 'matches', 'can'))) {
die("TODO: handle schema keyword '$field'");
}
}
if ($type eq 'string') {
# Is hello allowed?
if(!defined($input{'memberof'}) || (grep { $_ eq 'hello' } @{$input{'memberof'}})) {
if(defined($input{'notmemberof'}) && (grep { $_ eq 'hello' } @{$input{'notmemberof'}})) {
push @cases, { _input => 'hello', _STATUS => 'DIES' };
} else {
push @cases, { _input => 'hello' };
}
} elsif(defined($input{'memberof'}) && !defined($input{'max'})) {
# Data::Random
push @cases, { _input => (rand_set(set => $input{'memberof'}, size => 1))[0] }
} else {
if((!defined($input{'min'})) || ($input{'min'} >= 1)) {
push @cases, { _input => '0' } if(!defined($input{'memberof'}));
}
if(defined($input{'notmemberof'}) || (!grep { $_ eq 'hello' } @{$input{'memberof'}})) {
push @cases, { _input => 'hello' };
} else {
push @cases, { _input => 'hello', _STATUS => 'DIES' };
}
}
push @cases, { _input => '' } if((!exists($input{'min'})) || ($input{'min'} == 0));
# push @cases, { $field => "emoji \x{1F600}" };
push @cases, { _input => "\0null" } if($config{'test_nuls'});
} else {
die "TODO: type $type";
}
} else {
# our %input = ( str => { type => 'string' } );
foreach my $arg_name (keys %input) {
my $spec = $input{$arg_name} || {};
my $type = lc((!ref($spec)) ? $spec : $spec->{type}) || 'string';
foreach my $field(keys %{$spec}) {
if(!grep({ $_ eq $field } ('type', 'min', 'max', 'optional', 'matches', 'can', 'memberof', 'position'))) {
diag(__LINE__, ": TODO: handle schema keyword '$field'");
}
}
# --- Type-based seeds ---
if(($type eq 'number') || ($type eq 'float')) {
push @cases, @{_generate_float_cases($arg_name, $spec, \%mandatory_args)};
}
elsif ($type eq 'integer') {
# Probably duplicated below, but here as well just in case
push @cases, @{_generate_integer_cases($arg_name, $spec, \%mandatory_args)};
} elsif ($type eq 'string') {
# Is hello allowed?
if(my $re = $spec->{matches}) {
if(ref($re) ne 'Regexp') {
$re = qr/$re/;
}
my $random_string;
if($spec->{'max'}) {
$random_string = Data::Random::String::Matches->create_random_string({ length => $spec->{'max'}, regex => $re });
} elsif($spec->{'min'}) {
$random_string = Data::Random::String::Matches->create_random_string({ length => $spec->{'min'}, regex => $re });
} else {
$random_string = Data::Random::String::Matches->create_random_string({ regex => $re });
}
foreach my $str('hello', $random_string) {
if($str =~ $re) {
if(!defined($spec->{'memberof'}) || (grep { $_ eq $str } @{$spec->{'memberof'}})) {
if(defined($spec->{'notmemberof'}) && (grep { $_ eq $str } @{$spec->{'notmemberof'}})) {
push @cases, { %mandatory_args, ( $arg_name => $str, _STATUS => 'DIES' ) };
} else {
push @cases, { %mandatory_args, ( $arg_name => $str ) };
}
} elsif(defined($spec->{'memberof'}) && !defined($spec->{'max'})) {
# Data::Random
push @cases, { %mandatory_args, ( _input => (rand_set(set => $spec->{'memberof'}, size => 1))[0] ) }
} else {
push @cases, { %mandatory_args, ( $arg_name => $str, _STATUS => 'DIES' ) };
}
} else {
push @cases, { %mandatory_args, ( $arg_name => $str, _STATUS => 'DIES' ) };
}
}
} else {
if(!defined($spec->{'memberof'}) || (grep { $_ eq 'hello' } @{$spec->{'memberof'}})) {
if(defined($spec->{'notmemberof'}) && (grep { $_ eq 'hello' } @{$spec->{'notmemberof'}})) {
push @cases, { %mandatory_args, ( $arg_name => 'hello', _LINE => __LINE__, _STATUS => 'DIES' ) };
} else {
push @cases, { %mandatory_args, ( $arg_name => 'hello' ) };
}
} else {
push @cases, { %mandatory_args, ( $arg_name => 'hello', _LINE => __LINE__, _STATUS => 'DIES' ) };
}
}
if((!exists($spec->{min})) || ($spec->{min} == 0)) {
# '' should die unless it's in the memberof list
if(defined($spec->{'memberof'}) && (!grep { $_ eq '' } @{$spec->{'memberof'}})) {
push @cases, { %mandatory_args, ( $arg_name => '', _NAME => $arg_name, _STATUS => 'DIES' ) }
} elsif(defined($spec->{'memberof'}) && !defined($spec->{'max'})) {
# Data::Random
push @cases, { %mandatory_args, _input => (rand_set(set => $spec->{'memberof'}, size => 1))[0] }
} else {
push @cases, { %mandatory_args, ( $arg_name => '', _NAME => $arg_name ) } if((!exists($spec->{min})) || ($spec->{min} == 0));
}
}
# push @cases, { $arg_name => "emoji \x{1F600}" };
push @cases, { %mandatory_args, ( $arg_name => "\0null" ) } if($config{'test_nuls'} && (!(defined $spec->{memberof})) && !defined($spec->{matches}));
unless(defined($spec->{memberof}) || defined($spec->{matches})) {
# --- min/max string/array boundaries ---
if (defined $spec->{min}) {
my $len = $spec->{min};
push @cases, { %mandatory_args, ( $arg_name => 'a' x ($len - 1), _STATUS => 'DIES' ) } if($len > 0);
push @cases, { %mandatory_args, ( $arg_name => 'a' x $len ) };
push @cases, { %mandatory_args, ( $arg_name => 'a' x ($len + 1) ) };
}
if (defined $spec->{max}) {
my $len = $spec->{max};
push @cases, { %mandatory_args, ( $arg_name => 'a' x ($len - 1) ) };
push @cases, { %mandatory_args, ( $arg_name => 'a' x $len ) };
push @cases, { %mandatory_args, ( $arg_name => 'a' x ($len + 1), _STATUS => 'DIES' ) };
}
}
}
elsif ($type eq 'boolean') {
push @cases, { %mandatory_args, ( $arg_name => 0 ) };
push @cases, { %mandatory_args, ( $arg_name => 1 ) };
push @cases, { %mandatory_args, ( $arg_name => 'true' ) };
push @cases, { %mandatory_args, ( $arg_name => 'false' ) };
push @cases, { %mandatory_args, ( $arg_name => 'off' ) };
push @cases, { %mandatory_args, ( $arg_name => 'on' ) };
push @cases, { %mandatory_args, ( $arg_name => 'yes' ) };
push @cases, { %mandatory_args, ( $arg_name => 'no' ) };
push @cases, { %mandatory_args, ( $arg_name => 'bletch', _STATUS => 'DIES' ) };
push @cases, { %mandatory_args, ( $arg_name => -1, _STATUS => 'DIES' ) };
push @cases, { %mandatory_args, ( $arg_name => 2, _STATUS => 'DIES' ) };
}
elsif ($type eq 'hashref') {
push @cases, { $arg_name => { a => 1 } };
push @cases, { $arg_name => [], _STATUS => 'DIES' };
}
elsif ($type eq 'arrayref') {
push @cases, { $arg_name => [1,2] };
push @cases, { $arg_name => { a => 1 }, _STATUS => 'DIES' };
}
# --- matches (regex) ---
if (defined $spec->{matches}) {
my $regex = $spec->{matches};
for my $string(@regex_tests) {
if($string =~ $regex) {
push @cases, { %mandatory_args, ( $arg_name => $string ) };
} else {
push @cases, { %mandatory_args, ( $arg_name => $string, _STATUS => 'DIES' ) };
}
}
}
# --- nomatch (regex) ---
if (defined $spec->{nomatch}) {
my $regex = $spec->{nomatch};
for my $string(@regex_tests) {
if($string =~ $regex) {
push @cases, { %mandatory_args, ( $arg_name => $string, _STATUS => 'DIES' ) };
} else {
push @cases, { %mandatory_args, ( $arg_name => $string ) };
}
}
}
# --- memberof ---
if (defined $spec->{memberof}) {
my @set = @{ $spec->{memberof} };
push @cases, { %mandatory_args, ( $arg_name => $set[0] ) } if @set;
push @cases, { %mandatory_args, ( $arg_name => '_not_in_set_', _STATUS => 'DIES' ) };
}
# --- notmemberof ---
if (defined $spec->{notmemberof}) {
my @set = @{ $spec->{notmemberof} };
push @cases, { %mandatory_args, ( $arg_name => $set[0], _STATUS => 'DIES' ) } if @set;
push @cases, { %mandatory_args, ( $arg_name => '_not_in_set_' ) };
}
}
}
}
# Optional deduplication
# my %seen;
# @cases = grep { !$seen{join '|', %$_}++ } @cases;
# Random data test cases
if(scalar keys %input) {
if(((scalar keys %input) == 1) && exists($input{'type'}) && !ref($input{'type'})) {
# our %input = ( type => 'string' );
my $type = $input{'type'};
for (1..[% iterations_code %]) {
my $case_input;
if (@edge_case_array && rand() < PROB_EDGE_CASE) {
# Sometimes pick a field-specific edge-case
$case_input = _pick_from(\@edge_case_array);
} elsif(exists $type_edge_cases{$type} && rand() < 0.3) {
# Sometimes pick a type-level edge-case
$case_input = _pick_from($type_edge_cases{$type});
} elsif($type eq 'string') {
if($input{matches}) {
$case_input = Data::Random::String::Matches->create_random_string({ regex => $input{'matches'} });
} else {
$case_input = rand_str();
}
} elsif($type eq 'integer') {
$case_input = rand_int() + $input{'min'};
} elsif(($type eq 'number') || ($type eq 'float')) {
$case_input = rand_num() + $input{'min'};
} elsif($type eq 'boolean') {
$case_input = rand_bool();
} else {
die "TODO: type $type";
}
push @cases, { _input => $case_input, status => 'OK', _LINE => __LINE__ } if($case_input);
}
} else {
# our %input = ( str => { type => 'string' } );
foreach my $field (keys %input) {
my $spec = $input{$field} || {};
foreach my $field(keys %{$spec}) {
if(!grep({ $_ eq $field } ('type', 'min', 'max', 'optional', 'matches', 'can', 'position', 'semantic'))) {
diag(__LINE__, ": TODO: handle schema keyword '$field'");
}
}
}
for (1..[% iterations_code %]) {
my %case_input = (%mandatory_args);
foreach my $field (keys %input) {
my $spec = $input{$field} || {};
next if $spec->{'memberof'}; # Memberof data is created below
my $type = $spec->{type} || 'string';
# 1) Sometimes pick a field-specific edge-case
if (exists $edge_cases{$field} && rand() < PROB_EDGE_CASE) {
$case_input{$field} = _pick_from($edge_cases{$field});
next;
}
# 2) Sometimes pick a type-level edge-case
if (exists $type_edge_cases{$type} && rand() < 0.3) {
$case_input{$field} = _pick_from($type_edge_cases{$type});
next;
}
# 3) Sormal random generation by type
if ($type eq 'string') {
if(my $re = $spec->{matches}) {
if(ref($re) ne 'Regexp') {
$re = qr/$re/;
}
if($spec->{'max'}) {
$case_input{$field} = Data::Random::String::Matches->create_random_string({ length => $spec->{'max'}, regex => $re });
} elsif($spec->{'min'}) {
$case_input{$field} = Data::Random::String::Matches->create_random_string({ length => $spec->{'min'}, regex => $re });
} else {
$case_input{$field} = Data::Random::String::Matches->create_random_string({ regex => $re });
}
} elsif(my $semantic = $spec->{'semantic'}) {
if($semantic eq 'email') {
$case_input{$field} = rand_email($spec->{'max'} // $spec->{'min'});
} else {
diag(__LINE__, ": TODO: handle semantic type '$semantic'");
}
} else {
if(my $min = $spec->{min}) {
$case_input{$field} = rand_str($min);
if($config{'test_empty'} && ($min == 0)) {
push @cases, { _input => \%case_input, status => 'OK' } if(keys %case_input);
$case_input{$field} = '';
}
} else {
$case_input{$field} = rand_str();
if($config{'test_empty'}) {
push @cases, { _input => \%case_input, status => 'OK' } if(keys %case_input);
$case_input{$field} = '';
}
}
}
} elsif ($type eq 'integer') {
if(my $min = $spec->{min}) {
if(my $max = $spec->{'max'}) {
$case_input{$field} = int(rand($max - $min + 1)) + $min;
} else {
$case_input{$field} = rand_int() + $min;
}
} elsif(exists($spec->{min})) {
# min == 0
if(my $max = $spec->{'max'}) {
$case_input{$field} = int(rand($max + 1));
} else {
$case_input{$field} = abs(rand_int());
}
} else {
$case_input{$field} = rand_int();
}
}
elsif ($type eq 'boolean') {
$case_input{$field} = rand_bool();
}
elsif ($type eq 'number') {
if(my $min = $spec->{min}) {
$case_input{$field} = rand_num() + $min;
} else {
$case_input{$field} = rand_num();
}
}
elsif ($type eq 'arrayref') {
$case_input{$field} = rand_arrayref();
}
elsif ($type eq 'hashref') {
$case_input{$field} = rand_hashref();
} elsif($config{'test_undef'}) {
$case_input{$field} = undef;
}
# 4) occasionally drop optional fields
if ($spec->{optional} && rand() < 0.25) {
delete $case_input{$field};
}
}
push @cases, { _input => \%case_input, status => 'OK' } if(keys %case_input);
}
}
}
# edge-cases
if($config{'test_undef'}) {
if($all_optional) {
push @cases, {};
} else {
# Note that this is set on the input rather than output
push @cases, { '_STATUS' => 'DIES' }; # At least one argument is needed
}
}
if(scalar keys %input) {
push @cases, { '_STATUS' => 'DIES', map { $_ => undef } keys %input } if($config{'test_undef'});
} else {
push @cases, { }; # Takes no input
}
# If it's not in mandatory_strings it sets to 'undef' which is the idea, to test { value => undef } in the args
push @cases, { map { $_ => $mandatory_strings{$_} } keys %input, %mandatory_objects } if($config{'test_undef'});
push @candidate_bad, '' if($config{'test_empty'});
push @candidate_bad, undef if($config{'test_undef'});
push @candidate_bad, "\0" if($config{'test_nuls'});
# generate numeric, string, hashref and arrayref min/max edge cases
# TODO: For hashref and arrayref, if there's a $spec->{schema} field, use that for the data that's being generated
if(((scalar keys %input) == 1) && exists($input{'type'}) && !ref($input{'type'})) {
# our %input = ( type => 'string' );
my $type = $input{type};
if (exists $input{memberof} && ref $input{memberof} eq 'ARRAY' && @{$input{memberof}}) {
# Generate edge cases for memberof inside values
foreach my $val (@{$input{memberof}}) {
push @cases, { _input => $val };
}
# outside value
my $outside;
if(($type eq 'integer') || ($type eq 'number') || ($type eq 'float')) {
$outside = (sort { $a <=> $b } @{$input{memberof}})[-1] + 1;
} else {
$outside = 'INVALID_MEMBEROF';
}
push @cases, { _input => $outside, _STATUS => 'DIES' };
} else {
# Generate edge cases for min/max
if($type eq 'integer') {
push @cases, @{_generate_integer_cases('_input', \%input, \%mandatory_args)};
} elsif(($type eq 'number') || ($type eq 'float')) {
push @cases, @{_generate_float_cases('_input', \%input, \%mandatory_args)};
} elsif ($type eq 'string') {
if (defined $input{min}) {
my $len = $input{min};
push @cases, { _input => 'a' x ($len + 1) }; # just inside
if($len == 0) {
push @cases, { _input => '' } if($config{'test_empty'});
} else {
# outside
push @cases, { _input => 'a' x $len }; # border
push @cases, { _input => 'a' x ($len - 1), _STATUS => 'DIES' };
}
if($len >= 1) {
# Test checking of 'defined'/'exists' rather than if($string)
push @cases, { %mandatory_args, ( _input => '0', _LINE => __LINE__ ) };
} else {
push @cases, { _input => '0', _STATUS => 'DIES' }
}
} else {
push @cases, { _input => '', _LINE => __LINE__ } if($config{'test_empty'}); # No min, empty string should be allowable
}
if (defined $input{max}) {
my $len = $input{max};
push @cases, { %mandatory_args, ( _input => 'a' x ($len - 1) ) }; # just inside
push @cases, { %mandatory_args, ( _input => 'a' x $len ) }; # border
push @cases, { %mandatory_args, ( _input => 'a' x ($len + 1), _STATUS => 'DIES' ) }; # outside
}
if(defined $input{matches}) {
my $re = $input{matches};
# --- Positive controls ---
foreach my $val (@candidate_good) {
if ($val =~ $re) {
push @cases, { %mandatory_args, ( _input => $val ) };
last; # one good match is enough
}
}
# --- Negative controls ---
foreach my $val (@candidate_bad) {
if(!defined($val)) {
push @cases, { _input => undef, _STATUS => 'DIES' };
} elsif ($val !~ $re) {
push @cases, { _input => $val, _STATUS => 'DIES' };
}
}
push @cases, { _input => undef, _STATUS => 'DIES' } if($config{'test_undef'});
push @cases, { _input => "\0", _STATUS => 'DIES' } if($config{'test_nuls'});
}
if(defined $input{nomatch}) {
my $re = $input{nomatch};
# --- Positive controls ---
foreach my $val (@candidate_good) {
if ($val !~ $re) {
push @cases, { %mandatory_args, ( _input => $val ) };
last; # one good match is enough
}
}
# --- Negative controls ---
foreach my $val (@candidate_bad) {
if ($val =~ $re) {
push @cases, { _input => $val, _STATUS => 'DIES' };
}
}
}
} elsif ($type eq 'arrayref') {
if (defined $input{min}) {
my $len = $input{min};
push @cases, { _input => [ (1) x ($len + 1) ] }; # just inside
push @cases, { _input => [ (1) x $len ] }; # border
push @cases, { _input => [ (1) x ($len - 1) ], _STATUS => 'DIES' } if $len > 0; # outside
} else {
push @cases, { _input => [] } if($config{'test_empty'}); # No min, empty array should be allowable
}
if (defined $input{max}) {
my $len = $input{max};
push @cases, { _input => [ (1) x ($len - 1) ] }; # just inside
push @cases, { _input => [ (1) x $len ] }; # border
push @cases, { _input => [ (1) x ($len + 1) ], _STATUS => 'DIES' }; # outside
}
} elsif ($type eq 'hashref') {
if (defined $input{min}) {
my $len = $input{min};
push @cases, { _input => { map { "k$_" => 1 }, 1 .. ($len + 1) } };
push @cases, { _input => { map { "k$_" => 1 }, 1 .. $len } };
push @cases, { _input => { map { "k$_" => 1 }, 1 .. ($len - 1) }, _STATUS => 'DIES' } if $len > 0;
} else {
push @cases, { _input => {} } if($config{'test_empty'}); # No min, empty hash should be allowable
}
if (defined $input{max}) {
my $len = $input{max};
push @cases, { _input => { map { "k$_" => 1 }, 1 .. ($len - 1) } };
push @cases, { _input => { map { "k$_" => 1 }, 1 .. $len } };
push @cases, { _input => { map { "k$_" => 1 }, 1 .. ($len + 1) }, _STATUS => 'DIES' };
}
} elsif ($type eq 'boolean') {
if (exists $input{memberof} && ref $input{memberof} eq 'ARRAY') {
# memberof already defines allowed booleans
foreach my $val (@{$input{memberof}}) {
push @cases, { _input => $val };
}
} else {
# basic boolean edge cases
push @cases,
{ _input => 0 },
{ _input => 1 },
{ _input => 'off' },
{ _input => 'on' },
{ _input => 'false' },
{ _input => 'true' },
{ _input => 'yes' },
{ _input => 'no' },
{ _input => 2, _STATUS => 'DIES' }, # invalid boolean
{ _input => -1, _STATUS => 'DIES' }, # invalid boolean
{ _input => [ 3 ], _STATUS => 'DIES' }, # invalid boolean
{ _input => { 'abc' => 'xyz' }, _STATUS => 'DIES' }, # invalid boolean
{ _input => 'plugh', _STATUS => 'DIES' }; # invalid boolean
push @cases, { _input => undef, _STATUS => 'DIES' } if($config{'test_undef'});
}
}
# Test all edge cases
foreach my $edge(@edge_case_array) {
push @cases, { _input => $edge };
}
}
} else {
# our %input = ( str => { type => 'string' } );
push @cases, @{generate_tests(\%input, \%mandatory_args)};
}
if($config{'dedup'}) {
return _dedup_cases(\@cases);
}
# use Data::Dumper;
# die(Dumper(@cases));
return \@cases;
}
# Functions to generate test cases
sub _generate_integer_cases {
my ($arg_name, $spec, $mandatory_args) = @_;
my @cases;
if((!defined $spec->{min}) || ($spec->{min} <= -1)) {
push @cases, { %{$mandatory_args}, ( $arg_name => -1, _LINE => __LINE__ ) };
}
if((!defined $spec->{min}) || ($spec->{min} <= 42)) {
push @cases, { %{$mandatory_args}, ( $arg_name => 42 ) };
}
[% IF module %]
# Send wrong data type - builtins aren't good at checking this
push @cases,
{ %{$mandatory_args}, ( $arg_name => "test string in integer field $arg_name", _STATUS => 'DIES', _LINE => __LINE__ ) },
{ %{$mandatory_args}, ( $arg_name => {}, _STATUS => 'DIES', _LINE => __LINE__ ) },
{ %{$mandatory_args}, ( $arg_name => 3.14, _STATUS => 'DIES' ) }, # Float
{ %{$mandatory_args}, ( $arg_name => 'xyz', _STATUS => 'DIES' ) },
{ %{$mandatory_args}, ( $arg_name => [], _STATUS => 'DIES', _LINE => __LINE__ ) };
[% END %]
# min/max numeric boundaries
if (defined $spec->{min}) {
my $min = $spec->{min};
push @cases,
{ %{$mandatory_args}, ( $arg_name => $min - 1, _STATUS => 'DIES' ) },
{ %{$mandatory_args}, ( $arg_name => $min, _LINE => __LINE__ ) }, # border
{ %{$mandatory_args}, ( $arg_name => $min + 1 ) }; # just inside
if(!defined $spec->{max}) {
push @cases, { %{$mandatory_args}, ( $arg_name => $min + rand_int() ) };
if($min == 0) {
push @cases, { %{$mandatory_args}, ( $arg_name => abs(rand_int()) ) }; # Any positive integer
}
}
}
if (defined $spec->{max}) {
my $max = $spec->{max};
push @cases,
{ %{$mandatory_args}, ( $arg_name => $max - 1 ) },
{ %{$mandatory_args}, ( $arg_name => $max ) },
{ %{$mandatory_args}, ( $arg_name => $max + 1, _STATUS => 'DIES' ) };
if(defined $spec->{min}) {
# Test 0 if it's in range
push @cases, { %{$mandatory_args}, ( $arg_name => 0 ) } if($spec->{'min'} >= 0);
} else {
push @cases, { %{$mandatory_args}, ( $arg_name => $max - rand_int() ) };
if($max == 0) {
push @cases, { %{$mandatory_args}, ( $arg_name => abs(rand_int()) * -1 ) }; # Any negative integer
}
}
} elsif(!defined $spec->{min}) {
# Can take any number, so give it one
push @cases,
{ %{$mandatory_args}, ( $arg_name => rand_int() ) },
{ %{$mandatory_args}, ( $arg_name => 0) }; # 0 is in range
}
return \@cases;
}
sub _generate_float_cases {
my ($arg_name, $spec, $mandatory_args) = @_;
my @cases;
if((!defined $spec->{min}) || ($spec->{min} <= -0.1)) {
push @cases, { %{$mandatory_args}, ( $arg_name => -0.1, _LINE => __LINE__ ) };
}
if((!defined $spec->{min}) || ($spec->{min} <= 43.56)) {
push @cases, { %{$mandatory_args}, ( $arg_name => 43.56 ) };
}
[% IF module %]
# Send wrong data type - builtins aren't good at checking this
push @cases,
{ %{$mandatory_args}, ( $arg_name => "test string in integer field $arg_name", _STATUS => 'DIES', _LINE => __LINE__ ) },
{ %{$mandatory_args}, ( $arg_name => {}, _STATUS => 'DIES', _LINE => __LINE__ ) },
{ %{$mandatory_args}, ( $arg_name => 'abc', _STATUS => 'DIES' ) },
{ %{$mandatory_args}, ( $arg_name => [], _STATUS => 'DIES', _LINE => __LINE__ ) };
[% END %]
# min/max numeric boundaries
if (defined $spec->{min}) {
my $min = $spec->{min};
push @cases,
{ %{$mandatory_args}, ( $arg_name => $min - 0.001, _STATUS => 'DIES' ) },
{ %{$mandatory_args}, ( $arg_name => $min, _LINE => __LINE__ ) }, # border
{ %{$mandatory_args}, ( $arg_name => $min + 0.001 ) }; # just inside
if(!defined $spec->{max}) {
push @cases, { %{$mandatory_args}, ( $arg_name => $min + rand_num() ) };
if($min == 0) {
push @cases, { %{$mandatory_args}, ( $arg_name => abs(rand_num()) ) }; # Any positive number
}
}
}
if (defined $spec->{max}) {
my $max = $spec->{max};
push @cases,
{ %{$mandatory_args}, ( $arg_name => $max - 0.000001 ) },
{ %{$mandatory_args}, ( $arg_name => $max ) },
{ %{$mandatory_args}, ( $arg_name => $max + 0.000001, _STATUS => 'DIES' ) };
if(defined $spec->{min}) {
# Test 0 if it's in range
push @cases, { %{$mandatory_args}, ( $arg_name => 0 ) } if($spec->{'min'} >= 0);
} else {
push @cases, { %{$mandatory_args}, ( $arg_name => $max - rand_num() ) };
if($max == 0) {
push @cases, { %{$mandatory_args}, ( $arg_name => abs(rand_num()) * -0.00000001 ) }; # Any negative number
}
}
} elsif(!defined $spec->{min}) {
# Can take any number, so give it some
push @cases,
{ %{$mandatory_args}, ( $arg_name => rand_num() ) },
{ %{$mandatory_args}, ( $arg_name => 1.23 ) },
{ %{$mandatory_args}, ( $arg_name => -42.1 ) },
{ %{$mandatory_args}, ( $arg_name => 0) }; # 0 is in range
}
return \@cases;
}
# dedup, fuzzing can easily generate repeats
# FIXME: I don't think this catches them all
# FIXME: Handle cases with Class::Simple calls
sub _dedup_cases
{
my $cases = shift;
require JSON::MaybeXS;
JSON::MaybeXS->import();
my %seen;
my @rc = grep {
my $dump = encode_json($_);
!$seen{$dump}++
} @{$cases};
return \@rc;
}
sub generate_tests
{
my $input = $_[0];
my %mandatory_args = %{$_[1]};
my @cases;
foreach my $field (keys %input) {
my $spec = $input{$field} || {};
my $type = $spec->{type} || 'string';
if (exists $spec->{memberof} && ref $spec->{memberof} eq 'ARRAY' && @{$spec->{memberof}}) {
# Generate edge cases for memberof
# inside values
foreach my $val (@{$spec->{memberof}}) {
push @cases, { %mandatory_args, ( $field => $val ) };
}
# outside value
my $outside;
if ($type eq 'integer' || $type eq 'number') {
$outside = (sort { $a <=> $b } @{$spec->{memberof}})[-1] + 1;
} else {
$outside = 'INVALID_MEMBEROF';
}
push @cases, { %mandatory_args, ( $field => $outside, _STATUS => 'DIES' ) };
} else {
# Generate edge cases for min/max
if($type eq 'integer') {
push @cases, @{_generate_integer_cases($field, $spec, \%mandatory_args)};
} elsif(($type eq 'number') || ($type eq 'float')) {
push @cases, @{_generate_float_cases($field, $spec, \%mandatory_args)};
} elsif($type eq 'string') {
if (defined $spec->{min}) {
my $len = $spec->{min};
if(my $re = $spec->{matches}) {
for my $count ($len + 1, $len, $len - 1) {
next if ($count < 0);
my $str = rand_str($count);
if($str =~ $re) {
push @cases, { %mandatory_args, ( $field => $str ) };
} else {
push @cases, { %mandatory_args, ( $field => $str, _STATUS => 'DIES' ) };
}
}
} else {
push @cases, { %mandatory_args, ( $field => 'a' x ($len + 1) ) }; # just inside
push @cases, { %mandatory_args, ( $field => 'a' x $len ) }; # border
if($len > 0) {
if(($len > 1) || $config{'test_empty'}) {
# outside
push @cases, { %mandatory_args, ( $field => 'a' x ($len - 1), _STATUS => 'DIES' ) };
}
if($len <= 1) {
push @cases, { %mandatory_args, ( $field => '9' ) };
push @cases, { %mandatory_args, ( $field => '' ) } if($len == 0);
}
} else {
push @cases, { %mandatory_args, ( $field => '' ) } if($config{'test_empty'}); # min == 0, empty string should be allowable
# Don't confuse if() with if(defined())
push @cases, { %mandatory_args, ( $field => '0', _STATUS => 'DIES' ) };
}
}
} else {
push @cases, { %mandatory_args, ( $field => '' ) } if($config{'test_empty'}); # No min, empty string should be allowable
}
if (defined $spec->{max}) {
my $len = $spec->{max};
if((!defined($spec->{min})) || ($spec->{min} != $len)) {
if(my $re = $spec->{matches}) {
for my $count ($len - 1, $len, $len + 1) {
my $str = rand_str($count);
if($str =~ $re) {
if($count > $len) {
push @cases, { %mandatory_args, ( $field => $str, _LINE => __LINE__, _STATUS => 'DIES' ) };
} else {
push @cases, { %mandatory_args, ( $field => $str, _LINE => __LINE__ ) };
}
} else {
push @cases, { %mandatory_args, ( $field => $str, _STATUS => 'DIES', _LINE => __LINE__ ) };
}
}
} else {
push @cases, { %mandatory_args, ( $field => 'a' x ($len - 1), _LINE => __LINE__ ) }; # just inside
push @cases, { %mandatory_args, ( $field => 'a' x $len, _LINE => __LINE__ ) }; # border
push @cases, { %mandatory_args, ( $field => 'a' x ($len + 1), _LINE => __LINE__, _STATUS => 'DIES' ) }; # outside
}
}
} else {
if(exists($spec->{'min'})) {
push @cases, { %mandatory_args, ( $field => 'a' x (($spec->{'min'} + 1) * 1_000), _LINE => __LINE__ ) };
} else {
push @cases, { %mandatory_args, ( $field => 'a' x 10_000, _LINE => __LINE__ ) };
}
}
if(defined $spec->{matches}) {
my $re = $spec->{matches};
# --- Positive controls ---
foreach my $val (@candidate_good) {
if ($val =~ $re) {
push @cases, { %mandatory_args, ( $field => $val ) };
last; # one good match is enough
}
}
# --- Negative controls ---
foreach my $val (@candidate_bad) {
if(!defined($val)) {
push @cases, { _input => undef, _STATUS => 'DIES' } if($config{'test_undef'});
} elsif ($val !~ $re) {
push @cases, { _input => $val, _STATUS => 'DIES' };
}
}
push @cases, { $field => undef, _STATUS => 'DIES' } if($config{'test_undef'});
push @cases, { $field => "\0", _STATUS => 'DIES' } if($config{'test_nuls'});
}
if(defined $spec->{nomatch}) {
my $re = $spec->{nomatch};
# --- Positive controls ---
foreach my $val (@candidate_good) {
if ($val !~ $re) {
push @cases, { %mandatory_args, ( $field => $val ) };
last; # one good match is enough
}
}
# --- Negative controls ---
foreach my $val (@candidate_bad) {
if ($val =~ $re) {
push @cases, { $field => $val, _STATUS => 'DIES' };
}
}
}
# Send wrong data type
push @cases, { %mandatory_args, ( $field => [], _STATUS => 'DIES', _LINE => __LINE__ ) } if($config{'test_empty'});
push @cases, { %mandatory_args, ( $field => {}, _STATUS => 'DIES', _LINE => __LINE__ ) } if($config{'test_empty'});
} elsif ($type eq 'arrayref') {
if (defined $spec->{min}) {
my $len = $spec->{min};
push @cases, { $field => [ (1) x ($len + 1) ] }; # just inside
push @cases, { $field => [ (1) x $len ] }; # border
push @cases, { $field => [ (1) x ($len - 1) ], _STATUS => 'DIES' } if $len > 0; # outside
} else {
push @cases, { $field => [] } if($config{'test_empty'}); # No min, empty array should be allowable
}
if (defined $spec->{max}) {
my $len = $spec->{max};
push @cases, { $field => [ (1) x ($len - 1) ] }; # just inside
push @cases, { $field => [ (1) x $len ] }; # border
push @cases, { $field => [ (1) x ($len + 1) ], _STATUS => 'DIES' }; # outside
}
} elsif ($type eq 'hashref') {
if (defined $spec->{min}) {
my $len = $spec->{min};
push @cases, { $field => { map { "k$_" => 1 }, 1 .. ($len + 1) } };
push @cases, { $field => { map { "k$_" => 1 }, 1 .. $len } };
push @cases, { $field => { map { "k$_" => 1 }, 1 .. ($len - 1) }, _STATUS => 'DIES' } if $len > 0;
} else {
push @cases, { $field => {} } if($config{'test_empty'}); # No min, empty hash should be allowable
}
if (defined $spec->{max}) {
my $len = $spec->{max};
push @cases, { $field => { map { "k$_" => 1 }, 1 .. ($len - 1) } };
push @cases, { $field => { map { "k$_" => 1 }, 1 .. $len } };
push @cases, { $field => { map { "k$_" => 1 }, 1 .. ($len + 1) }, _STATUS => 'DIES' };
}
} elsif ($type eq 'boolean') {
if (exists $spec->{memberof} && ref $spec->{memberof} eq 'ARRAY') {
# memberof already defines allowed booleans
foreach my $val (@{$spec->{memberof}}) {
push @cases, { %mandatory_args, ( $field => $val ) };
}
} else {
# basic boolean edge cases
push @cases,
{ %mandatory_args, ( $field => 0 ) },
{ %mandatory_args, ( $field => 1 ) },
{ %mandatory_args, ( $field => 'false' ) },
{ %mandatory_args, ( $field => 'true' ) },
{ %mandatory_args, ( $field => 'off' ) },
{ %mandatory_args, ( $field => 'on' ) },
{ %mandatory_args, ( $field => 'yes' ) },
{ %mandatory_args, ( $field => 'no' ) },
{ %mandatory_args, ( $field => 2, _STATUS => 'DIES' ) }, # invalid boolean
{ %mandatory_args, ( $field => -1, _STATUS => 'DIES' ) }, # invalid boolean
{ %mandatory_args, ( $field => 'xyzzy', _STATUS => 'DIES' ) }; # invalid boolean
push @cases, { %mandatory_args, ( $field => undef, _STATUS => 'DIES' ) } if($config{'test_undef'});
push @cases, { %mandatory_args, ( $field => '', _STATUS => 'DIES' ) } if($config{'test_empty'});
}
}
}
# case_sensitive tests for memberof
if (defined $spec->{memberof} && exists $spec->{case_sensitive}) {
if (!$spec->{case_sensitive}) {
# Generate mixed-case versions of memberof values
foreach my $val (@{$spec->{memberof}}) {
push @cases, { %mandatory_args, ( $field => uc($val) ) },
{ %mandatory_args, ( $field => lc($val) ) },
{ %mandatory_args, ( $field => ucfirst(lc($val)) ) };
}
}
}
# Add notmemberof tests
if (defined $spec->{notmemberof}) {
my @blacklist = @{$spec->{notmemberof}};
# Each blacklisted value should die
foreach my $val (@blacklist) {
push @cases, { %mandatory_args, ( $field => $val, _STATUS => 'DIES' ) };
}
# Non-blacklisted value should pass
push @cases, { %mandatory_args, ( $field => '_not_in_blacklist_' ) };
}
# TODO: How do we generate tests for cross-field validation?
}
return \@cases;
}
sub populate_positions
{
my $input = shift;
my $rc;
foreach my $arg (keys %{$input}) {
my $spec = $input->{$arg} || {};
if(((ref($spec)) eq 'HASH') && defined($spec->{'position'})) {
$rc->{$arg} = $spec->{'position'};
} else {
if($rc) {
::diag("$arg is missing a position parameter in its schema");
}
return; # All must be defined
}
}
return $rc;
}
sub run_test
{
my($case, $input, $output, $positions) = @_;
if($ENV{'TEST_VERBOSE'}) {
diag('input: ', Dumper($input));
}
my $name = delete local $case->{'_NAME'};
my $result;
my $mess;
if(defined($input) && !ref($input)) {
if($name) {
$mess = "[% function %]($name = '$input') %s";
} else {
$mess = "[% function %]('$input') %s";
}
} elsif(defined($input)) {
my @alist = ();
if($positions) {
# Positional args
foreach my $key (keys %{$input}) {
if(($key ne '_STATUS') && ($key ne '_NAME')) {
if(exists($positions->{$key})) {
$alist[$positions->{$key}] = delete $input->{$key};
} else {
diag("Lost position number for $key");
}
}
}
@alist = grep { defined $_ } @alist; # Undefs will cause not enough args to be sent, which is a nice test
$input = join(', ', @alist);
} else {
# Named args
foreach my $key (sort keys %{$input}) {
if($key ne '_STATUS') {
if(defined($input->{$key})) {
push @alist, "'$key' => '$input->{$key}'";
} else {
push @alist, "'$key' => undef";
}
}
}
}
my $args = join(', ', @alist);
$args =~ s/%/%%/g;
$mess = "[% function %]($args) %s";
} else {
$mess = "[% function %] %s";
}
if(my $status = (delete $case->{'_STATUS'} || $output->{'_STATUS'})) {
if($status eq 'DIES') {
dies_ok { [% call_code %] } sprintf($mess, 'dies');
ok(!defined($result));
return; # There should be no output to validate
} elsif($status eq 'WARNS') {
warnings_exist { [% call_code %] } qr/./, sprintf($mess, 'warns');
} else {
lives_ok { [% call_code %] } sprintf($mess, 'survives');
}
} else {
lives_ok { [% call_code %] } sprintf($mess, 'survives');
}
delete local $output->{'_STATUS'};
if(scalar keys %{$output}) {
if($ENV{'TEST_VERBOSE'}) {
diag('result: ', Dumper($result));
}
returns_ok($result, $output, 'output validates');
}
}
my $positions = populate_positions(\%input);
diag('Run Fuzz Tests') if($ENV{'TEST_VERBOSE'});
foreach my $case (@{fuzz_inputs()}) {
# my %params;
# lives_ok { %params = get_params(\%input, %$case) } 'Params::Get input check';
# lives_ok { validate_strict(\%input, %params) } 'Params::Validate::Strict input check';
my $input;
if((ref($case) eq 'HASH') && exists($case->{'_input'})) {
$input = $case->{'_input'};
} else {
$input = $case;
}
if(my $line = (delete $case->{'_LINE'} || delete $input{'_LINE'})) {
diag("Test case from line number $line") if($ENV{'TEST_VERBOSE'});
}
{
# local %ENV;
run_test($case, $input, \%output, $positions);
# delete $ENV{'LANG'};
# delete $ENV{'LC_ALL'};
# run_test($case, $input, \%output, $positions);
# $ENV{'LANG'} = 'fr_FR.utf8';
# $ENV{'LC_ALL'} = 'fr_FR.utf8';
# run_test($case, $input, \%output, $positions);
}
}
diag('Run ', scalar(keys %transforms), ' transform tests') if($ENV{'TEST_VERBOSE'});
# diag('-' x 60);
# Build the foundation - which is a basic test with sensible defaults in the field
foreach my $transform (keys %transforms) {
my $foundation; # basic set of data with every field filled in with a sensible default value
foreach my $field (keys %input) {
my $spec = $input{$field} || {};
my $type = $spec->{type} || 'string';
if(($type eq 'number') || ($type eq 'float')) {
if(defined $spec->{min}) {
if(defined $spec->{max}) {
$foundation->{$field} = $spec->{max}; # border
} else {
$foundation->{$field} = rand_num() + $spec->{'min'};
}
} else {
if(defined $spec->{max}) {
$foundation->{$field} = $spec->{max}; # border
} else {
$foundation->{$field} = -0.1; # No min, so -0.1 should be allowable
}
}
} elsif($type eq 'string') {
if(defined $spec->{min} && $spec->{min} > 0) {
$foundation->{$field} = 'a' x $spec->{min};
} elsif(defined $spec->{max} && $spec->{max} > 0) {
$foundation->{$field} = 'b' x $spec->{max};
} else {
$foundation->{$field} = 'test_value';
}
} elsif ($type eq 'integer') {
if (defined $spec->{min}) {
$foundation->{$field} = $spec->{min};
} elsif (defined $spec->{max}) {
$foundation->{$field} = rand_int() + $spec->{max};
} else {
$foundation->{$field} = rand_int();
}
} elsif ($type eq 'boolean') {
$foundation->{$field} = 1;
} elsif ($type eq 'arrayref') {
$foundation->{$field} = rand_arrayref(defined($spec->{'min'}) ? $spec->{'min'} : ($spec->{'max'} // 5));
} elsif ($type eq 'hashref') {
$foundation->{$field} = { key => 'value' };
} else {
die("TODO: transform type $type for foundation");
}
}
# The foundation should work
my $case = { _NAME => "basic $transform test", _LINE => __LINE__ };
my $positions = populate_positions(\%input);
run_test($case, $foundation, \%output, $positions);
# Generate transform tests
# Don't generate invalid data, that's all already done,
# this is about verifying the transorms
my @tests;
diag("tests for transform $transform") if($ENV{'TEST_VERBOSE'});
# Now modify the foundation with test code
# BUILD CODE TO CALL FUNCTION
# CALL FUNCTION
# CHECK STATUS CORRECT
# IF STATUS EQ LIVES
# CHECK OUTPUT USING returns_ok
# FI
my $transform_input = $transforms{$transform}{'input'} || {};
foreach my $field (keys %input) {
my $spec = $transform_input->{$field} || {};
my $type = $spec->{type} || 'string';
# If there's a specific value, test that exact value
if (exists $spec->{value}) {
push @tests, {
%{$foundation},
$field => $spec->{value},
_LINE => __LINE__
# _DESCRIPTION => "$transform_name: $field=$spec->{value}"
};
next;
}
# Generate edge cases based on type and contraints
if($type eq 'integer') {
push @tests, @{_generate_integer_cases($field, $spec, $foundation)};
} elsif(($type eq 'number') || ($type eq 'float')) {
push @tests, @{_generate_float_cases($field, $spec, $foundation)};
} elsif($type eq 'string') {
if(defined $spec->{min}) {
push @tests, { %{$foundation}, ( $field => rand_str($spec->{min} + 1) ) }; # just inside
push @tests, { %{$foundation}, ( $field => rand_str($spec->{min}) ) }; # border
} else {
push @tests, { %{$foundation}, ( $field => rand_str() ) };
}
if(defined $spec->{max}) {
push @tests, { %{$foundation}, ( $field => rand_str($spec->{max} - 1) ) }; # just inside
if((defined $spec->{min}) && ($spec->{'min'} != $spec->{'max'})) {
push @tests, { %{$foundation}, ( $field => rand_str($spec->{max}) ) }; # border
}
}
} elsif($type eq 'boolean') {
push @tests, { %{$foundation}, ( $field => 1 ) }, { %{$foundation}, ( $field => 0 ) };
} elsif ($type eq 'arrayref') {
if(defined $spec->{min}) {
push @tests, { %{$foundation}, ( $field => rand_arrayref($spec->{min} + 1) ) }; # just inside
push @tests, { %{$foundation}, ( $field => rand_arrayref($spec->{min}) ) }; # border
} else {
push @tests, { %{$foundation}, ( $field => rand_arrayref() ) };
}
if(defined $spec->{max}) {
push @tests, { %{$foundation}, ( $field => rand_arrayref($spec->{max} - 1) ) }; # just inside
if((defined $spec->{min}) && ($spec->{'min'} != $spec->{'max'})) {
push @tests, { %{$foundation}, ( $field => rand_arrayref($spec->{max}) ) }; # border
}
}
} else {
die("TODO: transform type $type for test case");
}
}
if($config{'dedup'}) {
@tests = @{_dedup_cases(\@tests)};
}
{
# local %ENV;
my $transform_output = $transforms{$transform}{'output'} || {};
foreach my $test(@tests) {
if(my $line = (delete $test->{'_LINE'} || delete $input{'_LINE'})) {
diag("Test case from line number $line") if($ENV{'TEST_VERBOSE'});
}
run_test({ _NAME => $transform }, $test, $transform_output, $positions);
# delete $ENV{'LANG'};
# delete $ENV{'LC_ALL'};
# run_test({ _NAME => $transform }, $test, \%output, $positions);
# $ENV{'LANG'} = 'de_DE.utf8';
# $ENV{'LC_ALL'} = 'de_DE.utf8';
# run_test({ _NAME => $transform }, $test, \%output, $positions);
}
}
}
[% IF use_properties %]
# ============================================================
# Property-Based Transform Tests (Test::LectroTest)
# ============================================================
use Test::LectroTest::Compat;
use Test::LectroTest::Generator qw(:common);
use Scalar::Util qw(looks_like_number);
diag('Run property-based transform tests') if($ENV{'TEST_VERBOSE'});
[% transform_properties_code %]
[% END %]
[% corpus_code %]
done_testing();
__END__