1package MakeMaker::Test::Utils; 2 3use File::Spec; 4use strict; 5use Config; 6 7require Exporter; 8our @ISA = qw(Exporter); 9 10our $Is_VMS = $^O eq 'VMS'; 11our $Is_MacOS = $^O eq 'MacOS'; 12our $Is_FreeBSD = $^O eq 'freebsd'; 13 14our @EXPORT = qw(which_perl perl_lib makefile_name makefile_backup 15 make make_run run make_macro calibrate_mtime 16 setup_mm_test_root 17 have_compiler slurp 18 $Is_VMS $Is_MacOS 19 run_ok 20 ); 21 22 23# Setup the code to clean out %ENV 24{ 25 # Environment variables which might effect our testing 26 my @delete_env_keys = qw( 27 PERL_MM_OPT 28 PERL_MM_USE_DEFAULT 29 HARNESS_TIMER 30 HARNESS_OPTIONS 31 HARNESS_VERBOSE 32 PREFIX 33 MAKEFLAGS 34 ); 35 36 my %default_env_keys; 37 38 # Inform the BSDPAN hacks not to register modules installed for testing. 39 $default_env_keys{PORTOBJFORMAT} = 1 if $Is_FreeBSD; 40 41 # Remember the ENV values because on VMS %ENV is global 42 # to the user, not the process. 43 my %restore_env_keys; 44 45 sub clean_env { 46 for my $key (keys %default_env_keys) { 47 $ENV{$key} = $default_env_keys{$key} unless $ENV{$key}; 48 } 49 50 for my $key (@delete_env_keys) { 51 if( exists $ENV{$key} ) { 52 $restore_env_keys{$key} = delete $ENV{$key}; 53 } 54 else { 55 delete $ENV{$key}; 56 } 57 } 58 } 59 60 END { 61 while( my($key, $val) = each %restore_env_keys ) { 62 $ENV{$key} = $val; 63 } 64 } 65} 66clean_env(); 67 68 69=head1 NAME 70 71MakeMaker::Test::Utils - Utility routines for testing MakeMaker 72 73=head1 SYNOPSIS 74 75 use MakeMaker::Test::Utils; 76 77 my $perl = which_perl; 78 perl_lib; 79 80 my $makefile = makefile_name; 81 my $makefile_back = makefile_backup; 82 83 my $make = make; 84 my $make_run = make_run; 85 make_macro($make, $targ, %macros); 86 87 my $mtime = calibrate_mtime; 88 89 my $out = run($cmd); 90 91 my $have_compiler = have_compiler(); 92 93 my $text = slurp($filename); 94 95 96=head1 DESCRIPTION 97 98A consolidation of little utility functions used through out the 99MakeMaker test suite. 100 101=head2 Functions 102 103The following are exported by default. 104 105=over 4 106 107=item B<which_perl> 108 109 my $perl = which_perl; 110 111Returns a path to perl which is safe to use in a command line, no 112matter where you chdir to. 113 114=cut 115 116sub which_perl { 117 my $perl = $^X; 118 $perl ||= 'perl'; 119 120 # VMS should have 'perl' aliased properly 121 return $perl if $Is_VMS; 122 123 $perl .= $Config{exe_ext} unless $perl =~ m/$Config{exe_ext}$/i; 124 125 my $perlpath = File::Spec->rel2abs( $perl ); 126 unless( $Is_MacOS || -x $perlpath ) { 127 # $^X was probably 'perl' 128 129 # When building in the core, *don't* go off and find 130 # another perl 131 die "Can't find a perl to use (\$^X=$^X), (\$perlpath=$perlpath)" 132 if $ENV{PERL_CORE}; 133 134 foreach my $path (File::Spec->path) { 135 $perlpath = File::Spec->catfile($path, $perl); 136 last if -x $perlpath; 137 } 138 } 139 140 return $perlpath; 141} 142 143=item B<perl_lib> 144 145 perl_lib; 146 147Sets up environment variables so perl can find its libraries. 148 149=cut 150 151my $old5lib = $ENV{PERL5LIB}; 152my $had5lib = exists $ENV{PERL5LIB}; 153sub perl_lib { 154 # perl-src/t/ 155 my $lib = $ENV{PERL_CORE} ? qq{../lib} 156 # ExtUtils-MakeMaker/t/ 157 : qq{../blib/lib}; 158 $lib = File::Spec->rel2abs($lib); 159 my @libs = ($lib); 160 push @libs, $ENV{PERL5LIB} if exists $ENV{PERL5LIB}; 161 $ENV{PERL5LIB} = join($Config{path_sep}, @libs); 162 unshift @INC, $lib; 163} 164 165END { 166 if( $had5lib ) { 167 $ENV{PERL5LIB} = $old5lib; 168 } 169 else { 170 delete $ENV{PERL5LIB}; 171 } 172} 173 174 175=item B<makefile_name> 176 177 my $makefile = makefile_name; 178 179MakeMaker doesn't always generate 'Makefile'. It returns what it 180should generate. 181 182=cut 183 184sub makefile_name { 185 return $Is_VMS ? 'Descrip.MMS' : 'Makefile'; 186} 187 188=item B<makefile_backup> 189 190 my $makefile_old = makefile_backup; 191 192Returns the name MakeMaker will use for a backup of the current 193Makefile. 194 195=cut 196 197sub makefile_backup { 198 my $makefile = makefile_name; 199 return $Is_VMS ? "$makefile".'_old' : "$makefile.old"; 200} 201 202=item B<make> 203 204 my $make = make; 205 206Returns a good guess at the make to run. 207 208=cut 209 210sub make { 211 my $make = $Config{make}; 212 $make = $ENV{MAKE} if exists $ENV{MAKE}; 213 214 return $make; 215} 216 217=item B<make_run> 218 219 my $make_run = make_run; 220 221Returns the make to run as with make() plus any necessary switches. 222 223=cut 224 225sub make_run { 226 my $make = make; 227 $make .= ' -nologo' if $make eq 'nmake'; 228 229 return $make; 230} 231 232=item B<make_macro> 233 234 my $make_cmd = make_macro($make, $target, %macros); 235 236Returns the command necessary to run $make on the given $target using 237the given %macros. 238 239 my $make_test_verbose = make_macro(make_run(), 'test', 240 TEST_VERBOSE => 1); 241 242This is important because VMS's make utilities have a completely 243different calling convention than Unix or Windows. 244 245%macros is actually a list of tuples, so the order will be preserved. 246 247=cut 248 249sub make_macro { 250 my($make, $target) = (shift, shift); 251 252 my $is_mms = $make =~ /^MM(K|S)/i; 253 254 my $cmd = $make; 255 my $macros = ''; 256 while( my($key,$val) = splice(@_, 0, 2) ) { 257 if( $is_mms ) { 258 $macros .= qq{/macro="$key=$val"}; 259 } 260 else { 261 $macros .= qq{ $key=$val}; 262 } 263 } 264 265 return $is_mms ? "$make$macros $target" : "$make $target $macros"; 266} 267 268=item B<calibrate_mtime> 269 270 my $mtime = calibrate_mtime; 271 272When building on NFS, file modification times can often lose touch 273with reality. This returns the mtime of a file which has just been 274touched. 275 276=cut 277 278sub calibrate_mtime { 279 open(FILE, ">calibrate_mtime.tmp") || die $!; 280 print FILE "foo"; 281 close FILE; 282 my($mtime) = (stat('calibrate_mtime.tmp'))[9]; 283 unlink 'calibrate_mtime.tmp'; 284 return $mtime; 285} 286 287=item B<run> 288 289 my $out = run($command); 290 my @out = run($command); 291 292Runs the given $command as an external program returning at least STDOUT 293as $out. If possible it will return STDOUT and STDERR combined as you 294would expect to see on a screen. 295 296=cut 297 298sub run { 299 my $cmd = shift; 300 301 use ExtUtils::MM; 302 303 # Unix, modern Windows and OS/2 from 5.005_54 up can handle 2>&1 304 # This makes our failure diagnostics nicer to read. 305 if( MM->os_flavor_is('Unix') or 306 (MM->os_flavor_is('Win32') and !MM->os_flavor_is('Win9x')) or 307 ($] > 5.00554 and MM->os_flavor_is('OS/2')) 308 ) { 309 return `$cmd 2>&1`; 310 } 311 else { 312 return `$cmd`; 313 } 314} 315 316 317=item B<run_ok> 318 319 my @out = run_ok($cmd); 320 321Like run() but it tests that the result exited normally. 322 323The output from run() will be used as a diagnostic if it fails. 324 325=cut 326 327sub run_ok { 328 my $tb = Test::Builder->new; 329 330 my @out = run(@_); 331 332 $tb->cmp_ok( $?, '==', 0, "run(@_)" ) || $tb->diag(@out); 333 334 return wantarray ? @out : join "", @out; 335} 336 337=item B<setup_mm_test_root> 338 339Creates a rooted logical to avoid the 8-level limit on older VMS systems. 340No action taken on non-VMS systems. 341 342=cut 343 344sub setup_mm_test_root { 345 if( $Is_VMS ) { 346 # On older systems we might exceed the 8-level directory depth limit 347 # imposed by RMS. We get around this with a rooted logical, but we 348 # can't create logical names with attributes in Perl, so we do it 349 # in a DCL subprocess and put it in the job table so the parent sees it. 350 open( MMTMP, '>mmtesttmp.com' ) || 351 die "Error creating command file; $!"; 352 print MMTMP <<'COMMAND'; 353$ MM_TEST_ROOT = F$PARSE("SYS$DISK:[--]",,,,"NO_CONCEAL")-".][000000"-"]["-"].;"+".]" 354$ DEFINE/JOB/NOLOG/TRANSLATION=CONCEALED MM_TEST_ROOT 'MM_TEST_ROOT' 355COMMAND 356 close MMTMP; 357 358 system '@mmtesttmp.com'; 359 1 while unlink 'mmtesttmp.com'; 360 } 361} 362 363=item have_compiler 364 365 $have_compiler = have_compiler; 366 367Returns true if there is a compiler available for XS builds. 368 369=cut 370 371sub have_compiler { 372 my $have_compiler = 0; 373 374 # ExtUtils::CBuilder prints its compilation lines to the screen. 375 # Shut it up. 376 use TieOut; 377 local *STDOUT = *STDOUT; 378 local *STDERR = *STDERR; 379 380 tie *STDOUT, 'TieOut'; 381 tie *STDERR, 'TieOut'; 382 383 eval { 384 require ExtUtils::CBuilder; 385 my $cb = ExtUtils::CBuilder->new; 386 387 $have_compiler = $cb->have_compiler; 388 }; 389 390 return $have_compiler; 391} 392 393=item slurp 394 395 $contents = slurp($filename); 396 397Returns the $contents of $filename. 398 399Will die if $filename cannot be opened. 400 401=cut 402 403sub slurp { 404 my $filename = shift; 405 406 local $/ = undef; 407 open my $fh, $filename or die "Can't open $filename for reading: $!"; 408 my $text = <$fh>; 409 close $fh; 410 411 return $text; 412} 413 414=back 415 416=head1 AUTHOR 417 418Michael G Schwern <schwern@pobox.com> 419 420=cut 421 4221; 423