Initial Commit

database/perl/vendor/lib/Probe/Perl.pm

@@ -0,0 +1,299 @@
+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