t/lib/MBTest.pm

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