view release on metacpan or  search on metacpan

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

package App::Test::Generator;

# TODO: Test validator from Params::Validate::Strict 0.16
# TODO: $seed should be passed to Data::Random::String::Matches
# TODO: positional args - when config_undef is set, see what happens when not all args are given

use 5.036;

use strict;
use warnings;
use autodie qw(:all);

use utf8;
binmode STDOUT, ':utf8';
binmode STDERR, ':utf8';

use open qw(:std :encoding(UTF-8));

use App::Test::Generator::Template;
use Carp qw(carp croak);
use Config::Abstraction 0.36;
use Data::Dumper;
use Data::Section::Simple;
use File::Basename qw(basename);
use File::Spec;
use Module::Load::Conditional qw(check_install can_load);
use Params::Get;
use Params::Validate::Strict 0.30;
use Readonly;
use Readonly::Values::Boolean;
use Scalar::Util qw(looks_like_number);
use re 'regexp_pattern';
use Template;
use YAML::XS qw(LoadFile);

use Exporter 'import';

our @EXPORT_OK = qw(generate);

our $VERSION = '0.39';

use constant {
	DEFAULT_ITERATIONS => 30,
	DEFAULT_PROPERTY_TRIALS => 1000
};

use constant CONFIG_TYPES => ('test_nuls', 'test_undef', 'test_empty', 'test_non_ascii', 'dedup', 'properties', 'close_stdin', 'test_security', 'timeout');

# --------------------------------------------------
# Delimiter pairs tried in order when wrapping a
# string with q{} — bracket forms are preferred as
# they are most readable in generated test code
# --------------------------------------------------
Readonly my @Q_BRACKET_PAIRS => (
	['{', '}'],
	['(', ')'],
	['[', ']'],
	['<', '>'],
);

# --------------------------------------------------
# Single-character delimiters tried when no bracket
# pair is usable — each is tried in order and the
# first one not present in the string is used.
# The # character is last since it starts comments
# in many contexts and is least readable
# --------------------------------------------------
Readonly my @Q_SINGLE_DELIMITERS => (
	'~', '!', '%', '^', '=', '+', ':', ',', ';', '|', '/', '#'
);

# --------------------------------------------------
# Sentinel returned by index() when the search
# string is not found — used to make the >= 0
# boundary check self-documenting and to prevent

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

	my $vars = {
		setup_code => $setup_code,
		edge_cases_code => $edge_cases_code,
		edge_case_array_code => $edge_case_array_code,
		type_edge_cases_code => $type_edge_cases_code,
		config_code => $config_code,
		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.