App-Test-Generator
view release on metacpan or search on metacpan
error_pattern) and tie-break cases (all-zero→constant, object=property
tie→object); resolve_confidence() at all four threshold boundary
points (19→low, 20→medium, 39→medium, 40→high); add_evidence()
weight=0 stored as 0 not default 1; _representative_value() all 15
branches (float/integer with no/min-only/max-only/both constraints,
boolean/arrayref/hashref/unknown types, undef spec); _quote_value()
all 4 paths; _build_call() all 5 call-syntax combinations;
generate() missing-key croaks, has_new+builtin skips constructor,
empty new_spec hashref→no-arg constructor, empty transforms→default
variant; Complexity::analyze() given/when branch tokens, keyword
inside dquoted strings stripped, escaped dquote handled, unmatched
brace depth clamp, early_returns boundaries at 1 and 2 returns;
SideEffect::analyze() read/write IO keywords, self+globals→impure
purity path, false-positive guards for $self->{field}= inside strings
and comments; Planner::Isolation::plan() scalar-falsy time/network
values omit flags, hashref-truthy env propagates.
Dead code flagged: Model::Method::resolve_return_type() line 552 —
the `|| 'unknown'` fallback is unreachable because %score is always
initialised with 3 keys so $winner is always a non-empty string.
[Bug fixes]
- Fix SchemaExtractor::_detect_accessor_methods injecting the property
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
unescaped into generated test source; added _assert_identifier()
and applied it before every such splice point so a name that is
not identifier-shaped now croaks instead of producing a test file
with injected code.
- Fix extract-schemas2 calling Planner->new without the required
package argument, crashing on every invocation; package is now
passed through from the extracted schema.
- Fix Template.pm _dedup_cases() always being a no-op: a return
inside the eval{} block returned from the eval, not from
_dedup_cases, so the deduplicated result was discarded and the
unduplicated $cases was always returned to the caller.
bin/fuzz-harness-generator view on Meta::CPAN
}
$t .= "\nplan tests => $test_count;\n\n";
for my $i (0 .. $#tests) {
my $test = $tests[$i];
my $n = $i + 1;
my $input = _format_input($test->{'input'});
my $label = "$test->{'method'} does not die on input from $test->{'file'}";
# Flatten and escape the original error for use as a comment
(my $orig_error = $test->{'error'} // '') =~ s/\n/ /g;
$orig_error =~ s/'/\\'/g;
$t .= "# Corpus bug: $orig_error\n";
$t .= "lives_ok { $test->{'module'}\->$test->{'method'}($input) }\n";
$t .= " '$label';\n\n";
}
return $t;
}
bin/fuzz-harness-generator view on Meta::CPAN
# 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
# not reproduce the original input.
# --------------------------------------------------
sub _format_input {
my ($input) = @_;
return 'undef' unless defined $input;
# Emit bare numeric literals without quoting
return $input if $input =~ /^-?(?:\d+\.?\d*|\.\d+)$/;
# Escape backslashes first, then single quotes, to avoid
# double-escaping when both appear in the same string
(my $escaped = $input) =~ s/\\/\\\\/g;
$escaped =~ s/'/\\'/g;
return "'$escaped'";
}
# --------------------------------------------------
# _infer_module_from_schema
#
# Purpose: Attempt to determine the Perl module
# name for a given corpus method by
# locating and reading the companion YAML
# schema file that sits alongside the
# corpus directory.
bin/pod-example-tester view on Meta::CPAN
# them through unchanged.
#
# Lines that are already comments are left alone — they can't execute.
# ---------------------------------------------------------------------------
sub _neutralize_exec {
my ($line) = @_;
return '' if $line =~ /^\s*#/; # pure comment — harmless
return '' unless $line =~ /\b(?:system|exec)\s*\(|`|\bqx\s*[{(\[\/|]/;
(my $msg = $line) =~ s/^\s+//; # strip leading whitespace for display
$msg =~ s/'/\\'/g; # escape single quotes for q{}
$msg =~ s/\s+$//;
return "note('pod-example-tester: skipped shell call: $msg');";
}
# ---------------------------------------------------------------------------
# _stub_undeclared_vars — return sorted list of sigil+name variables (e.g.
# '$dir', '@items') that appear in the code block but are not declared with
# my/our/local. Used to inject stub declarations so generated eval blocks
# compile cleanly under "use strict" even when SYNOPSIS snippets assume
bin/test-generator-index view on Meta::CPAN
use Getopt::Long qw(GetOptions);
use IPC::Run3;
use JSON::MaybeXS;
use List::Util qw(max min);
use POSIX qw(strftime);
use HTML::Entities;
use HTTP::Tiny;
use Readonly;
use Storable qw(dclone);
use Time::HiRes qw(sleep);
use URI::Escape qw(uri_escape);
use version;
use WWW::RT::CPAN;
use YAML::XS qw(LoadFile);
=head1 NAME
test-generator-index - Test coverage dashboard generator
=head1 DESCRIPTION
bin/test-generator-index view on Meta::CPAN
# Now calculate deltas and create JavaScript data points
my @data_points;
my $prev_pct;
foreach my $point (@data_points_with_time) {
my $delta = defined $prev_pct ? sprintf('%.1f', $point->{pct} - $prev_pct) : 0;
$prev_pct = $point->{pct};
my $color = $delta > 0 ? 'green' : $delta < 0 ? 'red' : 'gray';
my $comment = js_escape($point->{comment});
push @data_points, qq{{ x: "$point->{timestamp}", y: $point->{pct}, delta: $delta, url: "$point->{url}", label: "$point->{timestamp}", pointBackgroundColor: "$color", comment: "$comment" }};
}
if(scalar(@data_points)) {
push @html, <<'HTML';
<div style="display: flex; justify-content: space-between; align-items: center; margin-bottom: 1em;">
<div>
<h2>Coverage Trend</h2>
<label>
<input type="checkbox" id="toggleTrend" checked>
bin/test-generator-index view on Meta::CPAN
'</p>';
} else {
push @html, "<p>No issues active on <a href=\"$rt_url\">RT</a></p>";
}
}
# -------------------------------
# CPAN Testers failing reports table
# -------------------------------
my $dist_name = $config{github_repo};
my $cpan_api = "https://api.cpantesters.org/v3/summary/" . uri_escape($dist_name);
my $http = HTTP::Tiny->new(agent => 'cpan-coverage-html/1.0', timeout => 30);
my $retry = 0;
my $success = 0;
my $res;
# Try a number of times because the cpantesters website can get overloaded
while($retry < $config{max_retry}) {
bin/test-generator-index view on Meta::CPAN
sub run_git {
my @cmd = @_;
my ($out, $err);
run3 ['git', @cmd], \undef, \$out, \$err;
return unless $? == 0;
chomp $out;
return $out;
}
# --------------------------------------------------
# js_escape
#
# Purpose: Escape a string for safe embedding in a
# JavaScript double-quoted string literal
# in generated HTML.
#
# Entry: $str - the string to escape.
#
# Exit: Returns the escaped string. Backslashes
# are doubled, double quotes are escaped,
# and newlines are replaced with \n.
#
# Side effects: None.
#
# Notes: Does not escape single quotes or other
# JS metacharacters — only the minimum
# needed for double-quoted string context.
# --------------------------------------------------
sub js_escape {
my $str = $_[0];
$str =~ s/\\/\\\\/g;
$str =~ s/"/\\"/g;
$str =~ s/\n/\\n/g;
return $str;
}
# --------------------------------------------------
# fetch_reports_by_grades
#
bin/test-generator-index view on Meta::CPAN
# in a single request.
# --------------------------------------------------
sub fetch_reports_by_grades {
my ($dist, $version, @grades) = @_;
my %seen;
my @reports;
for my $grade (@grades) {
my $url = 'https://api.cpantesters.org/v3/summary/'
. uri_escape($dist)
. '/' . uri_escape($version)
. "?grade=$grade";
my $res = $http->get($url);
next unless $res->{success};
my $arr = eval { decode_json($res->{content}) };
next unless ref $arr eq 'ARRAY';
for my $r (@$arr) {
my $key = make_key($r);
bin/test-generator-index view on Meta::CPAN
return unless -f $file;
open my $in, '<', $file or return;
my @lines = <$in>;
close $in;
# $file values come from mutation.json, keyed by paths discovered
# under lib/; reject any '..' segment before it can be used to
# build an output path, since the directory-preserving join below
# would otherwise let such a segment escape $dir.
croak("Refusing to report on suspicious file path: $file")
if grep { $_ eq File::Spec->updir } File::Spec->splitdir($file);
# Preserve directory structure inside report
my $relative_path = File::Spec->catfile($dir, $file . '.html');
my $out_dir = dirname($relative_path);
make_path($out_dir) unless -d $out_dir;
lib/App/Test/Generator.pm view on Meta::CPAN
}
}
} elsif($module eq $MODULE_BUILTIN) {
undef $module;
}
if($module && length($module) && ($module ne 'builtin')) {
_validate_module($module, $schema_file);
}
# $module/$function are spliced unescaped into generated test
# source below (use_ok, new_ok, ->$function, $module::$function)
# — reject anything that isn't identifier-shaped before that happens.
_assert_identifier($module, 'module', package => 1) if defined($module) && length($module);
# sensible defaults
$function ||= 'run';
# package => 1: fully-qualified sub names (e.g. DB::DB, a debugger
# hook installed into the DB:: package regardless of its source
# package) are legitimate function names, not just bare identifiers
_assert_identifier($function, 'function', package => 1);
lib/App/Test/Generator.pm view on Meta::CPAN
# _assert_identifier
#
# Purpose: Validate that a string is shaped like a
# plain Perl identifier (or, with
# package => 1, a "::"-separated package
# name) before it is spliced into generated
# test source as a bareword, package name,
# method name, or variable name rather than
# a quoted string literal. Schema-derived
# names (module, function, transform names)
# are spliced unescaped at the call sites
# that use this guard, so an unvalidated
# name could otherwise break out of the
# generated source and inject arbitrary
# Perl into a file that L<prove> will run.
#
# Entry: $name - the string to validate.
# $what - short label for the value, used
# only in the croak message.
# %opts - package => 1 allows "::"
# separators in $name.
lib/App/Test/Generator.pm view on Meta::CPAN
# 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
lib/App/Test/Generator.pm view on Meta::CPAN
}
# 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
lib/App/Test/Generator.pm view on Meta::CPAN
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;
lib/App/Test/Generator.pm view on Meta::CPAN
my @generators;
my @var_names;
for my $field (sort keys %{$input_spec}) {
my $spec = $input_spec->{$field};
# Skip non-hashref field specs — scalar types
# like 'string' have no generator sub-structure
next unless ref($spec) eq 'HASH';
# $field is spliced unescaped into the generated
# LectroTest generator spec by
# _schema_to_lectrotest_generator() — reject anything
# that isn't identifier-shaped first.
_assert_identifier($field, 'input field name');
my $gen = _schema_to_lectrotest_generator($field, $spec);
if(defined($gen) && length($gen)) {
push @generators, $gen;
push @var_names, $field;
}
lib/App/Test/Generator.pm view on Meta::CPAN
my $min_len = $spec->{'min'} // 0;
my $max_len = $spec->{'max'} // $DEFAULT_MAX_STRING_LEN;
# If a regex pattern is declared, delegate to
# Data::Random::String::Matches for pattern-aware generation
if(defined($spec->{'matches'})) {
my $pattern = $spec->{'matches'};
# Compile the pattern safely rather than splicing the raw
# string into qr/$pattern/ — the raw form lets a pattern
# containing an unescaped '/' break out of the qr//
# delimiter and inject arbitrary Perl into the generated
# test. regexp_pattern() decomposes the already-compiled
# Regexp object back into pattern text that is guaranteed
# to be a self-contained regex body, safe to re-embed.
my $compiled = ref($pattern) eq 'Regexp' ? $pattern : eval { qr/$pattern/ };
if($@ || !defined($compiled)) {
carp "Invalid matches pattern '$pattern' for field '$field_name': $@";
return "$field_name <- String(length => [$min_len, $max_len])";
}
my ($pat, $mods) = regexp_pattern($compiled);
lib/App/Test/Generator.pm view on Meta::CPAN
code => "length(\$result) <= $output_spec->{'max'}",
};
}
if(defined($output_spec->{'matches'})) {
my $pattern = $output_spec->{'matches'};
# See the matching comment in _schema_to_lectrotest_generator —
# compile first and re-embed via regexp_pattern() rather than
# splicing the raw string into qr/$pattern/, which would let
# an unescaped '/' break out of the delimiter.
my $compiled = ref($pattern) eq 'Regexp' ? $pattern : eval { qr/$pattern/ };
if($@ || !defined($compiled)) {
carp "Invalid matches pattern '$pattern' for transform '$transform_name': $@";
} else {
my ($pat, $mods) = regexp_pattern($compiled);
my $safe_re = "qr{$pat}" . ($mods // '');
push @properties, {
name => 'pattern_match',
code => "\$result =~ $safe_re",
};
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
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
lib/App/Test/Generator/Emitter/Perl.pm view on Meta::CPAN
=cut
sub new {
my ($class, %args) = @_;
# All three arguments are required for meaningful emission
croak 'schema required' unless defined $args{schema};
croak 'plans required' unless defined $args{plans};
croak 'package required' unless defined $args{package};
# $args{package} is spliced unescaped into use_ok()/new_ok() calls
# in _emit_header() — reject anything that isn't a valid Perl
# package name now, rather than generating broken or injected code.
croak "package '$args{package}' is not a valid Perl package name"
unless $args{package} =~ /^[A-Za-z_]\w*(?:::[A-Za-z_]\w*)*\z/;
return bless {
schema => $args{schema},
plans => $args{plans},
package => $args{package},
}, $class;
lib/App/Test/Generator/Emitter/Perl.pm view on Meta::CPAN
# Exit: Returns a string of Perl test code.
# Side effects: None.
# Notes: Test types are emitted in a fixed order
# for deterministic output. Methods with
# no recognised plan flags produce no
# output beyond the section comment.
# --------------------------------------------------
sub _emit_method_tests {
my ($self, $method) = @_;
# $method is spliced unescaped as a bareword method name
# (->$method(...)) by every _emit_*_test sub below — reject
# anything that isn't a valid Perl identifier before any of them run.
croak "method '$method' is not a valid Perl identifier"
unless $method =~ /^[A-Za-z_]\w*\z/;
my $plan = $self->{plans}{$method};
my $code = "\n# --- Tests for $method ---\n";
# Emit each test type in a consistent fixed order
$code .= $self->_emit_basic_test($method) if $plan->{$TEST_BASIC};
lib/App/Test/Generator/SchemaExtractor.pm view on Meta::CPAN
=item * Parameter lists: C<$param - type, default 'value'>
=back
=head3 Value Processing
Properly handles:
=over 4
=item * String literals with quotes and escape sequences
=item * Numeric values (integers and floats)
=item * Boolean values (true/false converted to 1/0)
=item * Empty data structures ([] and {})
=item * Special values (undef, __PACKAGE__)
=item * Complex expressions (preserved as-is when unevaluatable)
lib/App/Test/Generator/SchemaExtractor.pm view on Meta::CPAN
return unless defined $param && $param =~ /^\w+$/;
# ref() check for CODE
if ($code =~ /ref\s*\(\s*\$$param\s*\)\s*eq\s*['"]CODE['"]/i) {
$p->{type} = 'coderef';
$p->{semantic} = 'callback';
$self->_log(" ADVANCED: $param is coderef (ref check)");
return;
}
# Invocation as coderef - note the escaped @ in \@_
if ($code =~ /\$$param\s*->\s*\(/ ||
$code =~ /\$$param\s*->\s*\(\s*\@_\s*\)/ ||
$code =~ /&\s*\{\s*\$$param\s*\}/) {
$p->{type} = 'coderef';
$p->{semantic} = 'callback';
$self->_log(" ADVANCED: $param invoked as coderef");
return;
}
# Parameter name suggests callback
lib/App/Test/Generator/SchemaExtractor.pm view on Meta::CPAN
# extracted from code or POD into a
# clean Perl scalar, handling quoted
# strings, numeric literals, boolean
# keywords, empty containers, and
# undef.
#
# Entry: $value - raw value string.
# May be undef.
# $from_code - true if the value was
# extracted from source
# code (affects escape
# sequence handling).
#
# Exit: Returns the cleaned value:
# undef for undef or unparseable
# {} for empty hashrefs
# [] for empty arrayrefs
# integer for whole numbers
# float for decimal numbers
# 1 or 0 for boolean keywords
# string for everything else
lib/App/Test/Generator/SchemaExtractor.pm view on Meta::CPAN
$value = $1;
} elsif ($value =~ /^q[qwx]?\s*([^a-zA-Z0-9\{\[])(.*?)\1$/s) {
$value = $2;
}
# Handle quoted strings
if ($value =~ /^(['"])(.*)\1$/s) {
$value = $2;
if ($from_code) {
# In regex captures from source code, escape sequences are doubled
# \\n in capture needs to become \n for the test
$value =~ s/\\\\/\\/g;
}
# Only unescape the quote characters themselves
$value =~ s/\\"/"/g;
$value =~ s/\\'/'/g;
# If NOT from code (i.e., from POD), interpret escape sequences
unless ($from_code) {
$value =~ s/\\n/\n/g;
$value =~ s/\\r/\r/g;
$value =~ s/\\t/\t/g;
$value =~ s/\\\\/\\/g;
}
}
# Sometimes trailing ) is left on
if($value !~ /^\(/) {
lib/App/Test/Generator/Template.pm view on Meta::CPAN
}
my $name = delete local $case->{'_NAME'};
my $properties = delete local $case->{_PROPERTIES};
my $description = delete local $case->{_DESCRIPTION};
my $result;
my $mess;
my @alist = ();
if(defined($input) && !ref($input)) {
# $mess is later used as a sprintf() format string further
# below — a literal '%' in $name/$input must be escaped to
# '%%' first, the same as the aggregate branch does for
# $args, or a value like '%s' / '%n' corrupts the sprintf call.
(my $safe_input = $input) =~ s/%/%%/g;
if($name) {
(my $safe_name = $name) =~ s/%/%%/g;
$mess = "[% function %]($safe_name = '$safe_input') %s";
} else {
$mess = "[% function %]('$safe_input') %s";
}
} elsif(defined($input)) {
t/Generator.t view on Meta::CPAN
*_get_dominant_type = \&App::Test::Generator::_get_dominant_type;
*_detect_transform_properties = \&App::Test::Generator::_detect_transform_properties;
*_render_properties = \&App::Test::Generator::_render_properties;
*_schema_to_lectrotest_generator = \&App::Test::Generator::_schema_to_lectrotest_generator;
*_get_semantic_generators = \&App::Test::Generator::_get_semantic_generators;
*_get_builtin_properties = \&App::Test::Generator::_get_builtin_properties;
*_is_perl_builtin = \&App::Test::Generator::_is_perl_builtin;
}
# ------------------------------------------------------------------
# perl_sq — escape a string for single-quoted Perl string context
# ------------------------------------------------------------------
subtest 'perl_sq() returns empty string for undef' => sub {
is(App::Test::Generator::perl_sq(undef), '', 'undef produces empty string');
};
subtest 'perl_sq() escapes backslashes first' => sub {
is(App::Test::Generator::perl_sq('a\\b'), 'a\\\\b', 'backslash doubled');
};
subtest 'perl_sq() escapes apostrophes' => sub {
is(App::Test::Generator::perl_sq("it's"), "it\\'s", 'apostrophe escaped');
};
subtest 'perl_sq() escapes common control characters' => sub {
is(App::Test::Generator::perl_sq("a\nb"), 'a\\nb', 'newline escaped');
is(App::Test::Generator::perl_sq("a\rb"), 'a\\rb', 'CR escaped');
is(App::Test::Generator::perl_sq("a\tb"), 'a\\tb', 'tab escaped');
is(App::Test::Generator::perl_sq("a\fb"), 'a\\fb', 'formfeed escaped');
};
subtest 'perl_sq() replaces NUL bytes' => sub {
is(App::Test::Generator::perl_sq("a\0b"), 'a\\0b', 'NUL replaced with \\0');
};
subtest 'perl_sq() leaves plain string unchanged' => sub {
is(App::Test::Generator::perl_sq('hello'), 'hello', 'plain string unchanged');
};
t/Generator.t view on Meta::CPAN
subtest 'q_wrap() falls back when curly braces in string' => sub {
my $result = App::Test::Generator::q_wrap('a{b}c');
# Should use a different delimiter
unlike($result, qr/^q\{a\{b\}c\}$/, 'does not use q{} when string contains {}');
ok(length($result) > 0, 'returns non-empty result');
};
subtest 'q_wrap() uses single-quote fallback when all delimiters used' => sub {
# A string containing all bracket pairs AND all single-char delimiters
# forces the escaped single-quote fallback
my $str = '{}()[]<>~!%^=+:,;|/#';
my $result = App::Test::Generator::q_wrap($str);
ok(defined $result, 'returns defined value for pathological string');
};
subtest 'q_wrap() correctly uses != INDEX_NOT_FOUND boundary' => sub {
# A string starting with ~ means index returns 0 (not -1)
# If the guard were "> 0" instead of "!= -1" it would wrongly
# choose ~ as the delimiter when ~ is at position 0
my $result = App::Test::Generator::q_wrap('~starts with tilde');
t/default_value_extraction.t view on Meta::CPAN
'test',
'Cleans string with whitespace'
);
is(
$extractor->_clean_default_value(' 42 '),
42,
'Cleans integer with whitespace'
);
# Test escaped strings
is(
$extractor->_clean_default_value('"line1\\nline2"'),
"line1\nline2",
'Handles escaped newlines'
);
is(
$extractor->_clean_default_value("'it\\'s working'"),
"it's working",
'Handles escaped quotes'
);
done_testing();
};
# POD default value extraction
subtest 'POD Default Value Extraction' => sub {
my $module = <<'END_MODULE';
package Test::PODDefaults;
use strict;
t/default_value_extraction.t view on Meta::CPAN
package Test::EdgeCases;
use strict;
use warnings;
sub edge_cases {
my ($self, $param1, $param2, $param3, $param4, $param5) = @_;
# Edge case 1: Default with quotes inside quotes
$param1 = $param1 || "it's complicated";
# Edge case 2: Default with escaped characters
$param2 //= "line1\\nline2\\ttab";
# Edge case 3: Default as expression in parentheses
$param3 = defined $param3 ? $param3 : (10 + 20);
# Edge case 4: Default with trailing comment
$param4 = $param4 || 'default'; # this is a comment
# Edge case 5: Default with q// operator
$param5 = $param5 || q{default value};
t/default_value_extraction.t view on Meta::CPAN
# Check specific edge cases
is(
$code_params->{param1}{_default},
"it's complicated",
'Handles quotes inside string default'
);
is(
$code_params->{param2}{_default},
"line1\\nline2\\ttab",
'Preserves escaped characters in default'
);
is(
$code_params->{param2}{_default},
"line1\\nline2\\ttab",
'Preserves escaped characters in default'
);
# Note: param3 returns expression "(10 + 20)" which we can't evaluate
ok(
$code_params->{param3}{_default},
'Extracts expression default (even if unevaluatable)'
);
is(
$code_params->{param4}{_default},
t/edge_cases.t view on Meta::CPAN
# ==================================================================
# Generator::generate() -- end-to-end injection attempt via a
# schema-derived function name
#
# _assert_identifier() itself is already unit-tested directly
# elsewhere (t/function.t). This instead exercises the *full*
# generate() pipeline end to end: a function name shaped like a Perl
# statement-injection payload (semicolon-separated, containing a
# system() call) must be rejected before it ever reaches the point of
# being spliced unescaped into generated test source, and critically,
# before any output file is created on disk.
# ==================================================================
subtest 'Generator::generate(): statement-injection-shaped function name is rejected before any file is written' => sub {
my $dir = tempdir(CLEANUP => 1);
my $outfile = File::Spec->catfile($dir, 'out.t');
my $schema = {
function => 'evil; system("touch /tmp/pwned"); 1',
input => { number => { type => 'number', position => 0 } },
output => { type => 'number' },
t/extended_tests.t view on Meta::CPAN
like($result, qr/i/, 'case-insensitive modifier included');
};
subtest 'perl_quote: hashref falls through to render_fallback' => sub {
my $result = App::Test::Generator::perl_quote({ key => 'val' });
ok(defined $result, 'hashref handled');
like($result, qr/key/, 'key present in output');
like($result, qr/val/, 'value present in output');
};
subtest 'perl_sq: backslash escaped correctly' => sub {
my $result = App::Test::Generator::perl_sq('a\\b');
like($result, qr/\\\\/, 'backslash doubled');
};
subtest 'perl_sq: single quote escaped correctly' => sub {
my $result = App::Test::Generator::perl_sq("it's");
like($result, qr/\\'/, 'apostrophe escaped');
};
subtest 'perl_sq: control characters escaped' => sub {
is(App::Test::Generator::perl_sq("\n"), '\\n', 'newline escaped');
is(App::Test::Generator::perl_sq("\t"), '\\t', 'tab escaped');
is(App::Test::Generator::perl_sq("\r"), '\\r', 'CR escaped');
};
subtest 'perl_sq: NUL byte escaped as \\0' => sub {
is(App::Test::Generator::perl_sq("\0"), '\\0', 'NUL escaped');
};
subtest 'q_wrap: prefers bracket form when available' => sub {
my $result = App::Test::Generator::q_wrap('hello');
like($result, qr/^q\{hello\}$/, 'bracket form preferred');
};
subtest 'q_wrap: falls back to () when {} used in string' => sub {
my $result = App::Test::Generator::q_wrap('a{b}c');
ok(defined $result, 'string with braces handled');
t/function.t view on Meta::CPAN
Readonly my $SAMPLE_MIN_NAME_LEN => 1;
Readonly my $SAMPLE_MAX_NAME_LEN => 50;
Readonly my $SAMPLE_MIN_SCORE => 0.0;
Readonly my $SAMPLE_MAX_SCORE => 100.0;
Readonly my $SAMPLE_PASS_THRESHOLD => 60.0;
# ==================================================================
# perl_sq
# --------------------------------------------------
# White-box tests for the low-level single-quote
# string escaper used by perl_quote and q_wrap
# ==================================================================
subtest 'perl_sq' => sub {
# Access the private function directly via the package namespace
my $fn = \&App::Test::Generator::perl_sq;
# Undef input returns empty string, not 'undef'
is($fn->(undef), $EMPTY_STRING, 'undef returns empty string');
# Plain ASCII string passes through unchanged
is($fn->('hello'), 'hello', 'plain ASCII unchanged');
# Apostrophe must be escaped so it does not break the surrounding
# single-quoted string literal in the generated test
is($fn->("it's"), "it\\'s", 'apostrophe escaped');
# Backslash must be escaped first so later substitutions
# do not double-escape already-escaped sequences
is($fn->('a\\b'), 'a\\\\b', 'backslash escaped');
# Control characters are converted to their two-char sequences
is($fn->("a\nb"), 'a\\nb', 'newline escaped');
is($fn->("a\rb"), 'a\\rb', 'carriage return escaped');
is($fn->("a\tb"), 'a\\tb', 'tab escaped');
is($fn->("a\fb"), 'a\\fb', 'form feed escaped');
# NUL byte is converted to \0 for double-quoted context
is($fn->("a\0b"), 'a\\0b', 'NUL byte escaped');
# Both apostrophe and backslash in the same string
is($fn->("a\\'b"), "a\\\\\\'b", 'backslash and apostrophe together');
done_testing();
};
# ==================================================================
# perl_quote
# --------------------------------------------------
t/function.t view on Meta::CPAN
is($fn->(0), '0', 'zero unquoted');
is($fn->(42), '42', 'positive integer unquoted');
is($fn->(-1), '-1', 'negative integer unquoted');
# Floats are emitted unquoted
is($fn->(3.14), '3.14', 'float unquoted');
# Plain strings are single-quoted
is($fn->('hello'), "'hello'", 'string single-quoted');
# Strings containing apostrophes have them escaped
is($fn->("it's"), "'it\\'s'", 'apostrophe in string escaped');
# Arrayrefs are recursively quoted with brackets
is($fn->([1, 2, 3]), '[ 1, 2, 3 ]', 'arrayref recursively quoted');
# Nested arrayrefs recurse correctly
is($fn->([1, [2, 3]]), '[ 1, [ 2, 3 ] ]', 'nested arrayref quoted');
# Arrayref containing undef produces undef literal in the output
is($fn->([undef, 1]), "[ $UNDEF_LITERAL, 1 ]", 'arrayref with undef element');
t/function.t view on Meta::CPAN
unlike($fn->($with_brace), qr/^q\{/, 'string with { avoids q{}');
# String containing all bracket pairs falls back to single chars
my $all_brackets = '{([<>])}';
my $result = $fn->($all_brackets);
like($result, qr/^q./, 'all-bracket string still uses q form');
# Empty string produces empty q form
is($fn->($EMPTY_STRING), 'q{}', 'empty string produces q{}');
# String with apostrophe — q_wrap avoids needing to escape it
# by choosing a delimiter that is not an apostrophe
my $apos = "it's";
my $wrapped = $fn->($apos);
unlike($wrapped, qr/\\'/, 'apostrophe not escaped in q_wrap output');
done_testing();
};
# ==================================================================
# render_fallback
# --------------------------------------------------
# Tests for the Data::Dumper-based catch-all renderer
# ==================================================================
subtest 'render_fallback' => sub {
t/function.t view on Meta::CPAN
# Double- and single-quoted string contents are removed entirely,
# including any keyword-like text inside them
is($fn->(q{my $x = "if this then that";}), q{my $x = ;}, 'double-quoted string contents removed');
is($fn->(q{my $x = 'unless this';}), q{my $x = ;}, 'single-quoted string contents removed');
# Trailing # comments are blanked from the matched line onward
is($fn->("my \$x = 1; # if true do this\n"), "my \$x = 1; \n", 'trailing comment removed');
# Escaped quote characters inside a string do not terminate the
# match early -- this is the (?:[^"\\]|\\.) escape-aware alternation
is($fn->(q{my $x = "she said \"hi\"";}), q{my $x = ;}, 'escaped quotes inside string do not break stripping');
# A body with no strings or comments passes through unchanged
is($fn->('if ($x) { return 1; }'), 'if ($x) { return 1; }', 'plain code is unchanged');
# Empty input returns empty output, not undef or a die
is($fn->(''), '', 'empty string input returns empty string');
done_testing();
};
t/function.t view on Meta::CPAN
# permission tricks that behave differently when run as root
my $out_file = "cover_html/lcsaj_hits/hits_$$.json";
make_path($out_file);
throws_ok { Devel::App::Test::Generator::LCSAJ::Runtime::_write_results() }
qr/^Cannot write \Q$out_file\E: /,
'_write_results() croaks with the exact documented message when open() fails';
};
my $err = $@;
chdir $orig_cwd or croak "cannot chdir back to $orig_cwd: $!";
is($err, '', 'no unexpected exception escaped the eval wrapper') or diag($err);
};
subtest 'Devel::App::Test::Generator::LCSAJ::Runtime - BEGIN-time LCSAJ_TARGETS parsing' => sub {
# %TARGET is populated once, at compile time, from $ENV{LCSAJ_TARGETS}.
# That BEGIN block cannot be re-run against this already-loaded module,
# so it is exercised by loading a fresh copy of the module in a child
# process with the env var pre-set, then reading back %TARGET -- a
# single bounded perl -e invocation, not a recursive test/prove run
my $targets = '/build/blib/lib/Foo.pm:/home/user/proj/lib/Bar.pm:' . "\n";
local $ENV{LCSAJ_TARGETS} = $targets;
t/function.t view on Meta::CPAN
subtest 'Template::get_data_section - return value and memory-cycle safety' => sub {
my $result = App::Test::Generator::Template->get_data_section('test.tt');
returns_ok($result, { type => 'scalarref' }, 'get_data_section() returns a scalarref');
memory_cycle_ok($result, 'get_data_section() result is free of circular references');
};
# ==================================================================
# App::Test::Generator::_assert_identifier
#
# Security-critical guard (see CLAUDE.md): every module/function/
# transform/field name spliced unescaped into generated test source
# passes through here first. No existing test file (t/Generator.t,
# t/Generator_unit.t) exercises this function at all, so this section
# is full by-value coverage rather than a value-add narrowing.
# ==================================================================
subtest 'Generator::_assert_identifier - accepts well-formed identifiers' => sub {
my $fn = \&App::Test::Generator::_assert_identifier;
is($fn->('foo', 'name'), 'foo', 'a plain bareword identifier is returned unchanged');
is($fn->('_private', 'name'), '_private', 'a leading underscore is accepted');
is($fn->('Foo123', 'name'), 'Foo123', 'letters and digits after the first character are accepted');
t/function.t view on Meta::CPAN
my $result;
lives_ok { $result = $e->_compile_signature_isolated('myfunc', '(positional => [])') }
'does not croak when child produces nothing on stdout or stderr';
is($result, undef, 'returns undef for silent subprocess exit');
};
subtest 'SchemaExtractor::_compile_signature_isolated: non-JSON stdout -> return undef without croaking' => sub {
# Regression: decode_json() was called unconditionally on $stdout; when
# the child wrote a Perl warning or truncated output instead of valid JSON,
# the croak escaped Test::Builder's subtest eval and killed the process.
#
# Strategy: mock open3 so the "child" stdout returns garbage text.
my $e = bless { allow_signature_exec => 1, verbose => 0 }, 'App::Test::Generator::SchemaExtractor';
my $garbage = 'NOT VALID JSON AT ALL }{[]';
open my $fake_rdr, '<', \$garbage or die;
my $empty = '';
open my $fake_err, '<', \$empty or die;
t/generator-regression.t view on Meta::CPAN
# 7. Hashref generator regression
#--------------------------------------------------------------------------
lives_ok {
App::Test::Generator::_schema_to_lectrotest_generator(
'data',
{ type => 'hashref', min => 1, max => 3 }
);
} 'hashref schema generates LectroTest code';
#--------------------------------------------------------------------------
# 8. 'matches' patterns containing an unescaped '/' must not break out of
# the generated qr// delimiter and inject code into the generated test
#--------------------------------------------------------------------------
{
my $breakout = q{a/; system('touch /tmp/pwned'); qr/b};
my $code;
lives_ok {
$code = App::Test::Generator::_schema_to_lectrotest_generator(
'name',
{ type => 'string', matches => $breakout }
"unknown type 'widget' → fallback \"'value'\"");
};
# ==================================================================
# BENCHMARKGENERATOR — _quote_value()
#
# Four paths:
# undef → 'undef'
# numeric (looks_like_number) → returned as-is
# plain string → single-quoted
# string with single quote → escaped
# ==================================================================
sub _qv { App::Test::Generator::BenchmarkGenerator::_quote_value($_[0]) }
# --------------------------------------------------
# Path: undef → 'undef' (early return)
# --------------------------------------------------
subtest '_quote_value: undef → "undef"' => sub {
is(_qv(undef), 'undef', 'undef input → string "undef"');
};
};
# --------------------------------------------------
# Path: plain string → single-quoted
# --------------------------------------------------
subtest '_quote_value: plain string → single-quoted' => sub {
is(_qv('world'), "'world'", 'plain string wrapped in single quotes');
};
# --------------------------------------------------
# Path: string containing a single-quote → escaped
# "it's" → "'it\\'s'" via s/'/\\'/g
# --------------------------------------------------
subtest "_quote_value: string with embedded single-quote → escaped" => sub {
is(_qv("it's"), q{'it\'s'}, "single quote in string is backslash-escaped");
};
# ==================================================================
# BENCHMARKGENERATOR — _build_call() branch paths
#
# Two dimensions: positional vs named params × has_new × builtin
# named + has_new → $obj->func(k => v)
# named + !has_new → Module::func(k => v)
# pos + has_new → $obj->func(args)
# pos + !has_new + builtin → func(args) [covered by BenchmarkGenerator_unit.t]
unlike($src, qr/'positive'|'negative'/, 'no transform variants emitted');
diag($src) if $ENV{TEST_VERBOSE};
};
# ==================================================================
# ANALYZER::COMPLEXITY — additional CFG paths
#
# Uncovered branches in _strip_strings_and_comments and analyze():
# 'given'/'when' keywords in @BRANCH_TOKENS
# keyword inside a double-quoted string body → not counted
# escaped characters inside double-quoted string
# unmatched '}' when depth=0 → clamp prevents underflow
# exact early_returns boundary: 1 return → 0 early; 2 → 1 early
# ==================================================================
# --------------------------------------------------
# Path: 'given' keyword → branching point
# 'given' is in @BRANCH_TOKENS but not tested in Analyzer-Complexity.t
# --------------------------------------------------
subtest 'Complexity::analyze: "given" keyword → branching point' => sub {
my $r = _complexity_body('given($x) { do_thing(); }');
# --------------------------------------------------
# Path: 'die' inside a double-quoted string
# --------------------------------------------------
subtest 'Complexity::analyze: "die" inside double-quoted string → not counted' => sub {
my $r = _complexity_body('print "may die here";');
is($r->{exception_paths}, 0, '"die" inside dquote string is stripped → 0 exception paths');
};
# --------------------------------------------------
# Path: escaped double-quote inside a double-quoted string
# "said \"if\" here" — the content including the escaped quote is stripped
# --------------------------------------------------
subtest 'Complexity::analyze: escaped dquote inside string handled correctly' => sub {
my $r = _complexity_body(q{my $msg = "it said \"if\" here";});
is($r->{branching_points}, 0, 'escaped dquote: "if" inside string still stripped');
};
# --------------------------------------------------
# Path: unmatched '}' when depth=0
# Condition: `$depth-- if $depth > 0`
# When depth=0, the guard fires (false branch) → depth stays 0
# --------------------------------------------------
subtest 'Complexity::analyze: unmatched } when depth=0 → depth stays 0' => sub {
my $r = _complexity_body('my $x = 1; }');
is($r->{nesting_depth}, 0, 'unmatched } does not underflow depth to negative');
t/test-generator-index.t view on Meta::CPAN
# make_path/open touches the filesystem.
opendir(my $dh, $container) or die $!;
my @entries = grep { $_ ne '.' && $_ ne '..' } readdir $dh;
closedir $dh;
is_deeply(\@entries, ['reportdir'], 'no sibling directory created outside $dir');
};
subtest '_resolve_report_path() rejects a ".." segment buried mid-path' => sub {
my $dir = tempdir(CLEANUP => 1);
throws_ok(
sub { _resolve_report_path($dir, 'lib/../../escaped') },
qr/Refusing to report on suspicious file path/,
'.. anywhere in the path is rejected, not just a leading one'
);
};
# ==================================================================
# generate_reproduction_script
# Inline copy of the function from bin/test-generator-index so we
# can test it without executing the script's top-level code.
# ==================================================================
( run in 0.742 second using v1.01-cache-2.11-cpan-788537b7465 )