File Coverage

blib/lib/Portable/Config.pm

Criterion	Covered	Total	%
statement	18	56	32.1
branch	0	14	0.0
condition	0	6	0.0
subroutine	6	9	66.6
pod	0	2	0.0
total	24	87	27.5

package Portable::Config;

use 5.008;
use strict;
use warnings;
use Portable::FileSpec;

our $VERSION = '1.22';

#####################################################################
# Constructor

sub new {
	my $class  = shift;
	my $parent = shift;
	unless ( Portable::_HASH($parent->portable_config) ) {
		die('Missing or invalid config key in portable.perl');
	}

	# Create the object
	my $self = bless { }, $class;
	my $conf = $parent->portable_config;
	my $root = $parent->dist_root;
	foreach my $key ( sort keys %$conf ) {
		unless (
			defined $conf->{$key}
			and
			length $conf->{$key}
			and not
			$key =~ /^ld|^libpth$/
		) {
			$self->{$key} = $conf->{$key};
			next;
		}
		#join path to directory of portable perl with value from config file
		if ($key eq 'perlpath') {
		  $self->{$key} = Portable::FileSpec::catfile($root, split /\//, $conf->{$key});
		}
		else {
		  $self->{$key} = Portable::FileSpec::catdir($root, split /\//, $conf->{$key});
		}
	}
	foreach my $key ( grep { /^ld|^libpth$/ } keys %$self ) {
		#special handling of linker config variables and libpth
		next unless defined $self->{$key};
		$self->{$key} =~ s/\$(\w+)/$self->{$1}/g;
	}

	return $self;
}

sub apply {
	my $self   = shift;
	my $parent = shift;

	# Force all Config entries to load, so that
	# all Config_heavy.pl code has run, and none
	# of our values will be overwritten later.
	require Config;
	my $preload = { %Config::Config };

	# Shift the tie STORE method out the way
	SCOPE: {
		no warnings;
		*Config::_TEMP = *Config::STORE;
		*Config::STORE = sub {
			$_[0]->{$_[1]} = $_[2];
		};
	}

	# Write the values to the Config hash
	foreach my $key ( sort keys %$self ) {
		$Config::Config{$key} = $self->{$key};
	}

	# Restore the STORE method
	SCOPE: {
		no warnings;
		*Config::STORE = delete $Config::{_TEMP};
	}

	# Confirm we got all the paths
	my $volume = quotemeta $parent->dist_volume;
	foreach my $key ( sort keys %Config::Config ) {
		next unless defined $Config::Config{$key};
		next if     $Config::Config{$key} =~ /$volume/i;
		next unless $Config::Config{$key} =~ /\b[a-z]\:/i;
		die "Failed to localize \$Config::Config{$key} ($Config::Config{$key})";
	}

	return 1;
}

1;