App-Test-Generator
view release on metacpan or search on metacpan
t/function.t view on Meta::CPAN
};
}
# Allow access to private helpers via the package namespace
BEGIN {
use_ok('App::Test::Generator');
use_ok('App::Test::Generator::Mutator');
use_ok('App::Test::Generator::Mutant');
use_ok('App::Test::Generator::Exporter::YAML');
use_ok('App::Test::Generator::Analyzer::Return');
use_ok('App::Test::Generator::Analyzer::ReturnMeta');
use_ok('App::Test::Generator::Analyzer::Complexity');
use_ok('App::Test::Generator::Analyzer::SideEffect');
use_ok('App::Test::Generator::Planner::Mock');
use_ok('App::Test::Generator::Planner::Fixture');
use_ok('App::Test::Generator::Planner::Grouping');
use_ok('App::Test::Generator::Planner::Isolation');
use_ok('App::Test::Generator::Planner');
use_ok('App::Test::Generator::LCSAJ::Coverage');
use_ok('App::Test::Generator::LCSAJ');
use_ok('App::Test::Generator::Mutation::Base');
use_ok('App::Test::Generator::Mutation::ConditionalInversion');
use_ok('App::Test::Generator::Mutation::NumericBoundary');
use_ok('App::Test::Generator::Mutation::ReturnUndef');
use_ok('App::Test::Generator::Mutation::BooleanNegation');
use_ok('App::Test::Generator::TestStrategy');
use_ok('App::Test::Generator::Model::Method');
use_ok('App::Test::Generator::Sample::Module');
use_ok('Devel::App::Test::Generator::LCSAJ::Runtime');
use_ok('App::Test::Generator::Emitter::Perl');
use_ok('App::Test::Generator::Template');
use_ok('App::Test::Generator::SchemaExtractor');
}
# --------------------------------------------------
# Constants used across multiple subtests to avoid
# magic literals and make intent clear
# --------------------------------------------------
Readonly my $EMPTY_STRING => '';
Readonly my $UNDEF_LITERAL => 'undef';
# --------------------------------------------------
# Mirrors of the boundary constants private to
# App::Test::Generator::Sample::Module, so its
# boundary tests below avoid magic numbers without
# requiring the module to export its internals
# --------------------------------------------------
Readonly my $SAMPLE_MIN_EMAIL_LEN => 5;
Readonly my $SAMPLE_MAX_EMAIL_LEN => 254;
Readonly my $SAMPLE_MIN_BIRTH_YEAR => 1900;
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
# --------------------------------------------------
# Tests for the top-level value quoter that produces
# Perl source-code literals for any scalar type
# ==================================================================
subtest 'perl_quote' => sub {
my $fn = \&App::Test::Generator::perl_quote;
# Undef always produces the bare word 'undef'
is($fn->(undef), $UNDEF_LITERAL, 'undef produces undef literal');
# YAML boolean strings must round-trip to Perl boolean constants
is($fn->('true'), '!!1', 'true produces !!1');
is($fn->('false'), '!!0', 'false produces !!0');
# Integers are emitted unquoted for numeric comparison
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');
# Regexp objects are rendered as qr{} with modifiers
my $re = qr/foo/i;
like($fn->($re), qr/qr\{foo\}i/, 'Regexp rendered as qr{}');
# Regexp without modifiers has no trailing flags
my $re2 = qr/bar/;
like($fn->($re2), qr/qr\{bar\}/, 'Regexp without modifiers');
done_testing();
};
# ==================================================================
# q_wrap
# --------------------------------------------------
# Tests for the string wrapper that chooses the most
# readable q{} delimiter form
# ==================================================================
subtest 'q_wrap' => sub {
my $fn = \&App::Test::Generator::q_wrap;
# Undef returns empty single-quoted string — q_wrap is a
# string quoter, not a value serialiser, so undef means
# no string value rather than the Perl literal 'undef'
is($fn->(undef), "''", 'undef returns empty single-quoted string');
# Plain string uses the preferred q{} bracket form
is($fn->('hello'), 'q{hello}', 'plain string uses q{}');
# String containing { forces a different bracket pair
my $with_brace = 'a{b';
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 {
my $fn = \&App::Test::Generator::render_fallback;
# Undef produces the literal string 'undef'
is($fn->(undef), $UNDEF_LITERAL, 'undef produces undef literal');
# Integer scalars pass through Dumper in terse mode
my $scalar_result = $fn->(42);
is($scalar_result, '42', 'integer scalar');
# Hashrefs are rendered as Perl hash literals with braces
my $hash_result = $fn->({ a => 1 });
like($hash_result, qr/\{/, 'hashref renders with braces');
like($hash_result, qr/'a'/, 'hashref key present');
# No trailing newline — Dumper adds one and we strip it
unlike($fn->({ a => 1 }), qr/\n$/, 'no trailing newline');
# Arrayrefs render with square brackets
my $arr_result = $fn->([1, 2]);
like($arr_result, qr/\[/, 'arrayref renders with brackets');
done_testing();
};
# ==================================================================
# render_args_hash
# --------------------------------------------------
# Tests for the flat hashref renderer used for output
# specs and constructor argument lists
# ==================================================================
subtest 'render_args_hash' => sub {
my $fn = \&App::Test::Generator::render_args_hash;
# Undef input returns empty string
is($fn->(undef), $EMPTY_STRING, 'undef returns empty string');
# Non-hash input returns empty string
is($fn->([1, 2]), $EMPTY_STRING, 'arrayref returns empty string');
# Empty hash returns empty string
is($fn->({}), $EMPTY_STRING, 'empty hash returns empty string');
# Single key-value pair is rendered correctly
my $result = $fn->({ type => 'string' });
like($result, qr/'type'\s*=>\s*'string'/, 'single key rendered');
# Multiple keys are sorted alphabetically for deterministic output
my $multi = $fn->({ b => 2, a => 1 });
my $a_pos = index($multi, "'a'");
my $b_pos = index($multi, "'b'");
t/function.t view on Meta::CPAN
},
'analyze() report matches documented hashref shape',
);
is($clean_report->{stability_score}, 100, 'clean schema scores full stability');
is($clean_report->{consistency_score}, 100, 'clean schema scores full consistency');
is_deeply($clean_report->{risk_flags}, [], 'clean schema raises no risk flags');
# A boolean return with no other risk stays clamped at 100 -- the
# bonus is documented as a no-op here, not an over-100 value silently
# clamped down, so this also guards against the clamp being removed
my $boolean_report = $analyser->analyze({ output => { type => 'boolean' } });
is($boolean_report->{stability_score}, 100, 'boolean bonus is a no-op when already at 100');
# Combine the implicit-undef penalty with the boolean bonus to prove
# the bonus does take effect once stability has actually been reduced
my $combined_report = $analyser->analyze({
output => {
type => 'boolean',
_error_handling => { implicit_undef => 1 },
},
});
is(
$combined_report->{stability_score},
100 - $PENALTY_IMPLICIT_UNDEF_STABILITY + $BONUS_BOOLEAN_STABILITY,
'boolean bonus applies on top of an already-reduced stability score',
);
is_deeply($combined_report->{risk_flags}, ['implicit_error_return'], 'implicit_error_return flag recorded');
diag("combined report: stability=$combined_report->{stability_score} consistency=$combined_report->{consistency_score}")
if $ENV{TEST_VERBOSE};
# risk_flags is a fresh arrayref per call with no back-reference
# to the schema or the analyser, so no cycle should be detectable
memory_cycle_ok($combined_report, 'analyze() report has no reference cycles');
};
# ==================================================================
# App::Test::Generator::Analyzer::Complexity
# --------------------------------------------------
# t/Analyzer-Complexity.t already covers analyze()'s
# public behaviour in depth (branching, exceptions,
# nesting, classification, string/comment stripping
# indirectly). What it does not do is call the private
# helper _strip_strings_and_comments directly -- the
# skill explicitly requires testing internal helpers in
# isolation, so that is the focus here, plus the
# Test::Returns schema-shape check on analyze()'s report.
# ==================================================================
subtest 'Analyzer::Complexity - _strip_strings_and_comments isolated behaviour' => sub {
my $fn = \&App::Test::Generator::Analyzer::Complexity::_strip_strings_and_comments;
# 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();
};
subtest 'Analyzer::Complexity - new and analyze report shape' => sub {
my $analyser = App::Test::Generator::Analyzer::Complexity->new();
isa_ok($analyser, 'App::Test::Generator::Analyzer::Complexity', 'new() returns correct class');
my $method = { body => 'sub foo { if ($x) { return 1; } return 0; }' };
my $report = $analyser->analyze($method);
returns_ok(
$report,
{
type => 'hashref',
schema => {
cyclomatic_score => { type => 'integer' },
branching_points => { type => 'integer' },
early_returns => { type => 'integer' },
exception_paths => { type => 'integer' },
nesting_depth => { type => 'integer' },
complexity_level => { type => 'string' },
},
},
'analyze() report matches documented hashref shape',
);
diag("complexity report: $report->{complexity_level} (score=$report->{cyclomatic_score})")
if $ENV{TEST_VERBOSE};
# The report hashref holds only plain scalars, so no cycle is possible;
# this guards against a future change that embeds $method or $self in it
memory_cycle_ok($report, 'analyze() report has no reference cycles');
# Method argument missing a body key entirely must not die --
# documented via the "//= ''" default in the source
lives_ok { $analyser->analyze({}) } 'analyze() tolerates a method hashref with no body key';
done_testing();
};
# ==================================================================
# App::Test::Generator::Analyzer::SideEffect
# --------------------------------------------------
# t/Analyzer-SideEffect.t already covers analyze()'s
# public flags and purity classification thoroughly,
# including string/comment false-positive avoidance.
# This module ships its own copy of
# _strip_strings_and_comments (duplicated-by-design
# from Analyzer::Complexity per CLAUDE.md's "shared-by-
# duplication helper" convention elsewhere in this
# codebase) -- exercised directly here since it has not
# been called by its fully-qualified name anywhere else.
# ==================================================================
t/function.t view on Meta::CPAN
subtest 'Devel::App::Test::Generator::LCSAJ::Runtime::_write_results - writes a well-formed per-PID JSON file' => sub {
my $orig_cwd = getcwd();
my $tmp = File::Temp::tempdir(CLEANUP => 1);
local %Devel::App::Test::Generator::LCSAJ::Runtime::HITS = (
'lib/Foo/Bar.pm' => { 10 => 3, 12 => 1 },
);
eval {
chdir $tmp or die "cannot chdir to $tmp: $!";
Devel::App::Test::Generator::LCSAJ::Runtime::_write_results();
};
my $err = $@;
chdir $orig_cwd or croak "cannot chdir back to $orig_cwd: $!";
is($err, '', '_write_results() does not die for a normal, writable target') or diag($err);
my $out_file = "$tmp/cover_html/lcsaj_hits/hits_$$.json";
ok(-e $out_file, 'a per-PID JSON file is written under cover_html/lcsaj_hits, named with the current PID');
no autodie qw(open);
open my $fh, '<', $out_file or croak "cannot read back $out_file: $!";
local $/;
my $content = <$fh>;
close $fh;
my $decoded = decode_json($content);
is_deeply(
$decoded,
{ 'lib/Foo/Bar.pm' => { 10 => 3, 12 => 1 } },
'the written JSON round-trips back to the exact %HITS structure that was serialised'
);
memory_cycle_ok(\%Devel::App::Test::Generator::LCSAJ::Runtime::HITS, '%HITS holds no circular references');
};
subtest 'Devel::App::Test::Generator::LCSAJ::Runtime::_write_results - croaks with the documented message when open() fails' => sub {
my $orig_cwd = getcwd();
my $tmp = File::Temp::tempdir(CLEANUP => 1);
local %Devel::App::Test::Generator::LCSAJ::Runtime::HITS = (
'lib/Foo/Bar.pm' => { 10 => 1 },
);
eval {
chdir $tmp or die "cannot chdir to $tmp: $!";
# Pre-create the exact target path as a directory, not a file --
# open() for write against a directory portably fails on every
# platform this module supports, without relying on chmod-based
# 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;
# List-form system() under capture_merged(), not qx{}/backticks --
# qx{} always goes through a shell, and a shell-quoted '...' -e
# argument that works under sh/bash is invalid syntax for
# cmd.exe on Windows (single quotes are not its quoting
# character), which previously made the child perl process fail
# to parse its own -e script.
my @inc_args = map { ('-I', $_) } @INC;
my $code = 'print join(q{,}, sort keys %Devel::App::Test::Generator::LCSAJ::Runtime::TARGET)';
my ($output, $exit) = capture_merged {
system($^X, @inc_args, '-MDevel::App::Test::Generator::LCSAJ::Runtime', '-e', $code);
};
is($exit, 0, 'the child process exits cleanly') or diag($output);
is(
$output,
'lib/Bar.pm,lib/Foo.pm',
'LCSAJ_TARGETS entries are normalised (blib/lib and lib stripped) and stray trailing newlines are removed'
);
};
# Clear %HITS so this module's END block (_write_results) does not write
# a stray hits_$$.json file into the real project tree when this test
# script itself exits
%Devel::App::Test::Generator::LCSAJ::Runtime::HITS = ();
# --------------------------------------------------
# App::Test::Generator::Emitter::Perl
#
# t/Emitter-Perl.t and t/Emitter-Perl_unit.t already exhaustively cover
# every emitted code block and every plan-flag combination, but use only
# loose (unanchored) regex matches on croak messages and never use
# Test::Mockingbird, Test::Returns, or Test::Memory::Cycle. These
# subtests add: exact (anchored) croak-message assertions, dispatch-only
# isolation of _emit_method_tests() via mocking every _emit_*_test sub
# (so the dispatch logic is verified independently of what those subs
# actually emit), the never-before-tested predicate_test flag, the
# never-before-tested case of a method entirely absent from %schema,
# and returns_ok/memory_cycle_ok coverage.
# --------------------------------------------------
subtest 'Emitter::Perl::new - exact croak messages' => sub {
throws_ok { App::Test::Generator::Emitter::Perl->new(plans => {}, package => 'Foo') }
qr/^schema required at /, 'missing schema croaks with the exact documented message';
throws_ok { App::Test::Generator::Emitter::Perl->new(schema => {}, package => 'Foo') }
qr/^plans required at /, 'missing plans croaks with the exact documented message';
throws_ok { App::Test::Generator::Emitter::Perl->new(schema => {}, plans => {}) }
qr/^package required at /, 'missing package croaks with the exact documented message';
my $bad_package = "Evil'); system('touch /tmp/pwned'); #";
throws_ok { App::Test::Generator::Emitter::Perl->new(schema => {}, plans => {}, package => $bad_package) }
qr/^package '\Q$bad_package\E' is not a valid Perl package name at /,
t/function.t view on Meta::CPAN
package => 'My::Module',
);
my $code = $emitter->emit();
returns_ok($code, { type => 'string' }, 'emit() returns a string');
like($code, qr/done_testing\(\);\s*\z/, 'emit() output ends with the done_testing() footer');
memory_cycle_ok($emitter, 'emit() leaves the emitter free of circular references');
};
# ==================================================================
# App::Test::Generator::Template
#
# This module's own package code is a single thin wrapper,
# get_data_section(), around Data::Section::Simple::get_data_section().
# Everything else in the .pm file is __DATA__ template text (test.tt)
# rendered into *generated* downstream test files at runtime -- those
# embedded helper subs (rand_str, fuzz_inputs, etc.) never belong to the
# App::Test::Generator::Template namespace, so they are out of scope
# here; t/app.t exercises them indirectly by rendering and running the
# generated harnesses. t/Template.t and t/Template_unit.t already cover
# both call styles and the unknown-template/undef-argument cases by
# value, so this section adds only what those files do not: a mocked
# dispatch-isolation test pinning down exactly which arguments reach
# Data::Section::Simple::get_data_section() for each call style, plus
# Test::Returns/Test::Memory::Cycle coverage.
# ==================================================================
subtest 'Template::get_data_section - dispatch isolation via mocked Data::Section::Simple' => sub {
my @captured;
Test::Mockingbird::mock(
'Data::Section::Simple::get_data_section',
sub { @captured = @_; return 'mocked-content'; },
);
@captured = ();
App::Test::Generator::Template->get_data_section('test.tt');
is_deeply(\@captured, ['test.tt'],
'class-method call strips the leading class name before delegating, passing on only the template name');
@captured = ();
App::Test::Generator::Template::get_data_section('test.tt');
is_deeply(\@captured, ['test.tt'],
'plain function call passes the template name through unchanged');
@captured = ();
App::Test::Generator::Template::get_data_section();
is_deeply(\@captured, [undef],
'a no-argument call still forwards a single undef element, since $_[0] is read (not shifted) when it is not the package name');
Test::Mockingbird::unmock('Data::Section::Simple::get_data_section');
};
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');
};
subtest 'Generator::_assert_identifier - package => 1 additionally allows "::" separators' => sub {
my $fn = \&App::Test::Generator::_assert_identifier;
is($fn->('Foo::Bar', 'module', package => 1), 'Foo::Bar',
'a "::"-separated package name is accepted when package => 1');
is($fn->('DB::DB', 'function', package => 1), 'DB::DB',
'a fully-qualified sub name such as DB::DB is accepted when package => 1');
throws_ok { $fn->('Foo::Bar', 'module') } qr/^App::Test::Generator: module 'Foo::Bar' is not a valid Perl identifier at /,
'without package => 1, a "::"-separated name is rejected with the exact documented message';
};
subtest 'Generator::_assert_identifier - croaks with the exact message for missing or empty names' => sub {
my $fn = \&App::Test::Generator::_assert_identifier;
throws_ok { $fn->(undef, 'module') } qr/^App::Test::Generator: module is missing or empty at /,
'undef name croaks with the exact documented message';
throws_ok { $fn->('', 'function') } qr/^App::Test::Generator: function is missing or empty at /,
'empty-string name croaks with the exact documented message';
};
subtest 'Generator::_assert_identifier - rejects injection payloads even with package => 1' => sub {
my $fn = \&App::Test::Generator::_assert_identifier;
for my $payload ("Foo'; system('rm -rf /'); '", 'Foo::Bar()', 'Foo::Bar; 1', 'Foo Bar', '1Foo') {
throws_ok { $fn->($payload, 'module', package => 1) }
qr/^App::Test::Generator: module '\Q$payload\E' is not a valid Perl identifier at /,
"payload '$payload' is rejected even with package => 1";
}
};
subtest 'Generator::_assert_identifier - return value shape' => sub {
my $fn = \&App::Test::Generator::_assert_identifier;
returns_ok($fn->('foo', 'name'), { type => 'string' }, '_assert_identifier() returns a plain string on success');
};
# ==================================================================
# App::Test::Generator::_perl_quote - circular-reference depth guard
#
# The depth > 100 croak in _perl_quote() is unreachable through any
# single-level call from the public perl_quote() wrapper (which always
# starts at depth 0), but is reachable legitimately by feeding
# perl_quote() a sufficiently deep arrayref-of-arrayrefs -- no need to
# call the private _perl_quote() directly with a fabricated depth.
# ==================================================================
subtest 'Generator::perl_quote - croaks on a structure nested past the recursion limit' => sub {
Readonly my $DEPTH_BEYOND_LIMIT => 101;
t/function.t view on Meta::CPAN
my $info = $e->_detect_external_object_dependency(q{ my $ua = LWP::UserAgent->new; $ua->get($url); });
is_deeply($info->{uses_objects}, ['LWP::UserAgent'], 'the class of the object variable is inferred from its assignment');
};
subtest 'SchemaExtractor::_detect_external_object_dependency - returns undef for an undef or dependency-free body' => sub {
my $e = bless {}, 'App::Test::Generator::SchemaExtractor';
is($e->_detect_external_object_dependency(undef), undef, 'an undef method body returns undef immediately');
is($e->_detect_external_object_dependency('return 1;'), undef, 'a body with no external object usage returns undef');
};
subtest 'SchemaExtractor::_extract_default_value - extracts a default from each of several common assignment idioms' => sub {
my $e = bless {}, 'App::Test::Generator::SchemaExtractor';
is($e->_extract_default_value('timeout', '$timeout = $timeout || 30;'), 30, 'Pattern 1: $param = $param || value');
is($e->_extract_default_value('x', '$x //= 5;'), 5, 'Pattern 2: $param //= value');
is($e->_extract_default_value('x', q{$x ||= 'foo';}), 'foo', 'Pattern 5: $param ||= value, with quotes stripped');
is($e->_extract_default_value('x', '$x = 1;'), undef, 'a plain assignment with none of the eight idioms returns undef');
};
subtest 'SchemaExtractor::_extract_default_value - returns undef for missing param or code' => sub {
my $e = bless {}, 'App::Test::Generator::SchemaExtractor';
is($e->_extract_default_value(undef, '$x = 1;'), undef, 'undef param returns undef');
is($e->_extract_default_value('x', undef), undef, 'undef code returns undef');
is($e->_extract_default_value('x', ''), undef, 'empty code returns undef');
};
subtest 'SchemaExtractor::_compile_signature_isolated: empty stdout and empty stderr -> return undef without croaking' => sub {
# Regression: when the child subprocess is killed by SIGKILL (e.g. the
# kernel OOM killer) before it writes anything, $stdout and $stderr are
# both empty strings. Before the fix, decode_json('') croaked with
# "malformed JSON string" and the exception propagated through the
# Test::Builder subtest boundary, killing the test process with exit 255.
#
# Strategy: mock open3 in the consuming namespace so the "child" returns
# empty filehandles without spawning a real process. waitpid($$, 0) on
# our own PID returns -1 immediately (not our child), which is harmless.
my $e = bless { allow_signature_exec => 1, verbose => 0 }, 'App::Test::Generator::SchemaExtractor';
my $empty = '';
open my $fake_rdr, '<', \$empty or die;
open my $fake_err, '<', \$empty or die;
no warnings 'redefine';
local *App::Test::Generator::SchemaExtractor::open3 = sub {
$_[0] = do { open my $fh, '>', \my $buf; $fh }; # writable stdin for child
$_[1] = $fake_rdr; # stdout: empty
$_[2] = $fake_err; # stderr: empty
return $$; # our own PID → waitpid returns -1 quickly
};
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;
no warnings 'redefine';
local *App::Test::Generator::SchemaExtractor::open3 = sub {
$_[0] = do { open my $fh, '>', \my $buf; $fh };
$_[1] = $fake_rdr;
$_[2] = $fake_err;
return $$;
};
my $result;
lives_ok { $result = $e->_compile_signature_isolated('myfunc', '(positional => [])') }
'does not croak when child stdout is non-JSON';
is($result, undef, 'returns undef for non-JSON subprocess output');
};
subtest 'SchemaExtractor::_log - prints to stdout only when verbose is true' => sub {
my $e = bless { verbose => 1 }, 'App::Test::Generator::SchemaExtractor';
my $stdout = capture_stdout { $e->_log('hello world') };
is($stdout, "hello world\n", 'message is printed with a trailing newline when verbose is set');
$e->{verbose} = 0;
$stdout = capture_stdout { $e->_log('should not appear') };
is($stdout, '', 'nothing is printed when verbose is false');
};
done_testing();
( run in 1.622 second using v1.01-cache-2.11-cpan-788537b7465 )