300 lines
7.0 KiB
Perl
300 lines
7.0 KiB
Perl
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__
|
|
|
|
|
|
=head1 NAME
|
|
|
|
Probe::Perl - Information about the currently running perl
|
|
|
|
=head1 VERSION
|
|
|
|
version 0.03
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use Probe::Perl;
|
|
$p = Probe::Perl->new();
|
|
|
|
# Version of this perl as a floating point number
|
|
$ver = $p->perl_version();
|
|
$ver = Probe::Perl->perl_version();
|
|
|
|
# Convert a multi-dotted string to a floating point number
|
|
$ver = $p->perl_version_to_float($ver);
|
|
$ver = Probe::Perl->perl_version_to_float($ver);
|
|
|
|
# Check if the given perl is the same as the one currently running
|
|
$bool = $p->perl_is_same($perl_path);
|
|
$bool = Probe::Perl->perl_is_same($perl_path);
|
|
|
|
# Find a path to the currently-running perl
|
|
$path = $p->find_perl_interpreter();
|
|
$path = Probe::Perl->find_perl_interpreter();
|
|
|
|
# Get @INC before run-time additions
|
|
@paths = $p->perl_inc();
|
|
@paths = Probe::Perl->perl_inc();
|
|
|
|
# Get the general type of operating system
|
|
$type = $p->os_type();
|
|
$type = Probe::Perl->os_type();
|
|
|
|
# Access Config.pm values
|
|
$val = $p->config('foo');
|
|
$val = Probe::Perl->config('foo');
|
|
$p->config('foo' => 'bar'); # Set locally
|
|
$p->config_revert('foo'); # Revert
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This module provides methods for obtaining information about the
|
|
currently running perl interpreter. It originally began life as code
|
|
in the C<Module::Build> project, but has been externalized here for
|
|
general use.
|
|
|
|
=head1 METHODS
|
|
|
|
=over 4
|
|
|
|
=item new()
|
|
|
|
Creates a new Probe::Perl object and returns it. Most methods in
|
|
the Probe::Perl packages are available as class methods, so you
|
|
don't always need to create a new object. But if you want to create a
|
|
mutable view of the C<Config.pm> data, it's necessary to create an
|
|
object to store the values in.
|
|
|
|
=item config( $key [, $value] )
|
|
|
|
Returns the C<Config.pm> value associated with C<$key>. If C<$value>
|
|
is also specified, then the value is set to C<$value> for this view of
|
|
the data. In this case, C<config()> must be called as an object
|
|
method, not a class method.
|
|
|
|
=item config_revert( $key )
|
|
|
|
Removes any user-assigned value in this view of the C<Config.pm> data.
|
|
|
|
=item find_perl_interpreter( )
|
|
|
|
Returns the absolute path of this perl interpreter. This is actually
|
|
sort of a tricky thing to discover sometimes - in these cases we use
|
|
C<perl_is_same()> to verify.
|
|
|
|
=item perl_version( )
|
|
|
|
Returns the version of this perl interpreter as a perl-styled version
|
|
number using C<perl_version_to_float()>. Uses C<$^V> if your perl is
|
|
recent enough, otherwise uses C<$]>.
|
|
|
|
=item perl_version_to_float( $version )
|
|
|
|
Formats C<$version> as a perl-styled version number like C<5.008001>.
|
|
|
|
=item perl_is_same( $perl )
|
|
|
|
Given the name of a perl interpreter, this method determines if it has
|
|
the same configuration as the one represented by the current perl
|
|
instance. Usually this means it's exactly the same
|
|
|
|
=item perl_inc( )
|
|
|
|
Returns a list of directories in this perl's C<@INC> path, I<before>
|
|
any entries from C<use lib>, C<$ENV{PERL5LIB}>, or C<-I> switches are
|
|
added.
|
|
|
|
=item os_type( [$osname] )
|
|
|
|
Returns a generic OS type (e.g. "Unix", "Windows", "MacOS") for the
|
|
given OS name. If no OS name is given it uses the value in $^O, which
|
|
is the same as $Config{osname}.
|
|
|
|
=back
|
|
|
|
=head1 AUTHOR
|
|
|
|
Randy W. Sims <randys@thepierianspring.org>
|
|
|
|
Based partly on code from the Module::Build project, by Ken Williams
|
|
<kwilliams@cpan.org> and others.
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright 2005 Ken Williams and Randy Sims. All rights reserved.
|
|
|
|
This library is free software; you can redistribute it and/or
|
|
modify it under the same terms as Perl itself.
|
|
|
|
=cut
|