App-Test-Generator
view release on metacpan or search on metacpan
lib/App/Test/Generator.pm view on Meta::CPAN
$corpus_code .= "dies_ok { \$obj->$function($input_str) } " .
"'$function(" . join(', ', map { $_ // '' } @$inputs ) . ") dies';\n";
} elsif($status eq 'WARNS') {
$corpus_code .= "warnings_exist { \$obj->$function($input_str) } qr/./, " .
"'$function(" . join(', ', map { $_ // '' } @$inputs ) . ") warns';\n";
} else {
my $desc = sprintf("$function(%s) returns %s",
perl_quote(join(', ', map { $_ // '' } @$inputs )),
$expected_str
);
if(($output{'type'} // '') eq 'boolean') {
if($expected_str eq '1') {
$corpus_code .= "ok(\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
} elsif($expected_str eq '0') {
$corpus_code .= "ok(!\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
} else {
croak("Boolean is expected to return $expected_str");
}
} else {
$corpus_code .= "is(\$obj->$function($input_str), $expected_str, " . q_wrap($desc) . ");\n";
}
}
} else {
if($status eq 'DIES') {
if($module) {
$corpus_code .= "dies_ok { $module\::$function($input_str) } " .
"'Corpus $expected dies';\n";
} else {
$corpus_code .= "dies_ok { $function($input_str) } " .
"'Corpus $expected dies';\n";
}
} elsif($status eq 'WARNS') {
if($module) {
$corpus_code .= "warnings_exist { $module\::$function($input_str) } qr/./, " .
"'Corpus $expected warns';\n";
} else {
$corpus_code .= "warnings_exist { $function($input_str) } qr/./, " .
"'Corpus $expected warns';\n";
}
} else {
my $desc = sprintf("$function(%s) returns %s",
perl_quote((ref $inputs eq 'ARRAY') ? (join(', ', map { $_ // '' } @{$inputs})) : $inputs),
$expected_str
);
if(($output{'type'} // '') eq 'boolean') {
if($expected_str eq '1') {
$corpus_code .= "ok(\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
} elsif($expected_str eq '0') {
$corpus_code .= "ok(!\$obj->$function($input_str), " . q_wrap($desc) . ");\n";
} else {
croak("Boolean is expected to return $expected_str");
}
} else {
$corpus_code .= "is(\$obj->$function($input_str), $expected_str, " . q_wrap($desc) . ");\n";
}
}
}
}
}
# Prepare seed/iterations code fragment for the generated test
my $seed_code = '';
if (defined $seed) {
# ensure integer-ish
$seed = int($seed);
$seed_code = "srand($seed);\n";
}
my $determinism_code = 'my $result2;' .
'eval { $result2 = do { ' . (defined($position_code) ? $position_code : $call_code) . " }; };\n" .
'is_deeply($result2, $result, "deterministic result for same input");' .
"\n";
# Generate the test content
my $tt = Template->new({ ENCODING => 'utf8', TRIM => 1 });
# Read template from DATA handle
my $template_package = __PACKAGE__ . '::Template';
my $template = $template_package->get_data_section('test.tt');
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) {
# autodie is disabled for this open -- under "use autodie qw(:all)"
# open() never returns false on failure, it throws its own exception
# instead, which would silently make the "or croak" dead code.
no autodie qw(open);
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";
lib/App/Test/Generator.pm view on Meta::CPAN
Render a flat hashref into a Perl source-code argument list of the
form C<'key' => value, ...>, suitable for embedding in a function call
in a generated test file.
my $code = render_args_hash({ type => 'string', min => 1 });
# returns: "'min' => 1, 'type' => 'string'"
=head3 Arguments
=over 4
=item * C<$href>
A flat hashref of key-value pairs. Values may be scalars, arrayrefs,
or Regexp objects — all are handled by C<perl_quote>.
=back
=head3 Returns
A comma-separated string of C<key => value> pairs sorted by key.
Returns an empty string if C<$href> is undef, empty, or not a hashref.
=head3 Notes
Keys and values are both rendered via C<perl_quote>. In particular,
C<Regexp> values are rendered as C<qr{...}> which is correct for
L<Params::Validate::Strict> and L<Return::Set> schema arguments in
the generated test.
=head3 API specification
=head4 input
{ href => { type => 'any', optional => 1 } }
=head4 output
{ type => 'string' }
=cut
sub render_args_hash {
my $href = $_[0];
# Return empty string for absent or non-hash input
return '' unless $href && ref($href) eq 'HASH';
# Sort keys for deterministic output across runs — important for
# generated test files that are committed to version control
my @pairs = map {
perl_quote($_) . ' => ' . perl_quote($href->{$_})
} sort keys %{$href};
return join(', ', @pairs);
}
=head2 render_arrayref_map
Render a hashref whose values are arrayrefs into a Perl source-code
fragment suitable for use as a hash literal in a generated test file.
my $code = render_arrayref_map({ name => ['', 'a' x 100] });
=head3 Arguments
=over 4
=item * C<$href>
A hashref whose values are arrayrefs. Keys whose values are not
arrayrefs are silently skipped.
=back
=head3 Returns
A comma-separated string of C<'key' => [ val, ... ]> entries, one per
qualifying key, sorted alphabetically. Returns the string C<'()'> if
C<$href> is undef, empty, or not a hashref — this produces an empty
hash assignment in the generated test rather than a syntax error.
=head3 Notes
Array element values are rendered via C<perl_quote> which handles
scalars, arrayrefs, and Regexp objects. Non-arrayref values are
skipped without warning — this is intentional since callers may pass
mixed-value hashes and only want the arrayref entries rendered.
=head3 API specification
=head4 input
{ href => { type => 'any', optional => 1 } }
=head4 output
{ type => 'string' }
=cut
sub render_arrayref_map {
my $href = $_[0];
# Return '()' rather than '' so callers get a valid empty hash
# literal rather than a syntax error in the generated test
return '()' unless $href && ref($href) eq 'HASH';
my @entries;
for my $k (sort keys %{$href}) {
my $aref = $href->{$k};
# Skip non-arrayref values — mixed hashes are allowed by callers
next unless ref($aref) eq 'ARRAY';
# Render each array element via perl_quote so strings are
# properly quoted and numbers are left unquoted
my $vals = join(', ', map { perl_quote($_) } @{$aref});
# Use "\t" rather than a literal tab for clarity
push @entries, "\t" . perl_quote($k) . " => [ $vals ]";
}
return join(",\n", @entries);
}
# --------------------------------------------------
# _has_positions
#
# Purpose: Determine whether any field in an input
# spec hashref declares a positional argument
# via the 'position' key.
#
# Entry: $input_spec - the input section of a parsed
# schema, expected to be a hashref whose values
# are themselves hashrefs containing field specs.
# May be undef or a non-hash ref.
#
# Exit: Returns 1 if any field has a defined
# 'position' key, 0 otherwise.
#
# Notes: Returns 0 immediately for undef or non-hash
# input rather than throwing — callers use the
# return value as a boolean and do not expect
# exceptions from this function.
# --------------------------------------------------
sub _has_positions {
my $input_spec = $_[0];
# Guard against undef or non-hash input — keys %$undef would throw
return 0 unless defined($input_spec) && ref($input_spec) eq 'HASH';
for my $field (keys %{$input_spec}) {
# Only examine fields whose spec is a hashref — scalar specs
# (e.g. input: { type: string }) cannot have positions
next unless ref($input_spec->{$field}) eq 'HASH';
# Return immediately on first match — no need to scan further
return 1 if defined $input_spec->{$field}{position};
}
# No positional arguments found in any field
return 0;
}
# --------------------------------------------------
# q_wrap
#
# Purpose: Wrap a string in the most readable
# q{} form that does not require escaping,
# falling back to single-quoted form with
# escaped apostrophes if no delimiter is
# available.
#
# Entry: $s - the string to wrap. May be undef.
# Exit: Returns a Perl source-code fragment that
# evaluates to the original string value,
# or the string 'undef' if $s is undef.
#
# Notes: index() returns -1 when not found and
# any value >= 0 when found, including 0
# for a delimiter at the start of the
# string. We compare against $INDEX_NOT_FOUND
# to make this boundary explicit and to
# prevent off-by-one mutation survivors.
# See GitHub issue #1.
# --------------------------------------------------
sub q_wrap {
my $s = $_[0];
croak('q_wrap: argument must be a plain string, not a reference') if ref($s);
# Return empty string for undef — this function is a low-level
# string quoter only. Callers that need the Perl literal 'undef'
# for undefined values should use perl_quote() instead, which
# handles the undef -> 'undef' semantic conversion correctly.
# Returning '' here preserves the original behaviour and avoids
# injecting the bare word 'undef' into contexts that expect a
# quoted string value.
return "''" unless defined $s;
# Try bracket-form q{} delimiters first — most readable
for my $p (@Q_BRACKET_PAIRS) {
my ($l, $r) = @{$p};
# Only use this bracket pair if neither bracket
# appears in the string — both must be checked
return "q$l$s$r" unless $s =~ /\Q$l\E|\Q$r\E/;
}
# Try single-character delimiters in preference order
for my $d (@Q_SINGLE_DELIMITERS) {
# index() returns $INDEX_NOT_FOUND (-1) when not found.
# Must use != $INDEX_NOT_FOUND rather than > 0 since
# the delimiter may legitimately appear at position 0
return "q$d$s$d" if index($s, $d) == $INDEX_NOT_FOUND;
}
# Last resort — single-quoted string with escaped apostrophes
(my $esc = $s) =~ s/'/\\'/g;
return "'$esc'";
}
# --------------------------------------------------
# perl_sq
#
# Purpose: Escape a string for safe inclusion
# inside a single-quoted Perl string
# literal in generated test code.
#
# Entry: $s - the string to escape.
# Exit: Returns the escaped string, or an
# empty string if $s is undef.
#
# Notes: NUL byte replacement produces the
# two-character sequence \0 which is
# only correct when the result is used
# inside a double-quoted string context
# in the generated test.
#
# The \b substitution (backspace) is
# intentionally omitted — in Perl regex
# context \b means word boundary, not
# backspace, so substituting it here
# would corrupt strings containing word
# boundaries.
# --------------------------------------------------
sub perl_sq {
my $s = $_[0];
croak('perl_sq: argument must be a plain string, not a reference') if ref($s);
# Return empty string for undef — callers that need
# 'undef' literal should use perl_quote instead
return '' unless defined $s;
# Escape backslashes first so later substitutions
# don't double-escape already-escaped sequences
$s =~ s/\\/\\\\/g;
# Escape apostrophes so they don't terminate the
# surrounding single-quoted string literal
$s =~ s/'/\\'/g;
# Escape common control characters to their
# printable two-character escape sequences
$s =~ s/\n/\\n/g;
$s =~ s/\r/\\r/g;
$s =~ s/\t/\\t/g;
$s =~ s/\f/\\f/g;
# Replace NUL bytes with \0 — valid only in
# double-quoted string context in generated code
$s =~ s/\0/\\0/g;
return $s;
}
=head2 perl_quote
Convert any Perl value into a source-code fragment that reproduces that value
when evaluated in a generated test file.
=head3 Arguments
=over 4
=item * C<$v>
Any Perl value. May be undef, a scalar, an arrayref, a Regexp, or a blessed
object. All types are handled — undef becomes C<'undef'>, the strings
C<'true'>/C<'false'> become the Perl boolean constants C<!!1>/C<!!0>,
numbers are unquoted, other strings are single-quoted, arrayrefs recurse,
Regexps become C<qr{...}>, and anything else (including hashrefs and
blessed objects) falls through to C<render_fallback>.
=back
=head3 API specification
=head4 input
{ v => { type => 'any', optional => 1 } }
=head4 output
{ type => 'string' }
=cut
sub perl_quote {
my ($v) = @_;
return _perl_quote($v, 0);
}
sub _perl_quote {
my ($v, $depth) = @_;
no warnings 'recursion'; ## no critic (TestingAndDebugging::ProhibitNoWarnings)
croak('perl_quote: structure too deeply nested (circular reference?)') if $depth > 100;
# 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($_, $depth + 1) } @{$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
( run in 1.088 second using v1.01-cache-2.11-cpan-b16cb0d3907 )