From: Karen Etheridge Date: Thu, 5 Dec 2013 19:21:40 +0000 (-0800) Subject: remove unused cruft inherited from Module-Build/t/lib/MBTest.pm X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=95b2fcabab78a7467792a6d29fd79a7101343886;p=p5sagit%2FModule-Metadata.git remove unused cruft inherited from Module-Build/t/lib/MBTest.pm --- diff --git a/t/lib/MBTest.pm b/t/lib/MBTest.pm index fb239ab..3580998 100644 --- a/t/lib/MBTest.pm +++ b/t/lib/MBTest.pm @@ -3,11 +3,8 @@ package MBTest; use strict; use warnings; -use IO::File (); use File::Spec; use File::Temp (); -use File::Path (); - # Setup the code to clean out %ENV BEGIN { @@ -79,15 +76,6 @@ $VERSION = 0.01_01; # 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); @@ -109,15 +97,6 @@ __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) = @_; @@ -129,152 +108,5 @@ BEGIN { $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