App-Test-Generator
view release on metacpan or search on metacpan
lib/App/Test/Generator/Template.pm view on Meta::CPAN
} elsif ($type eq 'hashref') {
push @cases,
{ $arg_name => { a => 1 } },
{ $arg_name => [], _STATUS => 'DIES' },
{ $arg_name => ( b => 2 ), _STATUS => 'DIES' },
{ $arg_name => 66, _STATUS => 'DIES' },
{ $arg_name => sub { die 'fail' }, _STATUS => 'DIES' },
{ $arg_name => 'scalar when hashref is needed', _STATUS => 'DIES' },
{ $arg_name => \'scalarref when hashref is needed', _STATUS => 'DIES' };
} elsif ($type eq 'arrayref') {
my $circular_ref = [];
push @{$circular_ref}, $circular_ref;
push @cases,
{ $arg_name => [1,2] },
{ $arg_name => $circular_ref, _STATUS => 'DIES', _DESCRIPTION => 'circular ref is caught' },
{ $arg_name => { a => 1 }, _STATUS => 'DIES' };
} elsif($type eq 'object') {
if($spec->{'isa'}) {
push @cases, { $arg_name => { a => 1 }, _STATUS => 'DIES', _LINE => __LINE__ };
push @cases, { $arg_name => [], _STATUS => 'DIES', _LINE => __LINE__ };
# Test dies when given the wrong type of object
push @cases, { $arg_name => new_ok('MyTestPackage'), _STATUS => 'DIES', _LINE => __LINE__ };
use_ok($spec->{isa});
push @cases, { $arg_name => new_ok($spec->{isa}) };
} elsif(!$spec->{can}) {
Carp::carp("neither 'isa' nor 'can' is defined - what type of object should be sent?");
}
}
# --- 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_' ) };
}
# --- semantic ---
if(defined(my $semantic = $spec->{'semantic'})) {
if(defined(my $semantic = $spec->{'semantic'})) {
push @cases, { %mandatory_args, ( -1, _STATUS => 'DIES' ) },
{ %mandatory_args, ( $arg_name => 0 ) },
{ %mandatory_args, ( $arg_name => 1 ) },
{ %mandatory_args, ( $arg_name => time ) },
{ %mandatory_args, ( $arg_name => 2147483647 ) },
{ %mandatory_args, ( 45.67, _STATUS => 'DIES', _DESCRIPTION => 'UNIX timestamp should not be a float' ) },
{ %mandatory_args, ( $arg_name => 2147483648, _STATUS => 'DIES' ) };
} elsif($semantic eq 'email') {
push @cases,
{ %mandatory_args, ( $arg_name => 'user@example.com' ) },
{ %mandatory_args, ( $arg_name => 'user+tag@sub.example.co.uk' ) },
{ %mandatory_args, ( $arg_name => '@nodomain', _STATUS => 'DIES' ) },
{ %mandatory_args, ( $arg_name => 'noatsign', _STATUS => 'DIES' ) },
{ %mandatory_args, ( $arg_name => 'user@', _STATUS => 'DIES' ) },
{ %mandatory_args, ( $arg_name => '', _STATUS => 'DIES' ) },
{ %mandatory_args, ( $arg_name => 'user@' . ('a' x 256) . '.com', _STATUS => 'DIES' ) };
} elsif($semantic eq 'filepath') {
push @cases,
{ %mandatory_args, ( $arg_name => '/tmp/test.txt' ) },
{ %mandatory_args, ( $arg_name => 'relative/path.txt' ) },
{ %mandatory_args, ( $arg_name => '.' ) },
{ %mandatory_args, ( $arg_name => '..' ) },
{ %mandatory_args, ( $arg_name => '../../etc/passwd', _STATUS => 'DIES' ) },
{ %mandatory_args, ( $arg_name => '/etc/passwd' . "\0", _STATUS => 'DIES' ) },
{ %mandatory_args, ( $arg_name => '', _STATUS => 'DIES' ) },
{ %mandatory_args, ( $arg_name => '/' . ('a' x 4096), _STATUS => 'DIES' ) };
if($^O eq 'MSWin32') {
push @cases,
{ %mandatory_args, ( $arg_name => 'C:\\Users\\test\\file.txt' ) },
{ %mandatory_args, ( $arg_name => 'D:\\' ) },
{ %mandatory_args, ( $arg_name => 'relative\\path.txt' ) },
{ %mandatory_args, ( $arg_name => 'C:\\..\\..\\Windows\\System32', _STATUS => 'DIES' ) },
{ %mandatory_args, ( $arg_name => 'C:\\path\\' . "\0" . 'file', _STATUS => 'DIES' ) },
{ %mandatory_args, ( $arg_name => 'COM1', _STATUS => 'DIES' ) }, # reserved device name
{ %mandatory_args, ( $arg_name => 'NUL', _STATUS => 'DIES' ) }, # reserved device name
{ %mandatory_args, ( $arg_name => 'C:\\path\\file?.txt', _STATUS => 'DIES' ) }, # wildcard
{ %mandatory_args, ( $arg_name => 'C:\\path\\file*.txt', _STATUS => 'DIES' ) }, # wildcard
{ %mandatory_args, ( $arg_name => '\\\\server\\share\\file.txt' ) }; # UNC path
}
} elsif($semantic eq 'date_string') {
push @cases,
{ %mandatory_args, ( $arg_name => '2024-01-01' ) },
{ %mandatory_args, ( $arg_name => '1970-01-01' ) },
{ %mandatory_args, ( $arg_name => '2024-02-29' ) }, # leap day
{ %mandatory_args, ( $arg_name => '2023-02-29', _STATUS => 'DIES' ) }, # not a leap year
{ %mandatory_args, ( $arg_name => '2024-13-01', _STATUS => 'DIES' ) }, # month 13
{ %mandatory_args, ( $arg_name => '2024-00-01', _STATUS => 'DIES' ) }, # month 0
{ %mandatory_args, ( $arg_name => '01-01-2024', _STATUS => 'DIES' ) }, # wrong order
{ %mandatory_args, ( $arg_name => '2024/01/01', _STATUS => 'DIES' ) }, # wrong separator
{ %mandatory_args, ( $arg_name => 'not-a-date', _STATUS => 'DIES' ) },
{ %mandatory_args, ( $arg_name => '', _STATUS => 'DIES' ) };
} elsif($semantic eq 'iso8601_string') {
push @cases,
{ %mandatory_args, ( $arg_name => '2024-01-01T00:00:00Z' ) },
{ %mandatory_args, ( $arg_name => '2024-06-15T12:30:45Z' ) },
lib/App/Test/Generator/Template.pm view on Meta::CPAN
push @cases, @{_generate_string_cases($field, $spec, \%mandatory_args)};
} elsif ($type eq 'arrayref') {
if (defined $spec->{min}) {
my $len = $spec->{min};
push @cases,
{ $field => [ (1) x ($len + 1) ] }, # just inside
{ $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
{ $field => [ (1) x $len ] }, # border
{ $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) } },
{ $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) } },
{ $field => { map { "k$_" => 1 }, 1 .. $len } },
{ $field => { map { "k$_" => 1 }, 1 .. ($len + 1) }, _STATUS => 'DIES' };
}
} elsif ($type eq 'boolean') {
push @cases, @{_generate_boolean_cases($field, $spec, \%mandatory_args)};
}
}
# 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_' ) };
}
# semantic tests
if(defined(my $semantic = $spec->{'semantic'})) {
if($semantic eq 'unix_timestamp') {
push @cases, { %mandatory_args, ( -1, _STATUS => 'DIES' ) },
{ %mandatory_args, ( 0 ) },
{ %mandatory_args, ( 1 ) },
{ %mandatory_args, ( time ) },
{ %mandatory_args, ( 2147483647 ) },
{ %mandatory_args, ( 45.67, _STATUS => 'DIES', _DESCRIPTION => 'UNIX timestamp should not be a float' ) },
{ %mandatory_args, ( 2147483648, _STATUS => 'DIES' ) };
} else {
diag("semantic type $semantic is not yet supported");
}
}
if(@relationships) {
diag('Run relationship tests') if($ENV{'TEST_VERBOSE'});
foreach my $rel (@relationships) {
my $type = $rel->{type};
if($type eq 'mutually_exclusive') {
my ($p1, $p2) = @{ $rel->{params} };
# Both specified — should die
run_test(
{ _STATUS => 'DIES',
_DESCRIPTION => "mutually exclusive: $p1 and $p2 both given" },
{ %mandatory_args, $p1 => 'val1', $p2 => 'val2' },
\%output,
$positions
);
# Each alone — should live
run_test(
{ _DESCRIPTION => "mutually exclusive: only $p1 given" },
{ %mandatory_args, $p1 => 'val1' },
\%output,
$positions
);
run_test(
{ _DESCRIPTION => "mutually exclusive: only $p2 given" },
{ %mandatory_args, $p2 => 'val2' },
\%output,
$positions
);
} elsif($type eq 'required_group') {
my @params = @{ $rel->{params} };
# None specified — should die
my %none = map { $_ => undef } @params;
run_test(
{ _STATUS => 'DIES',
_DESCRIPTION => 'required_group: none of (' . join(', ', @params) . ') given' },
{ %mandatory_args, %none },
\%output,
$positions
);
# Each alone — should live
foreach my $p (@params) {
run_test(
( run in 1.939 second using v1.01-cache-2.11-cpan-39bf76dae61 )