view release on metacpan or  search on metacpan

t/edge_cases.t  view on Meta::CPAN

	is( $h->{line}, 99, 'line key present with correct value' );
};

subtest 'Finding::icon -- returns bracketed string for all four valid severities' => sub {
	Readonly::Hash my %EXPECT => (
		$SEV_ERROR   => '[X]',
		$SEV_WARNING => '[!]',
		$SEV_PASS    => '[v]',
		$SEV_INFO    => '[i]',
	);
	for my $sev (keys %EXPECT) {
		my $f = _f(severity => $sev);
		is( $f->icon, $EXPECT{$sev}, "icon for $sev is $EXPECT{$sev}" );
	}
};

# ===========================================================================
# Context -- hostile inputs and path traversal
# ===========================================================================

subtest 'Context::new -- non-existent root croaks' => sub {
	throws_ok { $Context->new(root => '/no/such/path/xyz987abc') }
		qr/is not a directory/,
		'non-existent root rejected';
};

subtest 'Context::new -- plain file path as root croaks' => sub {
	# A file exists but is not a directory.
	my $tmp = File::Temp->new(UNLINK => 1);
	throws_ok { $Context->new(root => $tmp->filename) }
		qr/is not a directory/,
		'file path rejected as root';
};

subtest 'Context::has_file -- undef rel_path croaks' => sub {
	throws_ok { _ctx()->has_file(undef) }
		qr/requires a relative path/,
		'has_file(undef) croaks with documented error';
};

subtest 'Context::abs_path -- undef rel_path croaks' => sub {
	throws_ok { _ctx()->abs_path(undef) }
		qr/requires a relative path/,
		'abs_path(undef) croaks';
};

subtest 'Context::slurp -- undef rel_path croaks' => sub {
	throws_ok { _ctx()->slurp(undef) }
		qr/requires a relative path/,
		'slurp(undef) croaks';
};

subtest 'Context::slurp -- missing file croaks with documented error' => sub {
	throws_ok { _ctx()->slurp('no_such_file.pm') }
		qr/File not found/,
		'slurp of absent file croaks "File not found"';
};

# abs_path must reject paths with ".." components to prevent
# reading/checking files outside the distribution root.
subtest 'Context -- path traversal via abs_path is blocked' => sub {
	my $ctx = _ctx();
	throws_ok { $ctx->abs_path('../outside.txt') }
		qr/path traversal/i,
		'abs_path with leading ".." rejected';
	throws_ok { $ctx->abs_path('lib/../../outside.txt') }
		qr/path traversal/i,
		'abs_path with embedded ".." rejected';
};

subtest 'Context -- path traversal via has_file is blocked' => sub {
	my $ctx = _ctx();
	throws_ok { $ctx->has_file('../sibling') }
		qr/path traversal/i,
		'has_file with ".." component rejected';
};

subtest 'Context -- path traversal via slurp is blocked' => sub {
	my $ctx = _ctx();
	throws_ok { $ctx->slurp('../secret.txt') }
		qr/path traversal/i,
		'slurp with ".." component rejected';
};

subtest 'Context::perl_files -- non-existent dirs skipped silently' => sub {
	# An empty root with no lib/ or t/ must return an empty arrayref, not die.
	my $dir = tempdir(CLEANUP => 1);
	my $ctx = $Context->new(root => $dir);
	my $result;
	lives_ok { $result = $ctx->perl_files('lib', 't', 'nonexistent') }
		'missing dirs do not cause perl_files to die';
	returns_ok( $result, { type => 'arrayref' }, 'still returns arrayref' );
	is( scalar @{$result}, 0, 'empty arrayref for missing dirs' );
};

subtest 'Context::perl_files -- does not clobber outer $_' => sub {
	# File::Find localises $_ internally; we verify the outer value survives.
	my $ctx = _ctx(_distro('lib/A.pm' => '1;'));
	local $_ = 'sentinel_value';
	$ctx->perl_files;
	is( $_, 'sentinel_value', '$_ unchanged by perl_files' );
};

subtest 'Context::find_files -- undef dir argument croaks' => sub {
	throws_ok { _ctx()->find_files(undef) }
		qr/requires a directory/,
		'find_files(undef) croaks';
};

# ===========================================================================
# Report -- hostile add_findings inputs and empty-state rendering
# ===========================================================================

subtest 'Report::add_findings -- undef finding croaks' => sub {
	throws_ok { $Report->new->add_findings(undef) }
		qr/Expected an App::Project::Doctor::Finding/,
		'undef rejected by add_findings';
};

subtest 'Report::add_findings -- plain string croaks' => sub {
	throws_ok { $Report->new->add_findings('not a finding') }
		qr/Expected an App::Project::Doctor::Finding/,
		'string rejected by add_findings';
};

subtest 'Report::add_findings -- wrong blessed class croaks' => sub {
	# A blessed hashref that is not an ::Finding must be rejected.
	my $impostor = bless { severity => $SEV_ERROR, message => 'fake' }, 'FakeClass';
	throws_ok { $Report->new->add_findings($impostor) }
		qr/Expected an App::Project::Doctor::Finding/,
		'wrong-class object rejected';
};

subtest 'Report::add_findings -- no-arg call is a harmless no-op' => sub {
	my $r = $Report->new;
	lives_ok { $r->add_findings() } 'no-arg add_findings does not die';
	is( scalar($r->all_findings), 0, 'report stays empty' );
};

