view release on metacpan or  search on metacpan

t/test-generator-index.t  view on Meta::CPAN

	);
}

# confidence_score — returns (score, label) pair
sub confidence_score {
	my (%args) = @_;
	my $fail = $args{fail} // 0;
	my $pass = $args{pass} // 0;
	return (0, 'none') if ($fail + $pass) == 0;
	my $score = $fail / ($fail + $pass);
	my $med   = 0.90;
	my $low   = 0.70;
	my $label =
		$score >= $med ? 'strong'   :
		$score >= $low ? 'moderate' :
		'weak';
	return ($score, $label);
}

# perldelta_url — constructs perldoc URL for a version
sub perldelta_url {
	my ($v) = @_;
	my ($maj, $min) = "$v" =~ /^v?(\d+)\.(\d+)/;
	return "https://perldoc.perl.org/perl${maj}${min}0delta";
}

# _resolve_report_path — mirrors the path-traversal guard added to
# _mutant_file_report() in bin/test-generator-index: rejects any '..'
# segment in $file, then confirms the directory-preserving join of
# $dir and $file resolves to somewhere under $dir before returning it.
sub _resolve_report_path {
	my ($dir, $file) = @_;

	die "Refusing to report on suspicious file path: $file\n"
		if grep { $_ eq File::Spec->updir } File::Spec->splitdir($file);

	my $relative_path = File::Spec->catfile($dir, $file . '.html');
	my $out_dir = dirname($relative_path);

	make_path($out_dir) unless -d $out_dir;

	my $resolved_dir = abs_path($dir) // $dir;
	my $resolved_out = abs_path($out_dir) // $out_dir;
	die "Refusing to write report outside $dir: $relative_path\n"
		unless index($resolved_out, $resolved_dir) == 0;

	return $relative_path;
}

# ==================================================================
# parse_version
# ==================================================================

subtest 'parse_version() returns a version object for valid strings' => sub {
	my $v = parse_version('5.036000');
	ok(defined $v, '5.036000 parsed');
	ok($v->stringify, 'version object stringifies');
};

subtest 'parse_version() returns undef for garbage' => sub {
	my $v = parse_version('not_a_version');
	ok(!defined $v, 'garbage returns undef');
};

subtest 'parse_version() supports comparison operators' => sub {
	my $old = parse_version('5.034000');
	my $new = parse_version('5.036000');
	ok($new > $old, '5.036 > 5.034');
	ok($old < $new, '5.034 < 5.036');
};

subtest 'parse_version() handles v-string format' => sub {
	my $v = parse_version('v5.36.0');
	ok(defined $v, 'v-string format parsed');
};

# ==================================================================
# extract_perl_versions
# ==================================================================

subtest 'extract_perl_versions() returns empty list for empty reports' => sub {
	my @v = extract_perl_versions([]);
	is(scalar @v, 0, 'empty reports -> empty list');
};

subtest 'extract_perl_versions() skips reports with no perl field' => sub {
	my @v = extract_perl_versions([
		{ osname => 'linux' },
		{ perl => '5.036000', osname => 'linux' },
	]);
	is(scalar @v, 1, 'one version extracted, no-perl report skipped');
};

subtest 'extract_perl_versions() returns version objects' => sub {
	my @v = extract_perl_versions([
		{ perl => '5.036000' },
		{ perl => '5.034003' },
	]);
	is(scalar @v, 2, 'two versions extracted');
	ok($v[0]->stringify, 'first is a version object');
	ok($v[1]->stringify, 'second is a version object');
};

# ==================================================================
# detect_perl_version_cliff
# ==================================================================

subtest 'detect_perl_version_cliff() returns undef for empty reports' => sub {
	ok(!defined detect_perl_version_cliff([], []),
		'empty inputs -> undef');
};

subtest 'detect_perl_version_cliff() returns undef when only fail reports' => sub {
	my @fails = ({ perl => '5.034003' });
	ok(!defined detect_perl_version_cliff(\@fails, []),
		'no pass reports -> undef');
};

subtest 'detect_perl_version_cliff() returns undef when only pass reports' => sub {
	my @passes = ({ perl => '5.036000' });
	ok(!defined detect_perl_version_cliff([], \@passes),