App-Test-Generator
view release on metacpan or search on metacpan
bin/fuzz-harness-generator view on Meta::CPAN
# Purpose: Format a scalar input value as a Perl
# literal string suitable for embedding
# directly in generated test source code.
#
# Entry: $input - the input value to format.
# May be undef, a numeric string,
# or an arbitrary string.
#
# Exit: Returns a Perl literal string:
# 'undef' if $input is undef
# bare number if $input looks numeric
# single-quoted string otherwise, with
# backslashes and single quotes escaped.
#
# Side effects: None.
#
# Notes: Only scalar inputs are handled — corpus
# entries with arrayref or hashref inputs
# are not currently supported and will be
# formatted as a single-quoted string of
# the stringified reference, which will
doc/SchemaExtractor.pm view on Meta::CPAN
```bash
perl demo_extractor.pl
```
This creates a sample module, extracts schemas, and validates the results.
## How It Works
### 1. POD Analysis
The extractor looks for parameter documentation in POD:
```perl
=head2 validate_email($email)
=head3 INPUT
$email - string (5-254 chars), email address
Returns: 1 if valid
=cut
lib/App/Test/Generator.pm view on Meta::CPAN
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';
lib/App/Test/Generator.pm view on Meta::CPAN
}
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}};
}
lib/App/Test/Generator.pm view on Meta::CPAN
# 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);
lib/App/Test/Generator.pm view on Meta::CPAN
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
lib/App/Test/Generator.pm view on Meta::CPAN
$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'};
lib/App/Test/Generator.pm view on Meta::CPAN
# 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
lib/App/Test/Generator.pm view on Meta::CPAN
$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, {
lib/App/Test/Generator/Mutation/NumericBoundary.pm view on Meta::CPAN
# in the document copy it receives at test time
transform => sub {
my $doc = $_[0];
my $ops = $doc->find('PPI::Token::Operator') || [];
for my $op (@{$ops}) {
next unless $op->line_number == $line;
next unless $op->column_number == $col;
next unless $op->content eq $original;
# Safety check — do not mutate if this looks like
# a readline operator (<$fh>) rather than a numeric
# comparison. A readline < is immediately followed
# by a symbol token starting with $
my $next_sib = $op->next_sibling;
if($next_sib && $next_sib->isa('PPI::Token::Symbol')) {
last;
}
$op->set_content($change);
last;
lib/App/Test/Generator/SchemaExtractor.pm view on Meta::CPAN
use App::Test::Generator::Analyzer::ReturnMeta;
use App::Test::Generator::Analyzer::SideEffect;
use Carp qw(carp croak);
use PPI;
use Pod::Simple::Text;
use File::Basename;
use File::Path qw(make_path);
use Params::Get;
use Safe;
use Scalar::Util qw(looks_like_number);
use YAML::XS;
use IPC::Open3;
use JSON::MaybeXS qw(encode_json decode_json);
use Readonly;
use Symbol qw(gensym);
# --------------------------------------------------
# Confidence score thresholds for input and output analysis
# --------------------------------------------------
Readonly my $CONFIDENCE_HIGH_THRESHOLD => 60;
lib/App/Test/Generator/SchemaExtractor.pm view on Meta::CPAN
next unless $k && $v;
my $keyname = $k->content;
my $value = $v->can('content') ? $v->content : undef;
$value =~ s/^['"]|['"]$//g if defined $value;
if ($keyname eq 'type') {
$param{type} = lc($value);
} elsif ($keyname eq 'optional') {
$param{optional} = $value ? 1 : 0;
} elsif ($keyname =~ /^(min|max)$/ && looks_like_number($value)) {
$param{$keyname} = 0 + $value;
} elsif ($keyname eq 'matches') {
$param{matches} = qr/$value/;
}
}
$param{type} //= 'string';
$param{optional} //= 0;
$result{$key} = \%param;
lib/App/Test/Generator/SchemaExtractor.pm view on Meta::CPAN
# Positive
elsif ($constraint =~ /positive/i) {
$param->{min} = 1 if $param->{type} && $param->{type} eq 'integer';
$param->{min} = 0.01 if $param->{type} && $param->{type} eq 'number';
}
# Non-negative
elsif ($constraint =~ /non-negative/i) {
$param->{min} = 0;
} elsif($constraint =~ /(.+)?\s(.+)/) {
my ($op, $val) = ($1, $2);
if(looks_like_number($val)) {
if ($op eq '<') {
$param->{max} = $val - 1;
} elsif ($op eq '<=') {
$param->{max} = $val;
} elsif ($op eq '>') {
$param->{min} = $val + 1;
} elsif ($op eq '>=') {
$param->{min} = $val;
}
}
lib/App/Test/Generator/SchemaExtractor.pm view on Meta::CPAN
$p->{semantic} = 'filepath';
$self->_log(" ADVANCED: $param manipulated as file path");
return;
}
# Path validation patterns
# Only match a literal path assigned or defaulted to this variable
if(defined $p->{_default} && $p->{_default} =~ m{^([A-Za-z]:\\|/|\./|\.\./)}) {
$p->{type} = 'string';
$p->{semantic} = 'filepath';
$self->_log(" ADVANCED: $param default looks like a path");
return;
}
# IO::File detection
if ($code =~ /\$$param\s*->\s*isa\s*\(\s*['"]IO::File['"]\s*\)/ ||
$code =~ /IO::File\s*->\s*new\s*\(\s*\$$param/) {
$p->{type} = 'object';
$p->{isa} = 'IO::File';
$p->{semantic} = 'filehandle';
$self->_log(" ADVANCED: $param is IO::File object");
lib/App/Test/Generator/SchemaExtractor.pm view on Meta::CPAN
# $x :Type,
# $y = default
# ) { }
# Try to match signature after attributes
# Look for the parameter list - it's the last (...) before the opening brace
# that contains sigils ($, %, @)
if ($code =~ /sub\s+\w+\s*(?::\w+(?:\([^)]*\))?\s*)*\(((?:[^()]|\([^)]*\))*)\)\s*\{/s) {
my $potential_sig = $1;
# Check if this looks like parameters (has sigils)
if ($potential_sig =~ /[\$\%\@]/) {
$self->_log(" SIG: Found modern signature: ($potential_sig)");
$self->_parse_modern_signature($params, $potential_sig);
return;
}
}
# Traditional Style 1: my ($self, $arg1, $arg2) = @_;
if ($code =~ /my\s*\(\s*([^)]+)\)\s*=\s*\@_/s) {
my $sig = $1;
lib/App/Test/Generator/SchemaExtractor.pm view on Meta::CPAN
}
$self->_log(" CODE: $param length constraint $op $val");
}
# Numeric range checks (only if NOT part of error guard)
if (
!$guarded
&& $code =~ /\$$param\s*([<>]=?)\s*([+-]?(?:\d+\.?\d*|\.\d+))/
) {
my ($op, $val) = ($1, $2);
$p->{type} ||= looks_like_number($val) ? 'number' : 'integer';
if ($op eq '<' || $op eq '<=') {
# Only set max if it tightens the range
my $max = ($op eq '<') ? $val - 1 : $val;
$p->{max} = $max if !defined($p->{max}) || $max < $p->{max};
} elsif ($op eq '>' || $op eq '>=') {
my $min = ($op eq '>') ? $val + 1 : $val;
$p->{min} = $min if !defined($p->{min}) || $min > $p->{min};
}
}
lib/App/Test/Generator/SchemaExtractor.pm view on Meta::CPAN
}
# Extract default values with the new method
my $default_value = $self->_extract_default_value($param, $code);
if (defined $default_value && !exists $p->{_default}) {
$p->{optional} = 1;
$p->{_default} = $default_value;
# Try to infer type from default value if not already set
unless ($p->{type}) {
if (looks_like_number($default_value)) {
$p->{type} = $default_value =~ /\./ ? 'number' : 'integer';
} elsif (ref($default_value) eq 'ARRAY') {
$p->{type} = 'arrayref';
} elsif (ref($default_value) eq 'HASH') {
$p->{type} = 'hashref';
} elsif ($default_value eq 'undef') {
$p->{type} = 'scalar'; # undef can be any scalar
} elsif (defined $default_value && !ref($default_value)) {
$p->{type} = 'string';
}
lib/App/Test/Generator/Template.pm view on Meta::CPAN
if((!defined $spec->{min}) || ($spec->{min} <= 43.56)) {
push @cases, { %{$mandatory_args}, ( $arg_name => 43.56 ) };
}
[% IF module %]
# Send wrong data type - builtins aren't good at checking this
push @cases,
{ %{$mandatory_args}, ( $arg_name => "test string in float field $arg_name", _STATUS => 'DIES', _LINE => __LINE__ ) },
{ %{$mandatory_args}, ( $arg_name => {}, _STATUS => 'DIES', _LINE => __LINE__ ) },
{ %{$mandatory_args}, ( $arg_name => \42.1, _STATUS => 'DIES' ) }, # Scalar ref
# NaN and Inf are valid according to looks_like_number() so we
# cannot assume they die
# { %{$mandatory_args}, ( $arg_name => "NaN", _STATUS => 'DIES' ) },
{ %{$mandatory_args}, ( $arg_name => [], _STATUS => 'DIES', _LINE => __LINE__ ) };
[% END %]
# min/max numeric boundaries
if (defined $spec->{min}) {
my $min = $spec->{min};
push @cases,
{ %{$mandatory_args}, ( $arg_name => $min - 0.001, _STATUS => 'DIES' ) },
lib/App/Test/Generator/Template.pm view on Meta::CPAN
return $foundation;
}
[% IF use_properties %]
# ============================================================
# Property-Based Transform Tests (Test::LectroTest)
# ============================================================
use Test::LectroTest::Compat;
use Test::LectroTest::Generator qw(:common);
use Scalar::Util qw(looks_like_number);
diag('Run property-based transform tests') if($ENV{'TEST_VERBOSE'});
[% transform_properties_code %]
[% END %]
[% corpus_code %]
done_testing();
t/cli-extract-schemas.t view on Meta::CPAN
}
# --------------------------------------------------------------------
# --help
# --------------------------------------------------------------------
{
my ($exit, $out, $err) = run_cmd($script, '--help');
is($exit, 0, '--help exits cleanly');
like($out, qr/Usage:/i, '--help output looks correct' );
}
# --------------------------------------------------------------------
# Missing input file
# --------------------------------------------------------------------
{
my ($exit, $out, $err) = run_cmd($script);
isnt($exit, 0, 'missing input file exits non-zero');
t/cli-fuzz-harness-generator.t view on Meta::CPAN
my ($stdout, $stderr);
run3([$^X, @cmd], \undef, \$stdout, \$stderr);
my $exit = $? >> 8;
return ($exit, $stdout // '', $stderr // '');
}
# --help
{
my ($exit, $out, $err) = run_cmd($script, '--help');
is($exit, 0, '--help exits cleanly');
like($out, qr/Usage:/i, '--help output looks correct');
}
# --version
{
my ($exit, $out, $err) = run_cmd($script, '--version');
is($exit, 0, '--version exits cleanly');
like($out, qr/\d+\.\d+/, '--version prints version');
}
# --dry-run
t/generate.t view on Meta::CPAN
use open qw(:std :encoding(UTF-8));
my $conf_file = 't/conf/app_generator.yml';
ok(-e $conf_file, 'config file exists: $conf_file');
# Generate into a scalar
{
local *STDOUT;
open STDOUT, '>', \my $output;
App::Test::Generator->generate($conf_file);
like($output, qr/use Test::Most;/, 'output looks like a test file');
}
dies_ok { App::Test::Generator->generate() } 'Dies when not given an argument';
like $@, qr/^Usage: /;
done_testing();
t/schema_input.t view on Meta::CPAN
# Create a minimal test module to extract schema from
# ------------------------------------------------------------------
my $module = File::Spec->catfile($dir, 'TestSchema.pm');
open my $mod_fh, '>', $module or die $!;
print {$mod_fh} <<'EOF';
package TestSchema;
# This is the package that will be tested
use Scalar::Util qw(looks_like_number);
sub add {
if($_[0] && ($_[0] eq __PACKAGE__)) {
shift;
}
my ($a, $b) = @_;
die 'missing a' unless defined($a);
die 'not numeric' unless looks_like_number($a);
die 'not numeric' if defined($b) && !looks_like_number($b);
return $a + ($b // 0);
}
1;
EOF
close $mod_fh;
ok(-e $module, 'Test module created');
# ------------------------------------------------------------------
( run in 0.718 second using v1.01-cache-2.11-cpan-39bf76dae61 )