view release on metacpan or  search on metacpan

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

						);
						# if_param equals trigger value, then_param present — should live
						run_test(
							{ _DESCRIPTION => "value_conditional: $if_param='$equals', $then_param present" },
							{ %mandatory_args, $if_param => $equals, $then_param => 'val' },
							\%output,
							$positions
						);
						# if_param different value — then_param absence should not matter
						run_test(
							{ _DESCRIPTION => "value_conditional: $if_param != '$equals', $then_param not required" },
							{ %mandatory_args, $if_param => '__other__', $then_param => undef },
							\%output,
							$positions
						);
					}
				}
			}
		}
	}

	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 $properties = delete local $case->{_PROPERTIES};
	my $description = delete local $case->{_DESCRIPTION};
	my $result;
	my $mess;
	my @alist = ();
	if(defined($input) && !ref($input)) {
		# $mess is later used as a sprintf() format string further
		# below — a literal '%' in $name/$input must be escaped to
		# '%%' first, the same as the aggregate branch does for
		# $args, or a value like '%s' / '%n' corrupts the sprintf call.
		(my $safe_input = $input) =~ s/%/%%/g;
		if($name) {
			(my $safe_name = $name) =~ s/%/%%/g;
			$mess = "[% function %]($safe_name = '$safe_input') %s";
		} else {
			$mess = "[% function %]('$safe_input') %s";
		}
	} elsif(defined($input)) {
		if($positions) {
			# Positional args
			foreach my $key (keys %{$input}) {
				if(($key ne '_STATUS') && ($key ne '_NAME') && ($key ne '_LINE') && ($key ne '_PROPERTIES') && ($key ne '_DESCRIPTION')) {
					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
			if(ref($input) ne 'HASH') {
				if($case->{'_STATUS'} ne 'DIES') {
					die('Input is missing list of arguments (perhaps you only listed types)');
				}
				# e.g., we are passing a ref to a scalar to something that only takes a scalar, so it should cause the routine to die
				$positions = {};
				$alist[0] = $input;
			} else {
				foreach my $key (sort keys %{$input}) {
					if(($key ne '_STATUS') && ($key ne '_NAME') && ($key ne '_LINE') && ($key ne '_PROPERTIES')) {
						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";
	}

	my $status = delete $case->{'_STATUS'} || $output->{'_STATUS'};
	my $line = delete $case->{'_LINE'};
	my %ENV_before = %ENV;
	my $cwd_before = Cwd::getcwd();
	my %cwd_files_before = map { $_ => 1 } do { opendir(my $dh, '.') or die $!; readdir($dh) };

	local $SIG{ALRM} = sub { die '__TIMEOUT__' };
	if((!defined($config{timeout})) || ($config{timeout} > 0)) {
		alarm($config{'timeout'} // 10);