App-Test-Generator
view release on metacpan or search on metacpan
t/Exporter-YAML.t.
- Fix generate()'s _assert_identifier() check on the function name
rejecting fully-qualified sub names such as DB::DB, breaking
t/app.t's self-test sweep against
Devel::App::Test::Generator::LCSAJ::Runtime.pm (DB::DB is a Perl
debugger hook, always installed into the DB:: package regardless
of its source package); the function-name check now allows "::"
separators, same as the existing module-name check.
- Fix SchemaExtractor's heuristic numeric-type inference missing
parameters that are only ever validated via an explicit
looks_like_number($param) call rather than direct arithmetic
adjacency (e.g. a parameter used as looks_like_number($b) in a
guard clause and only later folded into arithmetic via
$a + ($b // 0), where $b never sits next to an operator itself);
such parameters fell back to type 'string', so fuzz-generated
non-numeric inputs caused generated tests to fail against code
that legitimately dies on non-numeric input. An explicit
looks_like_number($param) call in the source is now treated as a
direct numeric-type assertion, checked before the existing
arithmetic-operator and comparison heuristics.
- Fix _compile_signature_isolated()'s "fast path" Safe compartment,
tried before falling back to the subprocess unconditionally;
Type::Params/Types::Common pull in XS modules and Safe cannot host
XS/dynamic loading, so the compartment never succeeded for any real
signature_for() declaration and was dead code giving a false
impression of sandboxing. Removed; the subprocess path (gated on
allow_signature_exec => 1) is now the only path.
- Fix Generator.pm splicing module/function/transform/field names
magic numbers.
- Coverage dashboard per-file HTML links now work correctly; Devel::Cover
instrumentation restored to use cover -test for accurate per-file
HTML generation.
- Dashboard file links now correctly target blib-lib-* filenames as
generated by Devel::Cover, fixing persistent 404 errors on all
per-file coverage pages.
- generate-test-dashboard now derives the Devel::Cover -select pattern
dynamically from GITHUB_REPOSITORY, making the script portable across
CPAN distributions without hardcoded module paths.
- Fuzz schema generation now correctly looks in t/conf rather than
xt/conf for existing schemas to augment.
- Redundant exclusion of mutant_*.t from prove invocation removed;
mutant stubs are in xt/ and were never matched by the t/ find anyway.
[Bug fixes]
- Fix https://www.cpantesters.org/cpan/report/04c7279a-476f-11f1-bf55-cb595875c975
Make t/type_params.t an extended test
0.34 Sun May 3 10:30:24 EDT 2026
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.43';
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/BenchmarkGenerator.pm view on Meta::CPAN
package App::Test::Generator::BenchmarkGenerator;
use 5.036;
use Carp qw(croak);
use Params::Get qw(get_params);
use Readonly;
use Scalar::Util qw(looks_like_number);
our $VERSION = '0.43';
Readonly my %TYPE_DEFAULTS => (
number => 42,
integer => 42,
float => 3.14,
string => "'hello'",
boolean => 1,
arrayref => '[]',
lib/App/Test/Generator/BenchmarkGenerator.pm view on Meta::CPAN
sub _representative_value {
my ($spec) = @_;
return 'undef' unless defined $spec;
my $type = lc($spec->{type} // 'string');
if($type eq 'number' || $type eq 'integer' || $type eq 'float') {
my $min = $spec->{min};
my $max = $spec->{max};
my $default = $TYPE_DEFAULTS{$type} // 42;
if(defined $min && looks_like_number($min) && defined $max && looks_like_number($max)) {
return int(($min + $max) / 2);
}
if(defined $min && looks_like_number($min)) {
# pick the type default if it already satisfies >= min, else min+1
return $default > $min ? $default : $min + 1;
}
if(defined $max && looks_like_number($max)) {
# pick the type default if it already satisfies <= max, else max-1
return $default < $max ? $default : $max - 1;
}
return $default;
}
return $TYPE_DEFAULTS{$type} // "'value'";
}
# --------------------------------------------------
lib/App/Test/Generator/BenchmarkGenerator.pm view on Meta::CPAN
#
# Purpose: Quote a scalar value for use in generated Perl source.
#
# Entry: $v - scalar value (undef, number, or string)
#
# Exit: Returns a Perl literal string.
# --------------------------------------------------
sub _quote_value {
my ($v) = @_;
return 'undef' unless defined $v;
return $v if looks_like_number($v);
(my $escaped = $v) =~ s/'/\\'/g;
return "'$escaped'";
}
=head1 AUTHOR
Nigel Horne
=head1 LICENSE
lib/App/Test/Generator/PodExampleExtractor.pm view on Meta::CPAN
if($line =~ $VERBATIM_RE || ($line =~ /\S/ && @current)) {
push @current, $line;
} else {
if(@current) {
my $code = _dedent(join("\n", @current));
push @examples, {
section => $section,
code => $code,
expected => undef,
annotated_line => undef,
} if length($code) && _looks_like_perl($code);
@current = ();
}
}
}
if(@current) {
my $code = _dedent(join("\n", @current));
push @examples, {
section => $section,
code => $code,
expected => undef,
annotated_line => undef,
} if length($code) && _looks_like_perl($code);
}
return @examples;
}
# --------------------------------------------------
# _dedent
#
# Purpose: Remove the common leading whitespace from every line
# of a verbatim block so relative indentation is kept
lib/App/Test/Generator/PodExampleExtractor.pm view on Meta::CPAN
return '' unless @non_empty;
my ($min) = sort { $a <=> $b }
map { /^([ \t]*)/ ? length($1) : 0 } @non_empty;
s/^[ \t]{0,$min}// for @lines;
my $out = join("\n", @lines);
$out =~ s/\s+$//;
return $out;
}
# --------------------------------------------------
# _looks_like_perl
#
# Purpose: Return true when a verbatim block contains at least one
# line that is recognisably Perl syntax. Used to skip
# blocks of shell commands (e.g. "prove -l t/foo.t") that
# would cause compile errors under "use strict".
#
# Entry: $code - dedented block text
#
# Exit: Returns 1 (Perl) or '' (not Perl).
# --------------------------------------------------
sub _looks_like_perl {
my $code = $_[0];
for my $line (split /\n/, $code) {
next unless $line =~ /\S/; # skip blank lines
next if $line =~ /^\s*#/; # skip comment-only lines
# Perl sigils
return 1 if $line =~ /[\$\@\%]/;
# Perl keywords at start of statement
return 1 if $line =~ /^\s*(?:my|our|local|use|require|no|package|sub|for(?:each)?|if|unless|while|until|return|die|croak|warn|print|say|eval|BEGIN|END|push|pop|shift|unshift|keys|values|grep|map|sort)\b/;
# Method call or package separator
return 1 if $line =~ /(?:->|::)/;
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
} elsif (ref($default) eq 'ARRAY') {
$p->{type} = 'arrayref';
$self->_log(" CODE: $param type inferred as arrayref from default");
}
}
# ------------------------------------------------------------
# Heuristic numeric inference (low confidence)
# ------------------------------------------------------------
if (!$p->{type}) {
# An explicit looks_like_number($param) check is a direct
# numeric-type assertion by the author, stronger evidence than
# incidental arithmetic adjacency (e.g. $param is only ever
# used inside a defined-or default before the arithmetic, so
# the arithmetic-operator check below never sees $param itself
# next to an operator).
if ($code =~ /\blooks_like_number\s*\(\s*\$$param\s*\)/) {
$p->{type} = 'number';
$p->{_type_confidence} = 'heuristic';
$self->_log(" CODE: $param inferred as number (looks_like_number check)");
}
# Numeric operators: + - * / % **
# Use \/(?!\/) to exclude // (defined-or) from matching as division.
elsif (
$code =~ /\$$param\s*(?:[\+\-\*\%]|\/(?!\/))/ ||
$code =~ /(?:[\+\-\*\%]|\/(?!\/))\s*\$$param/ ||
$code =~ /\bint\s*\(\s*\$$param\s*\)/ ||
$code =~ /\babs\s*\(\s*\$$param\s*\)/
) {
$p->{type} = 'number';
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;
}
}
# Direct-index style: my $self = $_[0]; my $arg = $_[1]; ...
# Must be checked before Style 1 to avoid matching @_ inside closures
# defined in the body of a method that uses this style.
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' ), _DESCRIPTION => 'float below minimum value is denied' },
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/CoverageGuided_Fuzzer.t view on Meta::CPAN
subtest '_generate_for_schema() returns undef for "undef" string spec' => sub {
my $f = _fuzzer();
ok(!defined($f->_generate_for_schema('undef')), '"undef" spec -> undef');
};
subtest '_generate_for_schema() generates integer' => sub {
my $f = _fuzzer(seed => 1);
my $v = $f->_generate_for_schema({ type => 'integer', min => 0, max => 100 });
ok(defined $v, 'integer generated');
ok($v =~ /^-?\d+$/, 'looks like integer');
};
subtest '_generate_for_schema() generates boolean 0 or 1' => sub {
my $f = _fuzzer(seed => 1);
for (1..10) {
my $v = $f->_generate_for_schema({ type => 'boolean' });
ok($v == 0 || $v == 1, "boolean value $v is 0 or 1");
}
};
t/PodExampleExtractor_unit.t view on Meta::CPAN
my $res = $ex->extract();
ok(scalar @$res > 0, 'examples found in Sample::Module');
my @ann = grep { defined $_->{expected} } @$res;
ok(@ann >= 2, 'at least two annotated examples found');
my ($vs) = grep { $_->{code} =~ /validate_score.*75\.5/ } @ann;
ok(defined $vs, 'validate_score(75.5) example found');
is($vs->{expected}, "'Pass'", "expected value is 'Pass'");
};
# ==================================================================
# Shell-command filtering (_looks_like_perl)
# ==================================================================
subtest 'extract() skips verbatim blocks containing only shell commands' => sub {
my $pm = _tmp_pm(<<'PM');
package Foo;
=head1 SYNOPSIS
fuzz-harness-generator -r schemas/foo.yml
t/PodExampleExtractor_unit.t view on Meta::CPAN
1;
PM
my $out = File::Temp->new(SUFFIX => '.t', UNLINK => 1);
system($^X, '-Ilib', 'bin/pod-example-tester', '--output', "$out", $pm) == 0
or plan skip_all => 'pod-example-tester not runnable';
my $generated = do { local $/; open my $fh, '<', "$out" or die $!; <$fh> };
unlike($generated, qr/^\s+system\s*\(/m, 'no executable system() statement in generated file');
like($generated, qr/note\(.*skipped shell call/i, 'system() replaced with note()');
};
subtest '_looks_like_perl keeps blocks with sigils, keywords, :: and ->' => sub {
my $pm = _tmp_pm(<<'PM');
package Foo;
=head1 SYNOPSIS
my $obj = Foo->new();
prove -l t/foo.t
$obj->method();
t/SchemaExtractor.t view on Meta::CPAN
# ==================================================================
# _analyze_code (via extract_all integration)
# --------------------------------------------------
# Tests that code patterns are analysed correctly
# ==================================================================
subtest '_analyze_code integration' => sub {
my $source = <<'PM';
package CodeTest;
use Scalar::Util qw(looks_like_number);
sub add {
my ($x, $y) = @_;
die 'not numeric' unless looks_like_number($x);
return $x + ($y // 0);
}
sub get_name {
my ($self) = @_;
return $self->{name};
}
1;
PM
t/SchemaExtractor.t view on Meta::CPAN
# ==================================================================
# _yamltest_hints integration
# --------------------------------------------------
# Tests that numeric boundary hints are added for
# methods with numeric intent
# ==================================================================
subtest '_yamltest_hints integration' => sub {
my $source = <<'PM';
package HintsTest;
use Scalar::Util qw(looks_like_number);
sub scale {
my ($self, $factor) = @_;
die 'not numeric' unless looks_like_number($factor);
die 'negative' if $factor < 0;
return $self->{value} * $factor;
}
1;
PM
my $e = _extractor($source);
my $schemas = $e->extract_all(no_write => 1);
t/SchemaExtractor_function.t view on Meta::CPAN
my $result = $e->_extract_pvs_schema($code);
# Either returns a schema hashref or undef — just check no crash
ok(1, '_extract_pvs_schema completed without crash on validate_strict code');
if(defined $result) {
is(ref($result), 'HASH', 'returned value is a hashref when defined');
}
};
subtest '_extract_pvs_schema() returns hashref with input key when schema detected' => sub {
my $e = _extractor();
# Use the bare function name form that the extractor looks for
my $code = <<'CODE';
sub my_method {
my $params = validate_strict({
name => { type => 'string', optional => 0 }
});
}
CODE
my $result = $e->_extract_pvs_schema($code);
if(defined $result) {
is(ref($result), 'HASH', 'returns hashref');
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/extended_tests.t view on Meta::CPAN
#!/usr/bin/env perl
use strict;
use warnings;
use Test::Most;
use Capture::Tiny qw(capture);
use File::Path qw(make_path);
use File::Spec;
use File::Temp qw(tempdir tempfile);
use Scalar::Util qw(looks_like_number);
# Extended tests targeting:
# 1. Known surviving mutants in _dedup_mutants, _is_redundant_mutation,
# BooleanNegation, ReturnUndef, Emitter::Perl, Planner
# 2. Branch coverage gaps in Generator render helpers
# 3. LCSAJ/TER3 improvement via additional branch-path coverage
# 4. Stateful behaviour across multiple calls
BEGIN {
use_ok('App::Test::Generator');
t/extended_tests.t view on Meta::CPAN
my $f = App::Test::Generator::CoverageGuidedFuzzer->new(
schema => { input => { type => 'integer', min => 5, max => 10 } },
target_sub => sub { 1 },
iterations => 0,
seed => 42,
);
for (1..20) {
my $val = App::Test::Generator::CoverageGuidedFuzzer::_rand_int(
$f, { min => 5, max => 10 }
);
ok(looks_like_number($val), "_rand_int returns numeric value (got $val)");
}
};
subtest 'CoverageGuidedFuzzer: _rand_num returns value within bounds' => sub {
my $f = App::Test::Generator::CoverageGuidedFuzzer->new(
schema => { input => { type => 'number' } },
target_sub => sub { 1 },
iterations => 0,
seed => 42,
);
t/function.t view on Meta::CPAN
use Test::Memory::Cycle;
use Capture::Tiny qw(capture_stdout capture_merged);
use File::Temp qw(tempdir tempfile);
use File::Spec;
use File::Path qw(make_path);
use Cwd qw(getcwd);
use Carp qw(croak);
use JSON::MaybeXS qw(decode_json);
use PPI;
use Readonly;
use Scalar::Util qw(looks_like_number);
# CORE::GLOBAL::system overrides are resolved when the *calling* code is
# compiled, not dispatched dynamically -- a "local *CORE::GLOBAL::system"
# set at runtime inside a subtest has no effect on Mutator::run_tests(),
# because Mutator.pm is already compiled by the time that subtest runs.
# This override must therefore be installed in a BEGIN block before
# App::Test::Generator::Mutator is use'd below, with the actual mock
# behaviour supplied per-subtest via $REAL_SYSTEM_HOOK so the default
# (no active subtest) passes through to the real builtin.
our $REAL_SYSTEM_HOOK;
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 1.584 second using v1.01-cache-2.11-cpan-6aa56a78535 )