t/edge_cases.t  view on Meta::CPAN

};

subtest 'Fixer -- STDIN out-of-range index applies no fixes' => sub {
	my $applied = 0;
	my $r       = _report_with(_f(fix => sub { $applied++ }));
	my $out     = $EMPTY;
	my @w;
	my $count = _run_fixer_interactive($r, "99999\n", \$out, \@w);
	is( $count,   0, 'out-of-range index applies 0 fixes' );
	is( $applied, 0, 'fix coderef not called for index > max' );
};

subtest 'Fixer -- duplicate indices apply each fix exactly once' => sub {
	# Before the fix: "1,1,1" would call fix #1 three times.
	# After the fix: indices are deduplicated; fix #1 is called once.
	my $call_count = 0;
	my $r          = _report_with(_f(fix => sub { $call_count++ }));
	my $out        = $EMPTY;
	my @w;
	my $count = _run_fixer_interactive($r, "1,1,1\n", \$out, \@w);
	is( $call_count, 1, 'duplicate "1,1,1" applies fix exactly once (deduped)' );
	is( $count,      1, 'run returns 1 successful fix'                          );
};

subtest 'Fixer -- all-whitespace STDIN input applies no fixes' => sub {
	# "   " matches ^[\d,\s]+$ but splits to an empty list of indices.
	my $applied = 0;
	my $r       = _report_with(_f(fix => sub { $applied++ }));
	my $out     = $EMPTY;
	my @w;
	my $count = _run_fixer_interactive($r, "   \n", \$out, \@w);
	is( $applied, 0, 'whitespace-only index list applies no fixes' );
};

subtest 'Fixer -- non_interactive mode applies all fixes without STDIN' => sub {
	my @applied;
	my $r = $Report->new;
	for my $i (1 .. 3) {
		$r->add_findings(_f(fix => sub { push @applied, $i }));
	}
	my $fixer = $Fixer->new(report => $r, context => _ctx(), non_interactive => 1);
	my $out;
	open(local *STDOUT, '>', \$out) or die;
	my $count = $fixer->run;
	is( $count, 3, 'non_interactive mode applies all 3 fixes' );
	is( scalar @applied, 3, 'all 3 fix coderefs were called' );
};

# ===========================================================================
# Doctor -- code injection via check name and root detection
# ===========================================================================

subtest 'Doctor::run -- no root marker found croaks' => sub {
	# A directory without Makefile.PL / Build.PL / dist.ini / cpanfile.
	my $dir = tempdir(CLEANUP => 1);
	throws_ok { $Doctor->new(path => $dir)->run }
		qr/Cannot detect a distribution root/,
		'run croaks when no root marker is present';
};

subtest 'Doctor -- check name injection blocked before eval' => sub {
	# Before the fix: eval "require App::Project::Doctor::Check::Tests;
	# ++$main::INJECT_SENTINEL; 1" would execute the increment.
	# After the fix: names not matching /\A[A-Za-z][A-Za-z0-9]*\z/ are
	# rejected with a carp and skipped before the eval runs.
	local $INJECT_SENTINEL = 0;

	my $dir = _distro('Makefile.PL' => '');
	my $doctor = $Doctor->new(
		path   => $dir,
		checks => ['Tests; ++$main::INJECT_SENTINEL; 1'],
	);
	my ($out, @carped);
	{
		open(local *STDOUT, '>', \$out) or die;
		local $SIG{__WARN__} = sub { push @carped, $_[0] };
		eval { $doctor->run };
	}

	is( $INJECT_SENTINEL, 0, 'injected code was not executed' );
	ok( scalar @carped, 'invalid check name produces a carp warning' );
	like( join($EMPTY, @carped), qr/invalid|character/i,
		'warning message mentions invalid characters' );
	diag "carp: @carped" if $ENV{TEST_VERBOSE};
};

subtest 'Doctor -- check name with path separators is sanitised' => sub {
	# "../../etc/passwd" must be rejected before reaching eval.
	local $INJECT_SENTINEL = 0;

	my $dir = _distro('Makefile.PL' => '');
	my $doctor = $Doctor->new(
		path   => $dir,
		checks => ['../../etc/passwd'],
	);
	my ($out, @carped);
	{
		open(local *STDOUT, '>', \$out) or die;
		local $SIG{__WARN__} = sub { push @carped, $_[0] };
		eval { $doctor->run };
	}
	ok( 1, 'path-separator check name did not crash Doctor' );
	ok( scalar @carped, 'path-separator check name produces a carp' );
};

subtest 'Doctor::run -- preserves caller $@ across a failing check' => sub {
	# Doctor::run wraps check invocations in eval{}; caller $@ must survive.
	my $dir = _distro('Makefile.PL' => '');
	$@ = 'caller_sentinel';

	my $doctor = $Doctor->new(path => $dir, checks => ['Tests']);
	my ($out, @carped);
	{
		open(local *STDOUT, '>', \$out) or die;
		local $SIG{__WARN__} = sub { push @carped, $_[0] };
		my $g = mock_scoped 'App::Project::Doctor::Check::Tests::check'
			=> sub { die "deliberate failure\n" };
		$doctor->run;    # run catches the die internally; does not itself die
	}
	restore_all();