use strict;
use warnings;
-use IO::File ();
use File::Spec;
use File::Temp ();
-use File::Path ();
-
# Setup the code to clean out %ENV
BEGIN {
# We have a few extra exports, but Test::More has a special import()
# that won't take extra additions.
my @extra_exports = qw(
- stdout_of
- stderr_of
- stdout_stderr_of
- slurp
- find_in_path
- check_compiler
- have_module
- blib_load
- timed_out
);
push @EXPORT, @extra_exports;
__PACKAGE__->export(scalar caller, @extra_exports);
}
########################################################################
-{ # backwards compatible temp filename recipe adapted from perlfaq
- my $tmp_count = 0;
- my $tmp_base_name = sprintf("MB-%d-%d", $$, time());
- sub temp_file_name {
- sprintf("%s-%04d", $tmp_base_name, ++$tmp_count)
- }
-}
-########################################################################
-
# Setup a temp directory
sub tmpdir {
my ($self, @args) = @_;
$ENV{HOME} = tmpdir; # don't want .modulebuildrc or other things interfering
}
-sub save_handle {
- my ($handle, $subr) = @_;
- my $outfile = File::Spec->catfile(File::Spec->tmpdir, temp_file_name());
-
- local *SAVEOUT;
- open SAVEOUT, ">&" . fileno($handle)
- or die "Can't save output handle: $!";
- open $handle, "> $outfile" or die "Can't create $outfile: $!";
-
- eval {$subr->()};
- open $handle, ">&SAVEOUT" or die "Can't restore output: $!";
-
- my $ret = slurp($outfile);
- 1 while unlink $outfile;
- return $ret;
-}
-
-sub stdout_of { save_handle(\*STDOUT, @_) }
-sub stderr_of { save_handle(\*STDERR, @_) }
-sub stdout_stderr_of {
- my $subr = shift;
- my ($stdout, $stderr);
- $stdout = stdout_of ( sub {
- $stderr = stderr_of( $subr )
- });
- return wantarray ? ($stdout, $stderr) : $stdout . $stderr;
-}
-
-sub slurp {
- my $fh = IO::File->new($_[0]) or die "Can't open $_[0]: $!";
- local $/;
- return scalar <$fh>;
-}
-
-# Some extensions we should know about if we're looking for executables
-sub exe_exts {
-
- if ($^O eq 'MSWin32') {
- return split($Config{path_sep}, $ENV{PATHEXT} || '.com;.exe;.bat');
- }
- if ($^O eq 'os2') {
- return qw(.exe .com .pl .cmd .bat .sh .ksh);
- }
- return;
-}
-
-sub find_in_path {
- my $thing = shift;
-
- my @exe_ext = exe_exts();
- if ( File::Spec->file_name_is_absolute( $thing ) ) {
- foreach my $ext ( '', @exe_ext ) {
- return "$thing$ext" if -e "$thing$ext";
- }
- }
- else {
- my @path = split $Config{path_sep}, $ENV{PATH};
- foreach (@path) {
- my $fullpath = File::Spec->catfile($_, $thing);
- foreach my $ext ( '', @exe_ext ) {
- return "$fullpath$ext" if -e "$fullpath$ext";
- }
- }
- }
- return;
-}
-
-sub check_compiler {
- return (1,1) if $ENV{PERL_CORE};
-
- local $SIG{__WARN__} = sub {};
-
- blib_load('Module::Build');
- my $mb = Module::Build->current;
- $mb->verbose( 0 );
-
- my $have_c_compiler;
- stderr_of( sub {$have_c_compiler = $mb->have_c_compiler} );
-
- # check noexec tmpdir
- my $tmp_exec;
- if ( $have_c_compiler ) {
- my $dir = MBTest->tmpdir;
- my $c_file = File::Spec->catfile($dir,'test.c');
- open my $fh, ">", $c_file;
- print {$fh} "int main() { return 0; }\n";
- close $fh;
- my $exe = $mb->cbuilder->link_executable(
- objects => $mb->cbuilder->compile( source => $c_file )
- );
- $tmp_exec = 0 == system( $exe );
- }
- return ($have_c_compiler, $tmp_exec);
-}
-
-sub have_module {
- my $module = shift;
- return eval "require $module; 1";
-}
-
-sub blib_load {
- # Load the given module and ensure it came from blib/, not the larger system
- my $mod = shift;
- have_module($mod) or die "Error loading $mod\: $@\n";
-
- (my $path = $mod) =~ s{::}{/}g;
- $path .= ".pm";
- my ($pkg, $file, $line) = caller;
- unless($ENV{PERL_CORE}) {
- unless($INC{$path} =~ m/\bblib\b/) {
- (my $load_from = $INC{$path}) =~ s{$path$}{};
- die "$mod loaded from '$load_from'\nIt should have been loaded from blib. \@INC contains:\n ",
- join("\n ", @INC) . "\nFatal error occured in blib_load() at $file, line $line.\n";
- }
- }
-}
-
-sub timed_out {
- my ($sub, $timeout) = @_;
- return unless $sub;
- $timeout ||= 60;
-
- my $saw_alarm = 0;
- eval {
- local $SIG{ALRM} = sub { $saw_alarm++; die "alarm\n"; }; # NB: \n required
- alarm $timeout;
- $sub->();
- alarm 0;
- };
- if ($@) {
- die unless $@ eq "alarm\n"; # propagate unexpected errors
- }
- return $saw_alarm;
-}
-
-sub check_EUI {
- my $timed_out;
- stdout_stderr_of( sub {
- $timed_out = timed_out( sub {
- ExtUtils::Installed->new(extra_libs => [@INC])
- }
- );
- }
- );
- return ! $timed_out;
-}
-
1;
# vim:ts=2:sw=2:et:sta