view release on metacpan or  search on metacpan

t/function.t  view on Meta::CPAN

	# DB::DB() resolves $file through abs_path() before normalising, so
	# the cache/comparison key here must be built the same way -- using
	# _normalize(__FILE__) directly (skipping abs_path) would compare a
	# relative path against DB::DB()'s absolute one and never match
	my $this_file = Devel::App::Test::Generator::LCSAJ::Runtime::_normalize(Cwd::abs_path(__FILE__));
	ok(
		!exists $Devel::App::Test::Generator::LCSAJ::Runtime::HITS{$this_file},
		'a populated %TARGET that excludes this file suppresses recording for it'
	);

	%Devel::App::Test::Generator::LCSAJ::Runtime::TARGET = ($this_file => 1);
	my $hit_line = __LINE__ + 1;
	DB::DB();
	is(
		$Devel::App::Test::Generator::LCSAJ::Runtime::HITS{$this_file}{$hit_line},
		1,
		'adding this file to %TARGET allows the next call to record a hit for it'
	);
};

subtest 'Devel::App::Test::Generator::LCSAJ::Runtime::_write_results - skips IO when %HITS is empty' => sub {
	local %Devel::App::Test::Generator::LCSAJ::Runtime::HITS = ();

	my $make_path_calls = 0;
	Test::Mockingbird::mock(
		'Devel::App::Test::Generator::LCSAJ::Runtime',
		'make_path',
		sub { $make_path_calls++; return 1 },
	);
	Devel::App::Test::Generator::LCSAJ::Runtime::_write_results();
	is($make_path_calls, 0, '_write_results() returns immediately, before touching the filesystem, when %HITS is empty');
	Test::Mockingbird::unmock('Devel::App::Test::Generator::LCSAJ::Runtime', 'make_path');
};

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'
	);