use strict;
use warnings;

package Whitelist;

# FILENAME: Whitelist.pm
# CREATED: 12/04/12 06:33:42 by Kent Fredric (kentnl) <kentfredric@gmail.com>
# ABSTRACT: A basic test whitelist
use Carp qw( confess );

sub new {
	my ( $class, @args ) = @_;
	return bless { args => \@args }, $class;
}

sub whitelist {
	my ( $self, @args ) = @_;
	die 'Frozen' if $self->{frozen};
	$self->{whitelist} = [] unless exists $self->{whitelist};
	$self->{load}      = [] unless exists $self->{load};

	push @{ $self->{whitelist} }, @args;
	push @{ $self->{load} },      @args;

}

sub noload_whitelist {
	my ( $self, @args ) = @_;
	die 'Frozen' if $self->{frozen};
	$self->{whitelist} = [] unless exists $self->{whitelist};
	push @{ $self->{whitelist} }, @args;
}

sub freeze {
	my ($self) = @_;
	$self->{module_whitelist} = {};
	$self->{whitelist_inc}    = {};
	require Module::Runtime;
	for my $lib ( @{ $self->{load} } ) {
		Module::Runtime::require_module($lib);
	}
	for my $lib ( @{ $self->{whitelist} } ) {
		my $nn = Module::Runtime::module_notional_filename($lib);
		$self->{module_whitelist}->{$nn} = 1;
		$self->{whitelist_inc}->{$nn} = $INC{$nn} if exists $INC{$nn};
	}
	$self->{frozen}   = 1;
	$self->{real_inc} = {%INC};
}

sub checker {
	my ($self) = @_;
	my $dumper = sub {
		my $dump_hash = sub {
			my $hash   = shift;
			my $prefix = shift;
			$prefix = "  " if not defined $prefix;
			return qq[{\n$prefix] . ( join qq{,\n$prefix}, map { $_ . ' => ' . $hash->{$_} } keys %{$hash} ) . qq[\n}];
		};
		my $string_values = sub {
			my $hash = shift;
			return { map { $_, 'q{' . $hash->{$_} . '}' } keys %{$hash} };
		};

		return $dump_hash->(
			{
				real_inc         => $dump_hash->( $string_values->( $self->{real_inc}, ),         "    " ),
				whitelist_inc    => $dump_hash->( $string_values->( $self->{whitelist_inc}, ),    "    " ),
				module_whitelist => $dump_hash->( $string_values->( $self->{module_whitelist}, ), "    " ),

			}
		);
	};

	my $coderef;
	$coderef = sub {
		my ( $code, $filename ) = @_;
		return if exists $self->{module_whitelist}->{$filename};
		confess( "$filename requested but not whitelisted:\n " . $dumper->() );
	};

}
1;

