App-Test-Generator
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.33';
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');
# --------------------------------------------------
# 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
# NumericBoundary mutants from surviving
# --------------------------------------------------
Readonly my $INDEX_NOT_FOUND => -1;
# --------------------------------------------------
# Readonly constants for schema validation
# --------------------------------------------------
Readonly my $CONFIG_PROPERTIES_KEY => 'properties';
Readonly my $LEGACY_PERL_KEY_1 => '$module';
Readonly my $LEGACY_PERL_KEY_2 => 'our $module';
Readonly my $SOURCE_KEY => '_source';
# --------------------------------------------------
# Readonly constants for render_hash key detection
# --------------------------------------------------
Readonly my $KEY_MATCHES => 'matches';
lib/App/Test/Generator.pm view on Meta::CPAN
if($schema_file) {
($module = basename($schema_file)) =~ s/\.(conf|pl|pm|yml|yaml)$//;
$module =~ s/-/::/g;
}
} elsif($module eq 'builtin') {
undef $module;
}
if($module && length($module) && ($module ne 'builtin')) {
_validate_module($module, $schema_file);
}
# sensible defaults
$function ||= 'run';
$iterations ||= DEFAULT_ITERATIONS; # default fuzz runs if not specified
$seed = undef if defined $seed && $seed eq ''; # treat empty as undef
# --- YAML corpus support (yaml_cases is filename string) ---
my %yaml_corpus_data;
if (defined $yaml_cases) {
croak("$yaml_cases: $!") if(!-f $yaml_cases);
my $yaml_data = LoadFile(Encode::decode('utf8', $yaml_cases));
if ($yaml_data && ref($yaml_data) eq 'HASH') {
# Validate that the corpus inputs are arrayrefs
# e.g: "FooBar": ["foo_bar"]
# Skip only invalid entries:
for my $expected (keys %{$yaml_data}) {
my $outputs = $yaml_data->{$expected};
unless($outputs && (ref $outputs eq 'ARRAY')) {
carp("$yaml_cases: $expected does not point to an array ref, ignoring");
next;
}
$yaml_corpus_data{$expected} = $outputs;
}
}
}
# Merge Perl %cases and YAML corpus safely
# my %all_cases = (%cases, %yaml_corpus_data);
my %all_cases = (%yaml_corpus_data, %cases);
for my $k (keys %yaml_corpus_data) {
if (exists $cases{$k} && ref($cases{$k}) eq 'ARRAY' && ref($yaml_corpus_data{$k}) eq 'ARRAY') {
$all_cases{$k} = [ @{$yaml_corpus_data{$k}}, @{$cases{$k}} ];
}
}
if(my $hints = delete $schema->{_yamltest_hints}) {
if(my $boundaries = $hints->{boundary_values}) {
push @edge_case_array, @{$boundaries};
}
if(my $invalid = $hints->{invalid}) {
carp('TODO: handle yamltest_hints->invalid');
}
}
# If the schema says the type is numeric, normalize
if ($schema->{type} && $schema->{type} =~ /^(integer|number|float)$/) {
for (@edge_case_array) {
next unless defined $_;
$_ += 0 if Scalar::Util::looks_like_number($_);
}
}
# Load relationships from the schema if present and well-formed.
# SchemaExtractor may set this to undef or an empty arrayref when
# no relationships were detected, so guard both existence and type.
my @relationships;
if(exists($schema->{relationships}) && ref($schema->{relationships}) eq 'ARRAY') {
@relationships = @{$schema->{relationships}};
}
# Serialise the relationships array from the schema into Perl source
# code for embedding in the generated test file. Each relationship
# type is rendered as a hashref in the @relationships array.
my $relationships_code = '';
# Walk each relationship in the order SchemaExtractor produced them
for my $rel (@relationships) {
my $type = $rel->{type} // '';
# Mutually exclusive: both params being set should cause the method to die
if($type eq 'mutually_exclusive') {
$relationships_code .= "{ type => 'mutually_exclusive', params => [" .
join(', ', map { perl_quote($_) } @{$rel->{params}}) .
"] },\n";
# Required group: at least one of the params must be present
} elsif($type eq 'required_group') {
$relationships_code .= "{ type => 'required_group', params => [" .
join(', ', map { perl_quote($_) } @{$rel->{params}}) .
"], logic => " . perl_quote($rel->{logic} // 'or') . " },\n";
# Conditional requirement: if one param is set, another becomes mandatory
} elsif($type eq 'conditional_requirement') {
$relationships_code .= "{ type => 'conditional_requirement', if => " .
perl_quote($rel->{'if'}) . ", then_required => " .
perl_quote($rel->{then_required}) . " },\n";
# Dependency: one param requires another to also be present
} elsif($type eq 'dependency') {
$relationships_code .= "{ type => 'dependency', param => " .
perl_quote($rel->{param}) . ", requires => " .
perl_quote($rel->{requires}) . " },\n";
# Value constraint: one param being set forces another to a specific value
} elsif($type eq 'value_constraint') {
$relationships_code .= "{ type => 'value_constraint', if => " .
perl_quote($rel->{'if'}) . ", then => " .
perl_quote($rel->{then}) . ", operator => " .
perl_quote($rel->{operator}) . ", value => " .
perl_quote($rel->{value}) . " },\n";
# Value conditional: one param equalling a specific value requires another param
} elsif($type eq 'value_conditional') {
$relationships_code .= "{ type => 'value_conditional', if => " .
perl_quote($rel->{'if'}) . ", equals => " .
perl_quote($rel->{equals}) . ", then_required => " .
perl_quote($rel->{then_required}) . " },\n";
# Unknown type — warn and skip rather than emitting broken code
} else {
carp "Unknown relationship type '$type', skipping";
}
}
# Dedup the edge cases
my %seen;
@edge_case_array = grep {
my $key = defined($_) ? (Scalar::Util::looks_like_number($_) ? "N:$_" : "S:$_") : 'U';
!$seen{$key}++;
} @edge_case_array;
# Sort the edge cases to keep it consistent across runs
@edge_case_array = sort {
return -1 if !defined $a;
return 1 if !defined $b;
my $na = Scalar::Util::looks_like_number($a);
my $nb = Scalar::Util::looks_like_number($b);
return $a <=> $b if $na && $nb;
return -1 if $na;
return 1 if $nb;
return $a cmp $b;
} @edge_case_array;
# render edge case maps for inclusion in the .t
my $edge_cases_code = render_arrayref_map(\%edge_cases);
my $type_edge_cases_code = render_arrayref_map(\%type_edge_cases);
my $edge_case_array_code = '';
if(scalar(@edge_case_array)) {
$edge_case_array_code = join(', ', map { q_wrap($_) } @edge_case_array);
}
# Render configuration - all the values are integers for now, if that changes, wrap the $config{$key} in single quotes
my $config_code = '';
foreach my $key (sort keys %config) {
# Skip nested structures like 'properties' - they're used during
# generation but don't need to be in the generated test
if(ref($config{$key}) eq 'HASH') {
next;
}
if((!defined($config{$key})) || !$config{$key}) {
# YAML will strip the word 'false'
# e.g. in 'test_undef: false'
$config_code .= "'$key' => 0,\n";
} else {
$config_code .= "'$key' => $config{$key},\n";
}
}
# Render input/output
my $input_code = '';
if(((scalar keys %input) == 1) && exists($input{'type'}) && !ref($input{'type'})) {
# %input = ( type => 'string' );
foreach my $key (sort keys %input) {
$input_code .= "'$key' => '$input{$key}',\n";
}
} else {
# %input = ( str => { type => 'string' } );
$input_code = render_hash(\%input);
}
if(defined(my $re = $output{'matches'})) {
if(ref($re) ne 'Regexp') {
# Use eval to compile safely — qr/$re/ would interpolate
# the string first, corrupting patterns containing [ or \
my $compiled = eval { qr/$re/ };
if($@) {
carp("Invalid matches pattern '$re': $@");
} else {
$output{'matches'} = $compiled;
}
}
}
# Compile nomatch pattern to a Regexp object so it renders
# as qr{} in the generated test rather than a raw string.
# Without this, patterns containing [ or other regex
lib/App/Test/Generator.pm view on Meta::CPAN
#
# Purpose: Convert a Perl value into a source-code
# fragment that reproduces that value when
# evaluated in a generated test file.
#
# Entry: $v - the value to quote. May be undef,
# a scalar, an arrayref, a Regexp, or any
# other reference type.
#
# Exit: Returns a string of Perl source code.
# Undef produces the literal 'undef'.
# Numbers are returned unquoted.
# Strings are returned single-quoted via
# perl_sq(). Arrays are recursively quoted.
# Regexps are rendered as qr{...}.
# Other refs fall through to render_fallback.
#
# Side effects: None.
#
# Notes: The boolean string literals 'true' and
# 'false' are converted to Perl boolean
# constants !!1 and !!0 respectively so
# that YAML boolean values round-trip
# correctly into generated tests.
# --------------------------------------------------
sub perl_quote {
my $v = $_[0];
# Undef produces the Perl literal 'undef'
return 'undef' unless defined $v;
# Convert YAML boolean string literals to Perl
# boolean constants so they survive round-tripping
return '!!1' if $v eq 'true';
return '!!0' if $v eq 'false';
if(ref($v)) {
# Recursively quote each element of an arrayref
if(ref($v) eq 'ARRAY') {
my @quoted_v = map { perl_quote($_) } @{$v};
return '[ ' . join(', ', @quoted_v) . ' ]';
}
# Render Regexp objects as qr{} with modifiers
if(ref($v) eq 'Regexp') {
my ($pat, $mods) = regexp_pattern($v);
my $re = "qr{$pat}";
# Append modifiers (e.g. 'i', 'x') if present
$re .= $mods if $mods;
return $re;
}
# Hashrefs and other reference types fall through
# to render_fallback which uses Data::Dumper
return render_fallback($v);
}
# Numeric values are emitted unquoted so the generated
# test performs numeric rather than string comparison
return looks_like_number($v) ? $v : "'" . perl_sq($v) . "'";
}
# --------------------------------------------------
# _generate_transform_properties
#
# Convert a hashref of transform
# specifications into an arrayref of
# LectroTest property definition hashrefs,
# one per transform. Each hashref contains
# all the information needed by
# _render_properties to emit a runnable
# Test::LectroTest property block.
#
# Entry: $transforms - hashref of transform name
# => transform spec, as
# loaded from the schema.
# $function - name of the function under
# test.
# $module - module name, or undef for
# builtin functions.
# $input - the top-level input spec
# hashref from the schema
# (used for position sorting).
# $config - the normalised config
# hashref, used to read
# properties.trials.
# $new - defined if the function is
# an object method; the value
# is not used here since
# property tests always
# construct a fresh object
# via new_ok() with no args.
# Presence vs absence is the
# only signal used.
#
# Exit: Returns an arrayref of property hashrefs.
# Returns an empty arrayref if no transforms
# produce any testable properties.
# Never returns undef.
#
# Side effects: None. Does not modify any argument.
#
# Notes: Transforms whose input is the string
# 'undef' or whose input spec is not a
# hashref are silently skipped — they
# represent error-case transforms that have
# no meaningful generator.
#
# The 'WARN' vs 'WARNS' distinction in
# _STATUS: the schema convention uses
# 'WARNS' throughout. This function checks
# for 'WARNS' to match that convention.
# --------------------------------------------------
sub _generate_transform_properties {
my ($transforms, $function, $module, $input, $config, $new) = @_;
my @properties;
for my $transform_name (sort keys %{$transforms}) {
my $transform = $transforms->{$transform_name};
lib/App/Test/Generator.pm view on Meta::CPAN
return $code;
}
# --------------------------------------------------
# _detect_transform_properties
#
# Purpose: Automatically derive a list of testable
# LectroTest property hashrefs from a
# transform's input and output specs.
# Detects numeric range constraints, exact
# value matches, string length constraints,
# type preservation, and definedness.
#
# Entry: $transform_name - string name of the
# transform, used for
# heuristic matching
# (e.g. 'positive').
# $input_spec - the transform's input
# hashref, or the string
# 'undef'.
# $output_spec - the transform's output
# hashref, or undef if
# absent.
#
# Exit: Returns a list of property hashrefs,
# each containing 'name' and 'code' keys.
# Returns an empty list if no properties
# can be detected or if $input_spec is
# undef or the string 'undef'.
#
# Side effects: None.
#
# Notes: The 'positive' heuristic checks the
# transform name case-insensitively against
# $TRANSFORM_POSITIVE_PATTERN and adds a
# non-negative constraint if matched.
# This is intentionally a rough heuristic
# rather than a precise semantic check.
# --------------------------------------------------
sub _detect_transform_properties {
my ($transform_name, $input_spec, $output_spec) = @_;
my @properties;
# Guard: skip undef input and the YAML scalar 'undef'
return @properties unless defined($input_spec);
return @properties if(!ref($input_spec) && $input_spec eq 'undef');
# Default output spec to empty hash so all key lookups
# below are safe regardless of what the schema provides
$output_spec //= {};
# --------------------------------------------------
# Property 1: Output range constraints (numeric)
# --------------------------------------------------
if(_is_numeric_transform($input_spec, $output_spec)) {
if(defined($output_spec->{'min'})) {
my $min = $output_spec->{'min'};
push @properties, {
name => 'min_constraint',
code => "defined(\$result) && looks_like_number(\$result) && \$result >= $min",
};
}
if(defined($output_spec->{'max'})) {
my $max = $output_spec->{'max'};
push @properties, {
name => 'max_constraint',
code => "defined(\$result) && looks_like_number(\$result) && \$result <= $max",
};
}
# Heuristic: transforms named 'positive' (case-insensitive)
# imply a non-negative result constraint
if($transform_name =~ /$TRANSFORM_POSITIVE_PATTERN/i) {
push @properties, {
name => 'non_negative',
code => "defined(\$result) && looks_like_number(\$result) && \$result >= 0",
};
}
}
# --------------------------------------------------
# Property 2: Specific value output
# --------------------------------------------------
if(defined($output_spec->{'value'})) {
my $expected = $output_spec->{'value'};
# Numeric refs use == for comparison; scalars use eq
# via perl_quote to produce the correct quoted literal
push @properties, {
name => 'exact_value',
code => ref($expected)
? "\$result == $expected"
: "\$result eq " . perl_quote($expected),
};
}
# --------------------------------------------------
# Property 3: String length constraints
# --------------------------------------------------
if(_is_string_transform($input_spec, $output_spec)) {
if(defined($output_spec->{'min'})) {
push @properties, {
name => 'min_length',
code => "length(\$result) >= $output_spec->{'min'}",
};
}
if(defined($output_spec->{'max'})) {
push @properties, {
name => 'max_length',
code => "length(\$result) <= $output_spec->{'max'}",
};
}
if(defined($output_spec->{'matches'})) {
my $pattern = $output_spec->{'matches'};
push @properties, {
name => 'pattern_match',
code => "\$result =~ qr/$pattern/",
};
}
}
# --------------------------------------------------
# Property 4: Type preservation
# --------------------------------------------------
if(_same_type($input_spec, $output_spec)) {
my $type = _get_dominant_type($output_spec);
# Only emit a numeric_type check for numeric types —
# string and other types have no equivalent simple check
if($type eq 'number' || $type eq 'integer' || $type eq 'float') {
push @properties, {
name => 'numeric_type',
code => 'looks_like_number($result)',
};
}
}
# --------------------------------------------------
# Property 5: Definedness
# --------------------------------------------------
# Emit a defined() check for all transforms except those
# whose output type is explicitly 'undef' — those are
# expected to return nothing
unless(($output_spec->{'type'} // '') eq 'undef') {
push @properties, {
name => 'defined',
code => 'defined($result)',
};
}
return @properties;
}
# --------------------------------------------------
# _process_custom_properties
#
# Purpose: Process the 'properties' array from a
# transform definition, resolving each
# entry to either a named builtin property
# (looked up from _get_builtin_properties)
# or a custom property with inline code.
#
# Entry: $properties_spec - arrayref of property
# definitions from the
# schema. Each element
# is either a string
# (builtin name) or a
# hashref with 'name'
# and 'code' fields.
# $function - name of the function
# under test.
# $module - module name, or undef
# for builtins.
# $input_spec - the transform's input
# spec hashref.
# $output_spec - the transform's output
# spec hashref.
# $new - defined if the function
# is an OO method; value
# is not used, only
# presence is checked.
#
# Exit: Returns a list of property hashrefs,
# each containing 'name', 'code', and
# 'description' keys.
# Invalid or unrecognised entries are
# skipped with a carp warning.
#
# Side effects: Carps on unrecognised builtin names,
# missing code fields, and invalid
# property definition types.
#
# Notes: The sixth argument is $new (the OO
lib/App/Test/Generator.pm view on Meta::CPAN
my $prop_code;
my $prop_desc;
if(!ref($prop_def)) {
# Plain string — look up as a named builtin property
$prop_name = $prop_def;
unless(exists($builtin_properties->{$prop_name})) {
carp "Unknown built-in property '$prop_name', skipping";
next;
}
my $builtin = $builtin_properties->{$prop_name};
# Build the argument list, respecting positional order
my @var_names = sort keys %{$input_spec};
my @args;
if(_has_positions($input_spec)) {
my @sorted = sort { $input_spec->{$a}{'position'} <=> $input_spec->{$b}{'position'} } @var_names;
@args = map { "\$$_" } @sorted;
} else {
@args = map { "\$$_" } @var_names;
}
# Build the call expression for the builtin template.
# $new here is the raw OO signal from the caller —
# defined means OO mode, undef means functional
my $call_code;
if($module && defined($new)) {
# OO mode — fresh object per trial
$call_code = "my \$obj = new_ok('$module');";
$call_code .= "\$obj->$function";
} elsif($module && $module ne $MODULE_BUILTIN) {
# Functional mode with a named module
$call_code = "$module\::$function";
} else {
# Builtin or unqualified function call
$call_code = $function;
}
$call_code .= '(' . join(', ', @args) . ')';
# Instantiate the builtin's code template with the
# call expression and input variable list
$prop_code = $builtin->{'code_template'}->($function, $call_code, \@var_names);
$prop_desc = $builtin->{'description'};
} elsif(ref($prop_def) eq 'HASH') {
# Hashref — custom property with inline Perl code
$prop_name = $prop_def->{'name'} || 'custom_property';
$prop_code = $prop_def->{'code'};
$prop_desc = $prop_def->{'description'} || "Custom property: $prop_name";
unless($prop_code) {
carp "Custom property '$prop_name' missing 'code' field, skipping";
next;
}
# Sanity-check: code must contain at least a variable
# reference or a word character to be meaningful
unless($prop_code =~ /\$/ || $prop_code =~ /\w+/) {
carp "Custom property '$prop_name' code looks invalid: $prop_code";
next;
}
} else {
# Neither string nor hashref — unrecognised definition type
carp 'Invalid property definition: ', render_fallback($prop_def);
next;
}
push @properties, {
name => $prop_name,
code => $prop_code,
description => $prop_desc,
};
}
return @properties;
}
=head1 NOTES
C<seed> and C<iterations> really should be within C<config>.
=head1 SEE ALSO
=over 4
=item * L<Test Coverage Report|https://nigelhorne.github.io/App-Test-Generator/coverage/>
=item * L<App::Test::Generator::Template> - Template of the file of tests created by C<App::Test::Generator>
=item * L<App::Test::Generator::SchemaExtractor> - Create schemas from Perl programs
=item * L<Params::Validate::Strict>: Schema Definition
=item * L<Params::Get>: Input validation
=item * L<Return::Set>: Output validation
=item * L<Test::LectroTest>
=item * L<Test::Most>
=item * L<YAML::XS>
=back
=head1 AUTHOR
Nigel Horne, C<< <njh at nigelhorne.com> >>
Portions of this module's initial design and documentation were created with the
assistance of AI.
=head1 SUPPORT
This module is provided as-is without any warranty.
You can find documentation for this module with the perldoc command.
( run in 0.519 second using v1.01-cache-2.11-cpan-39bf76dae61 )