lib/Module/Build/t/lib/MBTest.pm

   1 package MBTest;
   2
   3 use strict;
   4
   5 use File::Spec;
   6
   7 BEGIN {
   8   # Make sure none of our tests load the users ~/.modulebuildrc file
   9   $ENV{MODULEBUILDRC} = 'NONE';
  10
  11   # In case the test wants to use Test::More or our other bundled
  12   # modules, make sure they can be loaded.  They'll still do "use
  13   # Test::More" in the test script.
  14   my $t_lib = File::Spec->catdir('t', 'bundled');
  15
  16   if (!$ENV{PERL_CORE}) {
  17     push @INC, $t_lib; # Let user's installed version override
  18   } else {
  19     # We change directories, so expand @INC to absolute paths
  20     # Also add .
  21     @INC = (map(File::Spec->rel2abs($_), @INC), ".");
  22
  23     # we are in 't', go up a level so we don't create t/t/_tmp
  24     chdir '..' or die "Couldn't chdir to ..";
  25
  26     push @INC, File::Spec->catdir(qw/lib Module Build/, $t_lib);
  27
  28     # make sure children get @INC pointing to uninstalled files
  29     require Cwd;
  30     $ENV{PERL5LIB} = File::Spec->catdir(Cwd::cwd(), 'lib');
  31   }
  32 }
  33
  34 use Exporter;
  35 use Test::More;
  36 use Config;
  37
  38 # We pass everything through to Test::More
  39 use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
  40 $VERSION = 0.01;
  41 @ISA = qw(Test::More); # Test::More isa Exporter
  42 @EXPORT = @Test::More::EXPORT;
  43 %EXPORT_TAGS = %Test::More::EXPORT_TAGS;
  44
  45 # We have a few extra exports, but Test::More has a special import()
  46 # that won't take extra additions.
  47 my @extra_exports = qw(stdout_of stderr_of slurp find_in_path check_compiler);
  48 push @EXPORT, @extra_exports;
  49 __PACKAGE__->export(scalar caller, @extra_exports);
  50
  51
  52 sub save_handle {
  53   my ($handle, $subr) = @_;
  54   my $outfile = 'save_out';
  55
  56   local *SAVEOUT;
  57   open SAVEOUT, ">&" . fileno($handle) or die "Can't save output handle: $!";
  58   open $handle, "> $outfile" or die "Can't create $outfile: $!";
  59
  60   eval {$subr->()};
  61   open $handle, ">&SAVEOUT" or die "Can't restore output: $!";
  62
  63   my $ret = slurp($outfile);
  64   1 while unlink $outfile;
  65   return $ret;
  66 }
  67
  68 sub stdout_of { save_handle(\*STDOUT, @_) }
  69 sub stderr_of { save_handle(\*STDERR, @_) }
  70
  71 sub slurp {
  72   my $fh = IO::File->new($_[0]) or die "Can't open $_[0]: $!";
  73   local $/;
  74   return scalar <$fh>;
  75 }
  76
  77 sub find_in_path {
  78   my $thing = shift;
  79
  80   my @path = split $Config{path_sep}, $ENV{PATH};
  81   my @exe_ext = $^O eq 'MSWin32' ? ('', # may have extension already
  82     split($Config{path_sep}, $ENV{PATHEXT} || '.com;.exe;.bat')) :
  83     ('');
  84   foreach (@path) {
  85     my $fullpath = File::Spec->catfile($_, $thing);
  86     foreach my $ext ( @exe_ext ) {
  87       return "$fullpath$ext" if -e "$fullpath$ext";
  88     }
  89   }
  90   return;
  91 }
  92
  93 # returns ($have_c_compiler, $C_support_feature);
  94 sub check_compiler {
  95   return (1,1) if $ENV{PERL_CORE};
  96
  97   local $SIG{__WARN__} = sub {};
  98
  99   my $mb = Module::Build->current;
 100   $mb->verbose( 0 );
 101
 102   my $have_c_compiler;
 103   stderr_of( sub {$have_c_compiler = $mb->have_c_compiler} );
 104
 105   return ($have_c_compiler, $mb->feature('C_support'));
 106 }
 107
 108 1;