File Coverage

blib/lib/Module/Which/P5Path.pm

Criterion	Covered	Total	%
statement	52	63	82.5
branch	13	18	72.2
condition	1	2	50.0
subroutine	12	15	80.0
pod	3	3	100.0
total	81	101	80.2

package Module::Which::P5Path;
$Module::Which::P5Path::VERSION = '0.04';
use 5.006;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);
our @EXPORT_OK = qw(path_to_p5path path_to_p5 p5path_to_path);

use Config;
require File::Spec::Unix; # qw(splitdir catdir);
require File::Spec;

# NOTE. To map config vars to their values, like this
#    ('archlib', 'perlpath') => ( $Config{archlib}, $Config{perlpath} )
# we only need the expression "@Config{@_}".

# my @vars = _purge_vars('a', 'b', 'c')
# Purges a list of Config variable names by eliminating those with
# false and duplicate values. The original order is preserved.
sub _purge_vars {
	my @vars;
	my %h;
	for my $val (@Config{@_}) {
		my $var = shift @_;
		next unless $val; # skip undefs and ''
		unless ($h{$val}++) { # keep only the first occurrence of a value
			push @vars, $var;
		}
	}
	return @vars
}

sub _is_windows {
	return $^O =~ /^(MSWin32|cygwin)/i;
}

sub _is_case_tolerant {
	return $^O =~ /^(MSWin32|cygwin)/i;
}
# it would make sense to use File::Spec->case_tolerant
# which should return 1 for Windows and Cygwin
# but it does not in Cygwin.

# tells whether a path lies under a directory path
# (it just checks to see if ...
#
# NOTE. include (?i) in pattern below when case_tolerant

# turns 'blib\lib' into 'blib[\\/]lib'
#   and 'a/b\c'    into 'a[\\/]b[\\/]c'
sub _win_re {
	my $p = shift;
	$p =~ s!([\\/])|(.)! $1?'[\\\\/]':"\Q$2" !ge;
	return $p
}
# is(_win_pattern('blib\lib'), 'blib[\\/]lib');
# is(_win_pattern('a/b\c'), 'a[\\/]b[\\/]c');
# is(_win_pattern('dir/f.pl'), 'dir[\\/]f\.pl');

sub _is_under {
	my $path = shift;
	my $dir = shift;
	return $path =~ /^\Q$dir\E/ unless _is_windows;
	# windows is: case tolerant and accepts '\\' or '/'
	my $dir_re = _win_re($dir);
	return $path =~ /(?i)^$dir_re/
}

sub _parent {
	my $path = shift;
	my @path = File::Spec::Unix->splitdir($path);
	pop @path;
	return File::Spec::Unix->catdir(@path)
}

# this computes a relative path from an absolute WHEN
# we know that the base is a descendant of the path
# (so we don't need to handle '.', '..' and the like)
# like File::Spec->abs2rel() is able to do
sub _abs2rel {
	my $path = shift;
	my $base = shift;
	my @path = File::Spec::Unix->splitdir($path);
	my $base_nodes = File::Spec::Unix->splitdir($base);
	splice @path, 0, $base_nodes;
	return File::Spec::Unix->catdir(@path);
}

# my ($p5path, $p5base) = _resolve_path($path, @ivars);
# my $p5path = _resolve_path($path, @ivars);
sub _resolve_path {
	my $path = shift;
	unless ($path) {
		return ($path, '') if wantarray;
		return $path
	}

	my @vars = @_;
	for (@vars) {
		my $p5p = $Config{$_};
		if (_is_under($path, $p5p)) {
			my $p5base = '${' . $_ . '}/';
			#my $p5path = $p5base . File::Spec::Unix->abs2rel($path, $Config{$_});
			my $p5path = $p5base . _abs2rel($path, $p5p);
			return ($p5path, $p5base) if wantarray;
			return $p5path
		}
	}
	return ($path, _parent($path)) if wantarray; # !FIXME: I don't like this!
	return $path # no resolution against given vars
}

our @DEFAULT_IVARS = qw(
   installarchlib archlib installprivlib privlib
   installsitearch installsitelib sitelib sitelib_stem
   installvendorarch installvendorlib vendorlib vendorlib_stem
);

# ($p5path, $p5base) = path_to_p5($path)
# $p5path = path_to_p5($path, include => \@IVARS)
sub path_to_p5 {
	my $path = shift;
	my %options = @_;
	my $ivars = $options{install_vars} || \@DEFAULT_IVARS;
    my @ivars = _purge_vars(@$ivars);
	return _resolve_path($path, @ivars);
}

# $p5path = path_to_p5path($path);
# $p5path = path_to_p5path($path, include => \@IVARS);
sub path_to_p5path {
	return scalar path_to_p5(@_);
}

sub p5path_to_path {
	my $path = shift;
	$path =~ s/^\$\{(\w+)\}/$Config{$1}/;
	return $path

}

1;

__END__