The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use warnings;
no warnings "deprecated";
use strict;

use Test::More tests => 19;
BEGIN { use_ok "Parse::Perl", qw(current_environment parse_perl); }

BEGIN { $SIG{__WARN__} = sub { die "WARNING: $_[0]" }; }

{
	package main;
	$main::env_m = main::current_environment;
	sub pkgname0() { "main" }
	sub pkgname1 { $main::pkgname1 = undef; return "main"; }
}

{
	package A;
	$main::env_A = main::current_environment;
	sub pkgname0() { "A" }
	sub pkgname1 { $main::pkgname1 = undef; return "A"; }
}

{
	package B;
	$main::env_B = main::current_environment;
	sub pkgname0() { "B" }
	sub pkgname1 { $main::pkgname1 = undef; return "B"; }
}

sub test_env($$$) {
	my($env, $override, $expect) = @_;
	@main::activity = ();
	parse_perl($env, q{
		}.(defined($override) ? "package $override;" : "").q{
		push @main::activity, [ __PACKAGE__, pkgname0(), pkgname1() ];
	})->();
	is_deeply \@main::activity, $expect;
}

test_env $main::env_m, undef, [[qw(main main main)]];
test_env $main::env_A, undef, [[qw(A A A)]];
test_env $main::env_B, undef, [[qw(B B B)]];
test_env $main::env_m, undef, [[qw(main main main)]];

test_env $main::env_m, "A", [[qw(A A A)]];
test_env $main::env_A, "A", [[qw(A A A)]];
test_env $main::env_B, "A", [[qw(A A A)]];

test_env $main::env_m, "B", [[qw(B B B)]];
test_env $main::env_A, "B", [[qw(B B B)]];
test_env $main::env_B, "B", [[qw(B B B)]];

test_env $main::env_B, "main", [[qw(main main main)]];
test_env $main::env_B, "A", [[qw(A A A)]];

sub test_env_n($$$) {
	my($env, $override, $expect) = @_;
	@main::activity = ();
	parse_perl($env, q{
		}.(defined($override) ? "package $override;" : "").q{
		push @main::activity, [ __PACKAGE__ ];
	})->();
	is_deeply \@main::activity, $expect;
}

SKIP: {
	skip "package not nullable on this Perl", 6 unless "$]" < 5.009;
	eval q{
		package;
		$main::env_0 = main::current_environment;
	}; die $@ if $@ ne "";
	test_env $main::env_0, "A", [[qw(A A A)]];
	test_env $main::env_0, "main", [[qw(main main main)]];
	test_env_n $main::env_0, undef, [[undef]];
	test_env_n $main::env_0, "", [[undef]];
	test_env_n $main::env_m, "", [[undef]];
	test_env_n $main::env_A, "", [[undef]];
}

1;