view release on metacpan or  search on metacpan

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

		seed_code => $seed_code,
		input_code => $input_code,
		output_code => $output_code,
		transforms_code => $transforms_code,
		corpus_code => $corpus_code,
		call_code => $call_code,
		position_code => $position_code,
		determinism_code => $determinism_code,
		function => $function,
		iterations_code => int($iterations),
		use_properties => $use_properties,
		transform_properties_code => $transform_properties_code,
		property_trials => $config{properties}{trials} // DEFAULT_PROPERTY_TRIALS,
		relationships_code => $relationships_code,
		module => $module
	};

	my $test;
	$tt->process($template, $vars, \$test) or croak($tt->error());

	if ($test_file) {
		open my $fh, '>:encoding(UTF-8)', $test_file or croak "Cannot open $test_file: $!";
		print $fh "$test\n";
		close $fh;
		if($module) {
			print "Generated $test_file for $module\::$function with fuzzing + corpus support\n";
		} else {
			print "Generated $test_file for $function with fuzzing + corpus support\n";
		}
	} else {
		print "$test\n";
	}
}

# --- Helpers for rendering data structures into Perl code for the generated test ---

# --------------------------------------------------
# _is_perl_builtin
#
# Purpose:    Return true if a string is the name of
#             a Perl core builtin function, to prevent
#             it being used as a module name in
#             use_ok() calls in generated tests.
#
# Entry:      $name - the string to check.
# Exit:       Returns 1 if builtin, 0 otherwise.
# Side effects: None.
# --------------------------------------------------
sub _is_perl_builtin {
	my $name = $_[0];
	return 0 unless defined $name;

	state %BUILTINS = map { $_ => 1 } qw(
		abs accept alarm atan2 bind binmode bless
		caller chdir chmod chomp chop chown chr chroot
		close closedir connect cos crypt
		dbmclose dbmopen defined delete die do dump
		each endgrent endhostent endnetent endprotoent endpwent endservent
		eof eval exec exists exit exp
		fcntl fileno flock fork format formline
		getc getgrent getgrgid getgrnam gethostbyaddr gethostbyname
		gethostent getlogin getnetbyaddr getnetbyname getnetent
		getpeername getpgrp getppid getpriority getprotobyname
		getprotobynumber getprotoent getpwent getpwnam getpwuid
		getservbyname getservbyport getservent getsockname getsockopt
		glob gmtime goto grep
		hex
		index int ioctl
		join
		keys kill
		last lc lcfirst length link listen local localtime log lstat
		map mkdir msgctl msgget msgrcv msgsnd my
		next no
		oct open opendir ord our
		pack pipe pop pos print printf prototype push
		quotemeta
		rand read readdir readline readlink readpipe recv redo
		ref rename require reset return reverse rewinddir rindex rmdir
		say scalar seek seekdir select semctl semget semop send
		setgrent sethostent setnetent setpgrp setpriority setprotoent
		setpwent setservent setsockopt shift shmctl shmget shmread
		shmwrite shutdown sin sleep socket socketpair sort splice split
		sprintf sqrt srand stat study sub substr symlink syscall
		sysopen sysread sysseek system syswrite
		tell telldir tie tied time times truncate
		uc ucfirst umask undef unlink unpack unshift untie use
		utime values vec wait waitpid wantarray warn write
	);
	return $BUILTINS{lc $name} // 0;
}

# --------------------------------------------------
# _load_schema
#
# Load and parse a schema file using
#     Config::Abstraction, returning the
#     schema as a hashref.
#
# Entry:      $schema_file - path to the schema file.
#             Must be defined, non-empty, and readable.
#
# Exit:       Returns a hashref of the parsed schema
#             with a '_source' key added containing
#             the originating file path.
#             Croaks on any error.
#
# Side effects: Reads from the filesystem.
#
# Notes:      Legacy Perl-file configs (containing
#             '$module' or 'our $module' keys) are
#             rejected with a clear error. Config::
#             Abstraction is used rather than require()
#             to avoid executing arbitrary code from
#             user-supplied config files.
# --------------------------------------------------
sub _load_schema {
	my $schema_file = $_[0];

	# Validate the argument before touching the filesystem
	croak(__PACKAGE__, ': Usage: _load_schema($schema_file)') unless defined $schema_file;