File Coverage

blib/lib/Probe/Perl.pm

Criterion	Covered	Total	%
statement	50	63	79.3
branch	13	34	38.2
condition	4	11	36.3
subroutine	13	13	100.0
pod	9	9	100.0
total	89	130	68.4

use strict;

package Probe::Perl;
{
  $Probe::Perl::VERSION = '0.03';
}

# TODO: cache values derived from launching an external perl process
# TODO: docs refer to Config.pm and $self->{config}


use Config;
use File::Spec;

sub new {
  my $class = shift;
  my $data  = shift || {};
  return bless( $data, $class );
}

sub config {
  my ($self, $key) = (shift, shift);
  if (@_) {
    unless (ref $self) {
      die "Can't set config values via $self->config().  Use $self->new() to create a local view";
    }
    $self->{$key} = shift;
  }
  return ref($self) && exists $self->{$key} ? $self->{$key} : $Config{$key};
}

sub config_revert {
  my $self = shift;
  die "Can't use config_revert() as a class method" unless ref($self);

  delete $self->{$_} foreach @_;
}

sub perl_version {
  my $self = shift;
  # Check the current perl interpreter
  # It's much more convenient to use $] here than $^V, but 'man
  # perlvar' says I'm not supposed to.  Bloody tyrant.
  return $^V ? $self->perl_version_to_float(sprintf( "%vd", $^V )) : $];
}

sub perl_version_to_float {
  my ($self, $version) = @_;
  $version =~ s/\./../;  # Double up the first dot so the output has one dot remaining
  $version =~ s/\.(\d+)/sprintf( '%03d', $1 )/eg;
  return $version;
}

sub _backticks {
  my $perl = shift;
  return unless -e $perl;

  my $fh;
  eval {open $fh, '-|', $perl, @_ or die $!};
  if (!$@) {
    return <$fh> if wantarray;
    my $tmp = do {local $/=undef; <$fh>};
    return $tmp;
  }

  # Quoting only happens on the path to perl - I control the rest of
  # the args and they don't need quoting.
  if ($^O eq 'MSWin32') {
    $perl = qq{"$perl"} if $perl =~ m{^[\w\\]+$};
  } else {
    $perl =~ s{([^\w\\])}{\\$1}g;
  }

  return `$perl @_`;
}

sub perl_is_same {
  my ($self, $perl) = @_;
  return _backticks($perl, qw(-MConfig=myconfig -e print -e myconfig)) eq Config->myconfig;
}

sub find_perl_interpreter {
  my $self = shift;

  return $^X if File::Spec->file_name_is_absolute($^X);

  my $exe = $self->config('exe_ext');

  my $thisperl = $^X;
  if ($self->os_type eq 'VMS') {
    # VMS might have a file version at the end
    $thisperl .= $exe unless $thisperl =~ m/$exe(;\d+)?$/i;
  } elsif (defined $exe) {
    $thisperl .= $exe unless $thisperl =~ m/$exe$/i;
  }

  foreach my $perl ( $self->config('perlpath'),
		     map( File::Spec->catfile($_, $thisperl),
			  File::Spec->path() )
		   ) {
    return $perl if -f $perl and $self->perl_is_same($perl);
  }
  return;
}

# Determine the default @INC for this Perl
sub perl_inc {
  my $self = shift;

  local $ENV{PERL5LIB};  # this is not considered part of the default.

  my $perl = $self->find_perl_interpreter();

  my @inc = _backticks($perl, qw(-l -e print -e for -e @INC));
  chomp @inc;

  return @inc;
}


{
  my %OSTYPES = qw(
		   aix       Unix
		   bsdos     Unix
		   dgux      Unix
		   dynixptx  Unix
		   freebsd   Unix
		   linux     Unix
		   hpux      Unix
		   irix      Unix
		   darwin    Unix
		   machten   Unix
		   next      Unix
		   openbsd   Unix
		   netbsd    Unix
		   dec_osf   Unix
		   svr4      Unix
		   svr5      Unix
		   sco_sv    Unix
		   unicos    Unix
		   unicosmk  Unix
		   solaris   Unix
		   sunos     Unix
		   cygwin    Unix
		   os2       Unix

		   dos       Windows
		   MSWin32   Windows

		   os390     EBCDIC
		   os400     EBCDIC
		   posix-bc  EBCDIC
		   vmesa     EBCDIC

		   MacOS     MacOS
		   VMS       VMS
		   VOS       VOS
		   riscos    RiscOS
		   amigaos   Amiga
		   mpeix     MPEiX
		  );


  sub os_type {
    my $class  = shift;
    return $OSTYPES{shift || $^O};
  }
}


1;

__END__