t/lib/MBTest.pm

   1 package MBTest;
   2
   3 use strict;
   4
   5 use IO::File ();
   6 use File::Spec;
   7 use File::Temp ();
   8 use File::Path ();
   9
  10
  11 # Setup the code to clean out %ENV
  12 BEGIN {
  13     # Environment variables which might effect our testing
  14     my @delete_env_keys = qw(
  15         HOME
  16         DEVEL_COVER_OPTIONS
  17         MODULEBUILDRC
  18         PERL_MB_OPT
  19         HARNESS_TIMER
  20         HARNESS_OPTIONS
  21         HARNESS_VERBOSE
  22         PREFIX
  23         INSTALL_BASE
  24         INSTALLDIRS
  25     );
  26
  27     # Remember the ENV values because on VMS %ENV is global
  28     # to the user, not the process.
  29     my %restore_env_keys;
  30
  31     sub clean_env {
  32         for my $key (@delete_env_keys) {
  33             if( exists $ENV{$key} ) {
  34                 $restore_env_keys{$key} = delete $ENV{$key};
  35             }
  36             else {
  37                 delete $ENV{$key};
  38             }
  39         }
  40     }
  41
  42     END {
  43         while( my($key, $val) = each %restore_env_keys ) {
  44             $ENV{$key} = $val;
  45         }
  46     }
  47 }
  48
  49
  50 BEGIN {
  51   clean_env();
  52
  53   # In case the test wants to use our other bundled
  54   # modules, make sure they can be loaded.
  55   my $t_lib = File::Spec->catdir('t', 'bundled');
  56   push @INC, $t_lib; # Let user's installed version override
  57
  58   if ($ENV{PERL_CORE}) {
  59     # We change directories, so expand @INC and $^X to absolute paths
  60     # Also add .
  61     @INC = (map(File::Spec->rel2abs($_), @INC), ".");
  62     $^X = File::Spec->rel2abs($^X);
  63   }
  64 }
  65
  66 use Exporter;
  67 use Test::More;
  68 use Config;
  69 use Cwd ();
  70
  71 # We pass everything through to Test::More
  72 use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
  73 $VERSION = 0.01_01;
  74 @ISA = qw(Test::More); # Test::More isa Exporter
  75 @EXPORT = @Test::More::EXPORT;
  76 %EXPORT_TAGS = %Test::More::EXPORT_TAGS;
  77
  78 # We have a few extra exports, but Test::More has a special import()
  79 # that won't take extra additions.
  80 my @extra_exports = qw(
  81   stdout_of
  82   stderr_of
  83   stdout_stderr_of
  84   slurp
  85   find_in_path
  86   check_compiler
  87   have_module
  88   blib_load
  89   timed_out
  90 );
  91 push @EXPORT, @extra_exports;
  92 __PACKAGE__->export(scalar caller, @extra_exports);
  93 # XXX ^-- that should really happen in import()
  94
  95
  96 ########################################################################
  97
  98 # always return to the current directory
  99 {
 100   my $cwd = File::Spec->rel2abs(Cwd::cwd);
 101
 102   sub original_cwd { return $cwd }
 103
 104   END {
 105     # Go back to where you came from!
 106     chdir $cwd or die "Couldn't chdir to $cwd";
 107   }
 108 }
 109 ########################################################################
 110
 111 { # backwards compatible temp filename recipe adapted from perlfaq
 112   my $tmp_count = 0;
 113   my $tmp_base_name = sprintf("MB-%d-%d", $$, time());
 114   sub temp_file_name {
 115     sprintf("%s-%04d", $tmp_base_name, ++$tmp_count)
 116   }
 117 }
 118 ########################################################################
 119
 120 # Setup a temp directory
 121 sub tmpdir {
 122   my ($self, @args) = @_;
 123   my $dir = $ENV{PERL_CORE} ? MBTest->original_cwd : File::Spec->tmpdir;
 124   return File::Temp::tempdir('MB-XXXXXXXX', CLEANUP => 1, DIR => $dir, @args);
 125 }
 126
 127 BEGIN {
 128   $ENV{HOME} = tmpdir; # don't want .modulebuildrc or other things interfering
 129 }
 130
 131 sub save_handle {
 132   my ($handle, $subr) = @_;
 133   my $outfile = File::Spec->catfile(File::Spec->tmpdir, temp_file_name());
 134
 135   local *SAVEOUT;
 136   open SAVEOUT, ">&" . fileno($handle)
 137     or die "Can't save output handle: $!";
 138   open $handle, "> $outfile" or die "Can't create $outfile: $!";
 139
 140   eval {$subr->()};
 141   open $handle, ">&SAVEOUT" or die "Can't restore output: $!";
 142
 143   my $ret = slurp($outfile);
 144   1 while unlink $outfile;
 145   return $ret;
 146 }
 147
 148 sub stdout_of { save_handle(\*STDOUT, @_) }
 149 sub stderr_of { save_handle(\*STDERR, @_) }
 150 sub stdout_stderr_of {
 151   my $subr = shift;
 152   my ($stdout, $stderr);
 153   $stdout = stdout_of ( sub {
 154       $stderr = stderr_of( $subr )
 155   });
 156   return wantarray ? ($stdout, $stderr) : $stdout . $stderr;
 157 }
 158
 159 sub slurp {
 160   my $fh = IO::File->new($_[0]) or die "Can't open $_[0]: $!";
 161   local $/;
 162   return scalar <$fh>;
 163 }
 164
 165 # Some extensions we should know about if we're looking for executables
 166 sub exe_exts {
 167
 168   if ($^O eq 'MSWin32') {
 169     return split($Config{path_sep}, $ENV{PATHEXT} || '.com;.exe;.bat');
 170   }
 171   if ($^O eq 'os2') {
 172     return qw(.exe .com .pl .cmd .bat .sh .ksh);
 173   }
 174   return;
 175 }
 176
 177 sub find_in_path {
 178   my $thing = shift;
 179
 180   my @exe_ext = exe_exts();
 181   if ( File::Spec->file_name_is_absolute( $thing ) ) {
 182     foreach my $ext ( '', @exe_ext ) {
 183       return "$thing$ext" if -e "$thing$ext";
 184     }
 185   }
 186   else {
 187     my @path = split $Config{path_sep}, $ENV{PATH};
 188     foreach (@path) {
 189       my $fullpath = File::Spec->catfile($_, $thing);
 190       foreach my $ext ( '', @exe_ext ) {
 191         return "$fullpath$ext" if -e "$fullpath$ext";
 192       }
 193     }
 194   }
 195   return;
 196 }
 197
 198 sub check_compiler {
 199   return (1,1) if $ENV{PERL_CORE};
 200
 201   local $SIG{__WARN__} = sub {};
 202
 203   blib_load('Module::Build');
 204   my $mb = Module::Build->current;
 205   $mb->verbose( 0 );
 206
 207   my $have_c_compiler;
 208   stderr_of( sub {$have_c_compiler = $mb->have_c_compiler} );
 209
 210   # check noexec tmpdir
 211   my $tmp_exec;
 212   if ( $have_c_compiler ) {
 213     my $dir = MBTest->tmpdir;
 214     my $c_file = File::Spec->catfile($dir,'test.c');
 215     open my $fh, ">", $c_file;
 216     print {$fh} "int main() { return 0; }\n";
 217     close $fh;
 218     my $exe = $mb->cbuilder->link_executable(
 219       objects => $mb->cbuilder->compile( source => $c_file )
 220     );
 221     $tmp_exec = 0 == system( $exe );
 222   }
 223   return ($have_c_compiler, $tmp_exec);
 224 }
 225
 226 sub have_module {
 227   my $module = shift;
 228   return eval "require $module; 1";
 229 }
 230
 231 sub blib_load {
 232   # Load the given module and ensure it came from blib/, not the larger system
 233   my $mod = shift;
 234   have_module($mod) or die "Error loading $mod\: $@\n";
 235
 236   (my $path = $mod) =~ s{::}{/}g;
 237   $path .= ".pm";
 238   my ($pkg, $file, $line) = caller;
 239   unless($ENV{PERL_CORE}) {
 240     unless($INC{$path} =~ m/\bblib\b/) {
 241       (my $load_from = $INC{$path}) =~ s{$path$}{};
 242       die "$mod loaded from '$load_from'\nIt should have been loaded from blib.  \@INC contains:\n  ",
 243       join("\n  ", @INC) . "\nFatal error occured in blib_load() at $file, line $line.\n";
 244     }
 245   }
 246 }
 247
 248 sub timed_out {
 249   my ($sub, $timeout) = @_;
 250   return unless $sub;
 251   $timeout ||= 60;
 252
 253   my $saw_alarm = 0;
 254   eval {
 255     local $SIG{ALRM} = sub { $saw_alarm++; die "alarm\n"; }; # NB: \n required
 256     alarm $timeout;
 257     $sub->();
 258     alarm 0;
 259   };
 260   if ($@) {
 261     die unless $@ eq "alarm\n";   # propagate unexpected errors
 262   }
 263   return $saw_alarm;
 264 }
 265
 266 sub check_EUI {
 267   my $timed_out;
 268   stdout_stderr_of( sub {
 269       $timed_out = timed_out( sub {
 270           ExtUtils::Installed->new(extra_libs => [@INC])
 271         }
 272       );
 273     }
 274   );
 275   return ! $timed_out;
 276 }
 277
 278 1;
 279 # vim:ts=2:sw=2:et:sta