view release on metacpan or  search on metacpan

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

# ==================================================================

subtest 'perldelta_url() returns a perldoc URL' => sub {
	my $url = perldelta_url('5.36.0');
	like($url, qr{https://perldoc\.perl\.org/perl}, 'contains perldoc domain');
	like($url, qr/delta$/, 'ends with delta');
};

subtest 'perldelta_url() extracts major and minor correctly' => sub {
	my $url = perldelta_url('5.36.0');
	like($url, qr/perl5360delta/, 'perl5360delta in URL');
};

subtest 'perldelta_url() handles version object input' => sub {
	my $v   = parse_version('5.038000');
	my $url = perldelta_url($v);
	like($url, qr/perl5/, 'URL contains perl5');
	like($url, qr/delta/, 'URL contains delta');
};

subtest 'perldelta_url() different versions produce different URLs' => sub {
	my $u1 = perldelta_url('5.034000');
	my $u2 = perldelta_url('5.036000');
	isnt($u1, $u2, 'different versions produce different URLs');
};

# ==================================================================
# _resolve_report_path (path-traversal guard regression tests)
# ==================================================================

subtest '_resolve_report_path() accepts a normal lib/ path, preserving structure' => sub {
	my $dir = tempdir(CLEANUP => 1);
	my $path = _resolve_report_path($dir, 'lib/Foo/Bar.pm');
	is($path, File::Spec->catfile($dir, 'lib/Foo/Bar.pm.html'), 'directory structure preserved under $dir');
	ok(-d dirname($path), 'intermediate directories created');
};

subtest '_resolve_report_path() rejects a file containing a ".." segment' => sub {
	my $container = tempdir(CLEANUP => 1);
	my $dir = File::Spec->catdir($container, 'reportdir');
	mkdir $dir or die $!;

	throws_ok(
		sub { _resolve_report_path($dir, '../../etc/cron.d/evil') },
		qr/Refusing to report on suspicious file path/,
		'.. segment is rejected before any path is built'
	);

	# Nothing besides the pre-existing reportdir/ should have been
	# created in $container — confirms the guard fires before any
	# 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.
# ==================================================================

sub generate_reproduction_script {
	my ($dist, $version, $report, $installed_mods, $outdir) = @_;

	my $guid     = $report->{guid}     or return;
	my $perl     = $report->{perl}     // 'unknown';
	my $os       = $report->{osname}   // 'unknown';
	my $reporter = $report->{reporter} // '';
	$reporter =~ s/"//g;
	$reporter =~ s/<[^>]+>//g;
	$reporter =~ s/\s+$//g;

	my $repro_dir  = File::Spec->catdir($outdir, 'reproduce');
	make_path($repro_dir) unless -d $repro_dir;

	my $script_name = "reproduce-$guid.sh";
	my $script_path = File::Spec->catfile($repro_dir, $script_name);

	open my $fh, '>', $script_path or return;

	print $fh "#!/bin/sh\n";
	print $fh "# Reproduction script for CPAN Testers report $guid\n";
	print $fh "# Distribution: $dist-$version\n";
	print $fh "# Perl: $perl  OS: $os\n";
	print $fh "# Reporter: $reporter\n";
	print $fh "# Report: https://www.cpantesters.org/cpan/report/$guid\n";
	print $fh "# Generated by test-generator-index (App::Test::Generator)\n";
	print $fh "set -e\n\n";
	print $fh "# Use Perl $perl (perlbrew / plenv recommended)\n";
	print $fh "# perlbrew install perl-$perl && perlbrew use perl-$perl\n\n";

	if(%$installed_mods) {
		print $fh "# Install exact dependency versions from the failing report\n";
		my @mod_lines = map { "\t'$_\@$installed_mods->{$_}'" }
		                sort keys %$installed_mods;
		print $fh "cpanm --notest \\\n", join(" \\\n", @mod_lines), "\n\n";
	}

	print $fh "# Install and test the failing distribution\n";
	print $fh "cpanm --look $dist\@$version\n";
	print $fh "# or from a local checkout: perl Makefile.PL && make && make test\n";

	close $fh;
	chmod 0755, $script_path;

	return $script_name;
}

subtest 'generate_reproduction_script() returns undef when report has no guid' => sub {
	my $dir = tempdir(CLEANUP => 1);