File Coverage

lib/ExtUtils/InferConfig.pm

Criterion	Covered	Total	%
statement	91	102	89.2
branch	22	46	47.8
condition	3	12	25.0
subroutine	12	12	100.0
pod	3	3	100.0
total	131	175	74.8

package ExtUtils::InferConfig;

use strict;
use Config;
use Carp qw/croak/;
use IPC::Cmd qw//;

use vars qw/$VERSION/;
BEGIN {
    $VERSION = '1.04';
}

#use constant ISWIN32 => ($^O =~ /win32/i ? 1 : 0);

=head1 NAME

ExtUtils::InferConfig - Infer Perl Configuration for non-running interpreters

=head1 SYNOPSIS

  use ExtUtils::InferConfig;
  my $eic = ExtUtils::InferConfig->new(
    perl => '/path/to/a/perl'
  );

  # Get that interpreters %Config as hash ref
  my $Config = $eic->get_config;

  # Get that interpreters @INC as array ref
  my $INC = $eic->get_inc;

=head1 DESCRIPTION

This module can determine the configuration and C<@INC> of a perl
interpreter given its path and that it is runnable by the current
user.

It runs the interpreter with a one-liner and grabs the C<%Config>
hash via STDOUT capturing. Getting the module load paths, C<@INC>,
works the same way for C<@INC> entries that are plain paths.

=head1 METHODS

=head2 new

Requires one named parameter: C, the path to the perl
interpreter to query for information.

Optional parameter: C 1> enables the debugging mode.

=cut

sub new {
    my $class = shift;
    $class = ref($class) || $class;

    my %args = @_;


    my $self = {
        perl => undef,
        config => undef,
        inc => undef,
        ($args{debug} ? (debug => 1) : ()),
    };
    bless $self => $class;

    # get interpreter, check that we have access
    my $perl = $args{perl} || $^X;
    $perl = $self->_perl_to_file($perl);

    if (not defined $perl) {
        croak(
            "Invalid perl interpreter specified. "
            ."It was either not found or it is not executable."
        );
    }

    warn "Using perl '$perl'" if $self->{debug};

    $self->{perl} = $perl;

    return $self;
}

sub _perl_to_file {
    # see perldoc perlvar about this. Look for $^X
    my $self = shift;
    my $perl = shift;

    return() if not defined $perl;
    return $perl if -f $perl and -x _;

    # Build up a set of file names (not command names).
    if ($^O ne 'VMS') {
      $perl .= $Config{_exe}
        unless $perl =~ m/\Q$Config{_exe}$/i;
    }

    return $perl if -f $perl and -x _;
    return();
}


=head2 get_config

Returns a copy of the C<%Config::Config> hash of the
intepreter which was specified as a parameter to the
constructor.

The first time this method (or the get_inc method below)
is called, the perl binary is run. For subsequent calls
of this method, the information is cached.

=cut

sub get_config {
    my $self = shift;
    return $self->{config} if defined $self->{config};

    $self->{config} = $self->_infer_config($self->{perl});

    return $self->{config};
}

sub _infer_config {
    my $self = shift;
    my $perl = shift;
    my $code = <<'HERE';
use Config;
foreach my $k (keys %Config) {
 my $ek = $k;
 $ek =~ s/([\n\t\r%])/q{%}.ord($1).q{;}/ge;
 my $ev = $Config{$k};
 if (defined $ev) {
  $ev =~ s/([\n\t\r%])/q{%}.ord($1).q{;}/ge;
 } else {
  $ev = q{%-1;};
 }
 print qq{$ek\n$ev\n};
}
HERE

    warn "Running the following code:\n---$code\n---" if $self->{debug};

    $code =~ s/\s+$//;
    $code =~ s/\n/ /g;

    my @command = (
      $perl, '-e', $code
    );
    warn "Running the following command: '@command'" if $self->{debug};

    my $old_use_run = $IPC::Cmd::USE_IPC_RUN;
    $IPC::Cmd::USE_IPC_RUN = 1;
    my ($success, $error_code, undef, $buffer, $error) = IPC::Cmd::run(
        command => \@command,
    );
    $IPC::Cmd::USE_IPC_RUN = $old_use_run;


    warn "Returned buffer is:\n---\n".join("\n",@$buffer)."\n---" if $self->{debug};
    warn "Returned error buffer is:\n---\n".join("\n",@$error)."\n---" if $self->{debug};

    if (not $success) {
        croak(
            "Could not run the specified perl interpreter to determine \%Config. Error code (if any) was: $error_code. STDERR was (if any): ".join('', @$error)
        );
    }

    my %Config;
    my @data = split /\n/, join '', @$buffer;
    while (@data) {
        my $key = shift(@data);
        chomp $key;
        my $value = shift(@data);
        $value = '' if !defined $value; #in case of last value
        chomp $value;
        $key =~ s/%(\d+);/chr($1)/eg;
        if ($value eq '%-1;') {
            $value = undef;
        }
        else {
            $value =~ s/%(\d+);/chr($1)/eg;
        }
        $Config{$key} = $value;
    }

    return \%Config;
}


=head2 get_inc

Returns a copy of the C<@INC> array of the
intepreter which was specified as a parameter to the
constructor. B This skips any references
(subroutines, C refs, objects) in the C<@INC>
array because they cannot be reliably stringified!

The first time this method (or the get_config method avove)
is called, the perl binary is run. For subsequent calls
of this method, the information is cached.

=cut

sub get_inc {
    my $self = shift;
    return $self->{config} if defined $self->{inc};

    $self->{inc} = $self->_infer_inc($self->{perl});

    return $self->{inc};
}


sub _infer_inc {
    my $self = shift;
    my $perl = shift;
    my $code = <<'HERE';
foreach my $inc (@INC) {
  my $i = $inc;
  if (not ref($i)) {
    $i =~ s/([\n\t\r%])/q{%}.ord($1).q{;}/ge;
  }
  print qq{$i\n};
}
HERE
    warn "Running the following code:\n---$code\n---" if $self->{debug};

    $code =~ s/\s+$//;
    $code =~ s/\n/ /g;

    my @command = (
      $perl, '-e', $code
    );
    warn "Running the following command: '@command'" if $self->{debug};

    my $old_use_run = $IPC::Cmd::USE_IPC_RUN;
    $IPC::Cmd::USE_IPC_RUN = 1;
    my ($success, $error_code, undef, $buffer, $error) = IPC::Cmd::run(
        command => \@command,
    );
    $IPC::Cmd::USE_IPC_RUN = $old_use_run;

    warn "Returned buffer is:\n---\n".join("\n",@$buffer)."\n---" if $self->{debug};
    warn "Returned error buffer is:\n---\n".join("\n",@$error)."\n---" if $self->{debug};

    if (not $success) {
        croak(
            "Could not run the specified perl interpreter to determine \@INC. Error code (if any) was: $error_code. STDERR was (if any): ".join('', @$error)
        );
    }

    my @inc;
    my @data = split /\n/, join '', @$buffer;
    foreach my $line (@data) {
        chomp $line;
        if ($line eq '%-1;') {
            $line = undef;
        }
        else {
            $line =~ s/%(\d+);/chr($1)/eg;
        }
        push @inc, $line;
    }

    return \@inc;
}


1;
__END__