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