File Coverage

blib/lib/ExtUtils/Builder/Util.pm

Criterion	Covered	Total	%
statement	55	85	64.7
branch	9	30	30.0
condition	3	15	20.0
subroutine	15	19	78.9
pod	8	8	100.0
total	90	157	57.3

package ExtUtils::Builder::Util;
$ExtUtils::Builder::Util::VERSION = '0.020';
use strict;
use warnings;

use Exporter 5.57 'import';
our @EXPORT_OK = qw/get_perl require_module unix_to_native_path native_to_unix_path command code function split_like_shell/;

use Carp 'croak';
use Config;
use ExtUtils::Config;
use ExtUtils::Helpers 0.027 'split_like_shell';
use File::Spec;
use File::Spec::Unix;
use Scalar::Util 'tainted';

sub get_perl {
	my (%opts) = @_;
	my $config = $opts{config} // ExtUtils::Config->new;

	if (File::Spec->file_name_is_absolute($^X) and not tainted($^X)) {
		return $^X;
	}
	elsif ($config->get('userelocatableinc')) {
		require Devel::FindPerl;
		return Devel::FindPerl::find_perl_interpreter($config);
	}
	else {
		return $config->get('perlpath');
	}
}

sub require_module {
	my $module = shift;
	(my $filename = "$module.pm") =~ s{::}{/}g;
	require $filename;
	return $module;
}

sub command {
	my (@command) = @_;
	require ExtUtils::Builder::Action::Command;
	return ExtUtils::Builder::Action::Command->new(command => \@command);
}

sub code {
	my %args = @_;
	require ExtUtils::Builder::Action::Code;
	return ExtUtils::Builder::Action::Code->new(%args);
}

sub function {
	my %args = @_;
	require ExtUtils::Builder::Action::Function;
	return ExtUtils::Builder::Action::Function->new(%args);
}

my %cache;
sub glob_to_regex {
	my $input = shift;
	return $cache{$input} ||= do {
		my $regex = _glob_to_regex_string($input);
		qr/^$regex$/;
	};
}

sub _glob_to_regex_string {
	my $glob = shift;
	my $in_curlies;
	local $_ = $glob;

	my $regex = !/\A(?=\.)/ ? '(?=[^\.])' : '';
	while (!/\G\z/mgc) {
		if (/\G([^\/.()|+^\$@%\\*?{},\[\]]+)/gc) {
			$regex .= $1;
		}
		elsif (m{\G/}gc) {
			$regex .= !/\G(?=\.)/gc ? '/(?=[^\.])' : '/'
		}
		elsif (/ \G ( [.()|+^\$@%] ) /xmgc) {
			$regex .= quotemeta $1;
		}
		elsif (/ \G \\ ( [*?{}\\,] ) /xmgc) {
			$regex .= quotemeta $1;
		}
		elsif (/\G\*/mgc) {
			$regex .= "[^/]*";
		}
		elsif (/\G\?/mgc) {
			$regex .= "[^/]";
		}
		elsif (/\G\{/mgc) {
			$regex .= "(";
			++$in_curlies;
		}
		elsif (/\G \[ ( [^\]]+ ) \] /xgc) {
			$regex .= "[\Q$1\E]";
		}
		elsif ($in_curlies && /\G\}/mgc) {
			$regex .= ")";
			--$in_curlies;
		}
		elsif ($in_curlies && /\G,/mgc) {
			$regex .= "|";
		}
		elsif (/\G([},]+)/gc) {
			$regex .= $1;
		}
		else {
			croak sprintf "Couldn't parse at %s|%s", substr($_, 0 , pos), substr $_, pos;
		}
	}

	return $regex;
}

sub unix_to_native_path {
	my ($input) = @_;
	my ($volume, $unix_dir, $file) = File::Spec::Unix->splitpath($input);
	my @splitdir = File::Spec::Unix->splitdir($unix_dir);
	my $catdir = File::Spec->catdir(@splitdir);
	return File::Spec->catpath($volume, $catdir, $file);
}

sub native_to_unix_path {
	my ($input) = @_;
	my ($volume, $unix_dir, $file) = File::Spec->splitpath($input);
	my @splitdir = File::Spec->splitdir($unix_dir);
	my $catdir = File::Spec::Unix->catdir(@splitdir);
	return File::Spec::Unix->catpath($volume, $catdir, $file);
}

1;

# ABSTRACT: Utility functions for ExtUtils::Builder

__END__