view release on metacpan or  search on metacpan

lib/App/Test/Generator/Template.pm  view on Meta::CPAN

							{ %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' ) },
							{ %mandatory_args, ( $arg_name => '2024-01-01T00:00:00+05:30' ) },
							{ %mandatory_args, ( $arg_name => '2024-01-01' ) },          # date only - check if accepted
							{ %mandatory_args, ( $arg_name => '2024-01-01T25:00:00Z', _STATUS => 'DIES' ) },  # hour 25
							{ %mandatory_args, ( $arg_name => '2024-01-01T00:61:00Z', _STATUS => 'DIES' ) },  # minute 61
							{ %mandatory_args, ( $arg_name => 'not-a-datetime', _STATUS => 'DIES' ) },
							{ %mandatory_args, ( $arg_name => '', _STATUS => 'DIES' ) };
					} else {
						diag("semantic type $semantic is not yet supported");
					}
				}
			}
		}
	}

	# Optional deduplication
	# my %seen;
	# @cases = grep { !$seen{join '|', %$_}++ } @cases;

	# Random data test cases
	# Uses type_edge_cases sometimes
	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') {
					my $min = $input{'min'} // 0;

					$case_input = int(rand_int() + $min);
					# If it's takes an integer, a float should die
					push @cases, { _input => $case_input + 0.1, _STATUS => 'DIES', _LINE => __LINE__ };
				} 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' } );
			push @cases, @{generate_tests(\%input, \%mandatory_args, _LINE => __LINE__)};

		}
	}

	# edge-cases
	if($config{'test_undef'}) {
		if($all_optional) {
			push @cases, { '_DESCRIPTION' => 'No args since all are optional' };
		} 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, { '_DESCRIPTION' => 'Takes no input' };	# 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
	# _LINE has to go first or else the undef in there mucks up the hash format
	push @cases, { _LINE => __LINE__, map { $_ => $mandatory_strings{$_} } keys %input, %mandatory_objects } if($config{'test_undef'} && !$positions);

	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

lib/App/Test/Generator/Template.pm  view on Meta::CPAN

				{ %{$mandatory_args}, ( $arg_name => [], _STATUS => 'DIES', _LINE => __LINE__ ) },
				{ %{$mandatory_args}, ( $arg_name => {}, _STATUS => 'DIES', _LINE => __LINE__ ) };
		}
		push @cases,
			{ %{$mandatory_args}, ( $arg_name => \'ref to scalar', _STATUS => 'DIES', _LINE => __LINE__ ) },
			{ %{$mandatory_args}, ( $arg_name => sub { die 'boom' }, _STATUS => 'DIES', _LINE => __LINE__ ) },
			{ %{$mandatory_args}, ( $arg_name => bless({}, 'Evil::Class'), _STATUS => 'DIES', _LINE => __LINE__ ) },
			# { %{$mandatory_args}, ( $arg_name => [1, 2, 3], _STATUS => 'DIES', _LINE => __LINE__ ) },	# Generates false positives. Why?
			{ %{$mandatory_args}, ( $arg_name => { a => 1 }, _STATUS => 'DIES', _LINE => __LINE__ ) };
	[% END %]

	return \@cases;
}

# dedup, fuzzing can easily generate repeats
# FIXME: I don't think this catches them all
# FIXME: Handle cases with Class::Simple calls
# FIXME: The JSON encoding fails on various data types that are sent (e.g. scalar refs, objects) so don't bother
sub _dedup_cases
{
	my $cases = shift;

	# Do not use JSON::MaybeXS because it will fail on non utf-8 characters
	require JSON::PP;
	JSON::PP->import();

	eval {
		my %seen;
		my @rc = grep {
			my $dump = encode_json($_);
			!$seen{$dump}++
		} @{$cases};

		return \@rc;
	};
	# Carp::carp(__PACKAGE__, ": disabling deduping: $@");

	return $cases;
}

sub generate_tests
{
	my $input = $_[0];
	my %mandatory_args = %{$_[1]};

	my @cases;

	foreach my $field (keys %input) {
		my $spec = $input{$field} || {};
		foreach my $field(keys %{$spec}) {
			next if($field =~ /^_/);	# Ignore comments
			if(!grep({ $_ eq $field } ('type', 'min', 'max', 'optional', 'matches', 'can', 'position', 'memberof', 'semantic', 'isa'))) {
				die("TODO: handle schema keyword '$field'");
			}
		}
	}

	# Build a test of the mandatory args
	push @cases, { _input => \%mandatory_args, status => 'OK' } if(keys %mandatory_args);

	for (1..[% iterations_code %]) {
		# One by one change each of the mandatory fields
		foreach my $field (keys %input) {
			my $spec = $input{$field} || {};
			next if $spec->{'memberof'};	# Memberof data is created below
			my $type = $spec->{type} || 'string';

			my %case_input = (%mandatory_args);
			# 1) Sometimes pick a field-specific edge-case
			if (exists $edge_cases{$field} && rand() < PROB_EDGE_CASE) {
				push @cases, { _input => \%case_input, status => 'OK' } if(keys %case_input);
				$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});
				push @cases, { _input => \%case_input, status => 'OK' } if(keys %case_input);
				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'");
					}
				} elsif(!$spec->{'memberof'}) {
					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 {