1b39c5158Smillertpackage MakeMaker::Test::Utils; 2b39c5158Smillert 3b39c5158Smillertuse File::Spec; 4b39c5158Smillertuse strict; 5*eac174f2Safresh1use warnings; 6b39c5158Smillertuse Config; 79f11ffb7Safresh1use Cwd qw(getcwd); 89f11ffb7Safresh1use Carp qw(croak); 99f11ffb7Safresh1use File::Path; 109f11ffb7Safresh1use File::Basename; 11b39c5158Smillert 12b39c5158Smillertrequire Exporter; 13b39c5158Smillertour @ISA = qw(Exporter); 14b39c5158Smillert 15b39c5158Smillertour $Is_VMS = $^O eq 'VMS'; 16b39c5158Smillertour $Is_MacOS = $^O eq 'MacOS'; 17898184e3Ssthenour $Is_FreeBSD = $^O eq 'freebsd'; 18b39c5158Smillert 19b39c5158Smillertour @EXPORT = qw(which_perl perl_lib makefile_name makefile_backup 20b39c5158Smillert make make_run run make_macro calibrate_mtime 21b39c5158Smillert have_compiler slurp 22b39c5158Smillert $Is_VMS $Is_MacOS 23b39c5158Smillert run_ok 249f11ffb7Safresh1 hash2files 259f11ffb7Safresh1 in_dir 26b39c5158Smillert ); 27b39c5158Smillert 28b39c5158Smillert 29b39c5158Smillert# Setup the code to clean out %ENV 30b39c5158Smillert{ 31b39c5158Smillert # Environment variables which might effect our testing 32b39c5158Smillert my @delete_env_keys = qw( 33b39c5158Smillert PERL_MM_OPT 34b39c5158Smillert PERL_MM_USE_DEFAULT 35b39c5158Smillert HARNESS_TIMER 36b39c5158Smillert HARNESS_OPTIONS 37b39c5158Smillert HARNESS_VERBOSE 38b39c5158Smillert PREFIX 39b39c5158Smillert MAKEFLAGS 40b8851fccSafresh1 PERL_INSTALL_QUIET 41b39c5158Smillert ); 42b39c5158Smillert 43898184e3Ssthen my %default_env_keys; 44898184e3Ssthen 45898184e3Ssthen # Inform the BSDPAN hacks not to register modules installed for testing. 46898184e3Ssthen $default_env_keys{PORTOBJFORMAT} = 1 if $Is_FreeBSD; 47898184e3Ssthen 486fb12b70Safresh1 # https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker/issues/65 496fb12b70Safresh1 $default_env_keys{ACTIVEPERL_CONFIG_SILENT} = 1; 506fb12b70Safresh1 51b39c5158Smillert # Remember the ENV values because on VMS %ENV is global 52b39c5158Smillert # to the user, not the process. 53b39c5158Smillert my %restore_env_keys; 54b39c5158Smillert 55b39c5158Smillert sub clean_env { 56898184e3Ssthen for my $key (keys %default_env_keys) { 57898184e3Ssthen $ENV{$key} = $default_env_keys{$key} unless $ENV{$key}; 58898184e3Ssthen } 59898184e3Ssthen 60b39c5158Smillert for my $key (@delete_env_keys) { 61b39c5158Smillert if( exists $ENV{$key} ) { 62b39c5158Smillert $restore_env_keys{$key} = delete $ENV{$key}; 63b39c5158Smillert } 64b39c5158Smillert else { 65b39c5158Smillert delete $ENV{$key}; 66b39c5158Smillert } 67b39c5158Smillert } 68b39c5158Smillert } 69b39c5158Smillert 70b39c5158Smillert END { 71b39c5158Smillert while( my($key, $val) = each %restore_env_keys ) { 72b39c5158Smillert $ENV{$key} = $val; 73b39c5158Smillert } 74b39c5158Smillert } 75b39c5158Smillert} 76b39c5158Smillertclean_env(); 77b39c5158Smillert 78b39c5158Smillert 79b39c5158Smillert=head1 NAME 80b39c5158Smillert 81b39c5158SmillertMakeMaker::Test::Utils - Utility routines for testing MakeMaker 82b39c5158Smillert 83b39c5158Smillert=head1 SYNOPSIS 84b39c5158Smillert 85b39c5158Smillert use MakeMaker::Test::Utils; 86b39c5158Smillert 87b39c5158Smillert my $perl = which_perl; 88b39c5158Smillert perl_lib; 89b39c5158Smillert 90b39c5158Smillert my $makefile = makefile_name; 91b39c5158Smillert my $makefile_back = makefile_backup; 92b39c5158Smillert 93b39c5158Smillert my $make = make; 94b39c5158Smillert my $make_run = make_run; 95b39c5158Smillert make_macro($make, $targ, %macros); 96b39c5158Smillert 97b39c5158Smillert my $mtime = calibrate_mtime; 98b39c5158Smillert 99b39c5158Smillert my $out = run($cmd); 100b39c5158Smillert 101b39c5158Smillert my $have_compiler = have_compiler(); 102b39c5158Smillert 103b39c5158Smillert my $text = slurp($filename); 104b39c5158Smillert 105b39c5158Smillert 106b39c5158Smillert=head1 DESCRIPTION 107b39c5158Smillert 108b39c5158SmillertA consolidation of little utility functions used throughout the 109b39c5158SmillertMakeMaker test suite. 110b39c5158Smillert 111b39c5158Smillert=head2 Functions 112b39c5158Smillert 113b39c5158SmillertThe following are exported by default. 114b39c5158Smillert 115b39c5158Smillert=over 4 116b39c5158Smillert 117b39c5158Smillert=item B<which_perl> 118b39c5158Smillert 119b39c5158Smillert my $perl = which_perl; 120b39c5158Smillert 121b39c5158SmillertReturns a path to perl which is safe to use in a command line, no 122b39c5158Smillertmatter where you chdir to. 123b39c5158Smillert 124b39c5158Smillert=cut 125b39c5158Smillert 126b39c5158Smillertsub which_perl { 127b39c5158Smillert my $perl = $^X; 128b39c5158Smillert $perl ||= 'perl'; 129b39c5158Smillert 130b39c5158Smillert # VMS should have 'perl' aliased properly 131b39c5158Smillert return $perl if $Is_VMS; 132b39c5158Smillert 133b39c5158Smillert $perl .= $Config{exe_ext} unless $perl =~ m/$Config{exe_ext}$/i; 134b39c5158Smillert 135b39c5158Smillert my $perlpath = File::Spec->rel2abs( $perl ); 136b39c5158Smillert unless( $Is_MacOS || -x $perlpath ) { 137b39c5158Smillert # $^X was probably 'perl' 138b39c5158Smillert 139b39c5158Smillert # When building in the core, *don't* go off and find 140b39c5158Smillert # another perl 141b39c5158Smillert die "Can't find a perl to use (\$^X=$^X), (\$perlpath=$perlpath)" 142b39c5158Smillert if $ENV{PERL_CORE}; 143b39c5158Smillert 144b39c5158Smillert foreach my $path (File::Spec->path) { 145b39c5158Smillert $perlpath = File::Spec->catfile($path, $perl); 146b39c5158Smillert last if -x $perlpath; 147b39c5158Smillert } 148b39c5158Smillert } 149b8851fccSafresh1 $perlpath = qq{"$perlpath"}; # "safe... in a command line" even with spaces 150b39c5158Smillert 151b39c5158Smillert return $perlpath; 152b39c5158Smillert} 153b39c5158Smillert 154b39c5158Smillert=item B<perl_lib> 155b39c5158Smillert 156b39c5158Smillert perl_lib; 157b39c5158Smillert 158b39c5158SmillertSets up environment variables so perl can find its libraries. 159b39c5158Smillert 160b39c5158Smillert=cut 161b39c5158Smillert 162b39c5158Smillertmy $old5lib = $ENV{PERL5LIB}; 163b39c5158Smillertmy $had5lib = exists $ENV{PERL5LIB}; 164b39c5158Smillertsub perl_lib { 1659f11ffb7Safresh1 my $basecwd = (File::Spec->splitdir(getcwd))[-1]; 1669f11ffb7Safresh1 croak "Basename of cwd needs to be 't' but is '$basecwd'\n" 1679f11ffb7Safresh1 unless $basecwd eq 't'; 168b39c5158Smillert # perl-src/t/ 169b39c5158Smillert my $lib = $ENV{PERL_CORE} ? qq{../lib} 170b39c5158Smillert # ExtUtils-MakeMaker/t/ 171b39c5158Smillert : qq{../blib/lib}; 172b39c5158Smillert $lib = File::Spec->rel2abs($lib); 173b39c5158Smillert my @libs = ($lib); 174b39c5158Smillert push @libs, $ENV{PERL5LIB} if exists $ENV{PERL5LIB}; 175b39c5158Smillert $ENV{PERL5LIB} = join($Config{path_sep}, @libs); 176b39c5158Smillert unshift @INC, $lib; 177b39c5158Smillert} 178b39c5158Smillert 179b39c5158SmillertEND { 180b39c5158Smillert if( $had5lib ) { 181b39c5158Smillert $ENV{PERL5LIB} = $old5lib; 182b39c5158Smillert } 183b39c5158Smillert else { 184b39c5158Smillert delete $ENV{PERL5LIB}; 185b39c5158Smillert } 186b39c5158Smillert} 187b39c5158Smillert 188b39c5158Smillert 189b39c5158Smillert=item B<makefile_name> 190b39c5158Smillert 191b39c5158Smillert my $makefile = makefile_name; 192b39c5158Smillert 193b39c5158SmillertMakeMaker doesn't always generate 'Makefile'. It returns what it 194b39c5158Smillertshould generate. 195b39c5158Smillert 196b39c5158Smillert=cut 197b39c5158Smillert 198b39c5158Smillertsub makefile_name { 199b39c5158Smillert return $Is_VMS ? 'Descrip.MMS' : 'Makefile'; 200b39c5158Smillert} 201b39c5158Smillert 202b39c5158Smillert=item B<makefile_backup> 203b39c5158Smillert 204b39c5158Smillert my $makefile_old = makefile_backup; 205b39c5158Smillert 206b39c5158SmillertReturns the name MakeMaker will use for a backup of the current 207b39c5158SmillertMakefile. 208b39c5158Smillert 209b39c5158Smillert=cut 210b39c5158Smillert 211b39c5158Smillertsub makefile_backup { 212b39c5158Smillert my $makefile = makefile_name; 213b39c5158Smillert return $Is_VMS ? "$makefile".'_old' : "$makefile.old"; 214b39c5158Smillert} 215b39c5158Smillert 216b39c5158Smillert=item B<make> 217b39c5158Smillert 218b39c5158Smillert my $make = make; 219b39c5158Smillert 220b39c5158SmillertReturns a good guess at the make to run. 221b39c5158Smillert 222b39c5158Smillert=cut 223b39c5158Smillert 224b39c5158Smillertsub make { 225b39c5158Smillert my $make = $Config{make}; 226b39c5158Smillert $make = $ENV{MAKE} if exists $ENV{MAKE}; 227b39c5158Smillert 228b8851fccSafresh1 return $Is_VMS ? $make : qq{"$make"}; 229b39c5158Smillert} 230b39c5158Smillert 231b39c5158Smillert=item B<make_run> 232b39c5158Smillert 233b39c5158Smillert my $make_run = make_run; 234b39c5158Smillert 235b39c5158SmillertReturns the make to run as with make() plus any necessary switches. 236b39c5158Smillert 237b39c5158Smillert=cut 238b39c5158Smillert 239b39c5158Smillertsub make_run { 240b39c5158Smillert my $make = make; 241b39c5158Smillert $make .= ' -nologo' if $make eq 'nmake'; 242b39c5158Smillert 243b39c5158Smillert return $make; 244b39c5158Smillert} 245b39c5158Smillert 246b39c5158Smillert=item B<make_macro> 247b39c5158Smillert 248b39c5158Smillert my $make_cmd = make_macro($make, $target, %macros); 249b39c5158Smillert 250b39c5158SmillertReturns the command necessary to run $make on the given $target using 251b39c5158Smillertthe given %macros. 252b39c5158Smillert 253b39c5158Smillert my $make_test_verbose = make_macro(make_run(), 'test', 254b39c5158Smillert TEST_VERBOSE => 1); 255b39c5158Smillert 256b39c5158SmillertThis is important because VMS's make utilities have a completely 257b39c5158Smillertdifferent calling convention than Unix or Windows. 258b39c5158Smillert 259b39c5158Smillert%macros is actually a list of tuples, so the order will be preserved. 260b39c5158Smillert 261b39c5158Smillert=cut 262b39c5158Smillert 263b39c5158Smillertsub make_macro { 264b39c5158Smillert my($make, $target) = (shift, shift); 265b39c5158Smillert 266b39c5158Smillert my $is_mms = $make =~ /^MM(K|S)/i; 267b39c5158Smillert 2689f11ffb7Safresh1 my @macros; 269b39c5158Smillert while( my($key,$val) = splice(@_, 0, 2) ) { 2709f11ffb7Safresh1 push @macros, qq{$key=$val}; 2719f11ffb7Safresh1 } 2729f11ffb7Safresh1 my $macros = ''; 2739f11ffb7Safresh1 if (scalar(@macros)) { 274b39c5158Smillert if ($is_mms) { 2759f11ffb7Safresh1 map { $_ = qq{"$_"} } @macros; 2769f11ffb7Safresh1 $macros = '/MACRO=(' . join(',', @macros) . ')'; 277b39c5158Smillert } 278b39c5158Smillert else { 2799f11ffb7Safresh1 $macros = join(' ', @macros); 280b39c5158Smillert } 281b39c5158Smillert } 282b39c5158Smillert 283b39c5158Smillert return $is_mms ? "$make$macros $target" : "$make $target $macros"; 284b39c5158Smillert} 285b39c5158Smillert 286b39c5158Smillert=item B<calibrate_mtime> 287b39c5158Smillert 288b39c5158Smillert my $mtime = calibrate_mtime; 289b39c5158Smillert 290b39c5158SmillertWhen building on NFS, file modification times can often lose touch 291b39c5158Smillertwith reality. This returns the mtime of a file which has just been 292b39c5158Smillerttouched. 293b39c5158Smillert 294b39c5158Smillert=cut 295b39c5158Smillert 296b39c5158Smillertsub calibrate_mtime { 2979f11ffb7Safresh1 my $file = "calibrate_mtime-$$.tmp"; 2989f11ffb7Safresh1 open(FILE, ">$file") || die $!; 299b39c5158Smillert print FILE "foo"; 300b39c5158Smillert close FILE; 3019f11ffb7Safresh1 my($mtime) = (stat($file))[9]; 3029f11ffb7Safresh1 unlink $file; 303b39c5158Smillert return $mtime; 304b39c5158Smillert} 305b39c5158Smillert 306b39c5158Smillert=item B<run> 307b39c5158Smillert 308b39c5158Smillert my $out = run($command); 309b39c5158Smillert my @out = run($command); 310b39c5158Smillert 311b39c5158SmillertRuns the given $command as an external program returning at least STDOUT 312b39c5158Smillertas $out. If possible it will return STDOUT and STDERR combined as you 313b39c5158Smillertwould expect to see on a screen. 314b39c5158Smillert 315b39c5158Smillert=cut 316b39c5158Smillert 317b39c5158Smillertsub run { 318b39c5158Smillert my $cmd = shift; 319b39c5158Smillert 320b39c5158Smillert use ExtUtils::MM; 321b39c5158Smillert 322b39c5158Smillert # Unix, modern Windows and OS/2 from 5.005_54 up can handle 2>&1 323b39c5158Smillert # This makes our failure diagnostics nicer to read. 324b8851fccSafresh1 if (MM->can_redirect_error) { 325b39c5158Smillert return `$cmd 2>&1`; 326b39c5158Smillert } 327b39c5158Smillert else { 328b39c5158Smillert return `$cmd`; 329b39c5158Smillert } 330b39c5158Smillert} 331b39c5158Smillert 332b39c5158Smillert 333b39c5158Smillert=item B<run_ok> 334b39c5158Smillert 335b39c5158Smillert my @out = run_ok($cmd); 336b39c5158Smillert 337b39c5158SmillertLike run() but it tests that the result exited normally. 338b39c5158Smillert 339b39c5158SmillertThe output from run() will be used as a diagnostic if it fails. 340b39c5158Smillert 341b39c5158Smillert=cut 342b39c5158Smillert 343b39c5158Smillertsub run_ok { 344b39c5158Smillert my $tb = Test::Builder->new; 345b39c5158Smillert 346b39c5158Smillert my @out = run(@_); 347b39c5158Smillert 348b39c5158Smillert $tb->cmp_ok( $?, '==', 0, "run(@_)" ) || $tb->diag(@out); 349b39c5158Smillert 350b39c5158Smillert return wantarray ? @out : join "", @out; 351b39c5158Smillert} 352b39c5158Smillert 353b39c5158Smillert=item have_compiler 354b39c5158Smillert 355b39c5158Smillert $have_compiler = have_compiler; 356b39c5158Smillert 357b39c5158SmillertReturns true if there is a compiler available for XS builds. 358b39c5158Smillert 359b39c5158Smillert=cut 360b39c5158Smillert 361b39c5158Smillertsub have_compiler { 362*eac174f2Safresh1 return 1 if $ENV{PERL_CORE}; 363*eac174f2Safresh1 364b39c5158Smillert my $have_compiler = 0; 365*eac174f2Safresh1 366*eac174f2Safresh1 in_dir(sub { 367b39c5158Smillert eval { 368b39c5158Smillert require ExtUtils::CBuilder; 3699f11ffb7Safresh1 my $cb = ExtUtils::CBuilder->new(quiet=>1); 370b39c5158Smillert $have_compiler = $cb->have_compiler; 371b39c5158Smillert }; 372*eac174f2Safresh1 }); 373*eac174f2Safresh1 374b39c5158Smillert return $have_compiler; 375b39c5158Smillert} 376b39c5158Smillert 377b39c5158Smillert=item slurp 378b39c5158Smillert 379b39c5158Smillert $contents = slurp($filename); 380b39c5158Smillert 381b39c5158SmillertReturns the $contents of $filename. 382b39c5158Smillert 383b39c5158SmillertWill die if $filename cannot be opened. 384b39c5158Smillert 385b39c5158Smillert=cut 386b39c5158Smillert 387b39c5158Smillertsub slurp { 388b39c5158Smillert my $filename = shift; 389b39c5158Smillert 390b39c5158Smillert local $/ = undef; 391b39c5158Smillert open my $fh, $filename or die "Can't open $filename for reading: $!"; 392b39c5158Smillert my $text = <$fh>; 393b39c5158Smillert close $fh; 394b39c5158Smillert 395b39c5158Smillert return $text; 396b39c5158Smillert} 397b39c5158Smillert 3989f11ffb7Safresh1=item hash2files 3999f11ffb7Safresh1 4009f11ffb7Safresh1 hash2files('dirname', { 'filename' => 'some content' }); 4019f11ffb7Safresh1 4029f11ffb7Safresh1Goes through given hash-ref, treating each key as a /-separated filename 4039f11ffb7Safresh1under the specified directory, and writing the value into it. Will create 4049f11ffb7Safresh1any necessary directories. 4059f11ffb7Safresh1 4069f11ffb7Safresh1Will die if errors occur. 4079f11ffb7Safresh1 4089f11ffb7Safresh1=cut 4099f11ffb7Safresh1 4109f11ffb7Safresh1sub hash2files { 4119f11ffb7Safresh1 my ($prefix, $hashref) = @_; 4129f11ffb7Safresh1 while(my ($file, $text) = each %$hashref) { 4139f11ffb7Safresh1 # Convert to a relative, native file path. 4149f11ffb7Safresh1 $file = File::Spec->catfile(File::Spec->curdir, $prefix, split m{\/}, $file); 4159f11ffb7Safresh1 my $dir = dirname($file); 4169f11ffb7Safresh1 mkpath $dir; 41756d68f1eSafresh1 my $utf8 = ("$]" < 5.008 or !$Config{useperlio}) ? "" : ":utf8"; 4189f11ffb7Safresh1 open(FILE, ">$utf8", $file) || die "Can't create $file: $!"; 4199f11ffb7Safresh1 print FILE $text; 4209f11ffb7Safresh1 close FILE; 4219f11ffb7Safresh1 # ensure file at least 1 second old for makes that assume 4229f11ffb7Safresh1 # files with the same time are out of date. 4239f11ffb7Safresh1 my $time = calibrate_mtime(); 4249f11ffb7Safresh1 utime $time, $time - 1, $file; 4259f11ffb7Safresh1 } 4269f11ffb7Safresh1} 4279f11ffb7Safresh1 4289f11ffb7Safresh1=item in_dir 4299f11ffb7Safresh1 4309f11ffb7Safresh1 $retval = in_dir(\&coderef); 4319f11ffb7Safresh1 $retval = in_dir(\&coderef, $specified_dir); 4329f11ffb7Safresh1 $retval = in_dir { somecode(); }; 4339f11ffb7Safresh1 $retval = in_dir { somecode(); } $specified_dir; 4349f11ffb7Safresh1 4359f11ffb7Safresh1Does a C<chdir> to either a directory. If none is specified, one is 4369f11ffb7Safresh1created with L<File::Temp> and then automatically deleted after. It ends 4379f11ffb7Safresh1by C<chdir>ing back to where it started. 4389f11ffb7Safresh1 4399f11ffb7Safresh1If the given code throws an exception, it will be re-thrown after the 4409f11ffb7Safresh1re-C<chdir>. 4419f11ffb7Safresh1 4429f11ffb7Safresh1Returns the return value of the given code. 4439f11ffb7Safresh1 4449f11ffb7Safresh1=cut 4459f11ffb7Safresh1 4469f11ffb7Safresh1sub in_dir(&;$) { 4479f11ffb7Safresh1 my $code = shift; 4489f11ffb7Safresh1 require File::Temp; 4499f11ffb7Safresh1 my $dir = shift || File::Temp::tempdir(TMPDIR => 1, CLEANUP => 1); 4509f11ffb7Safresh1 # chdir to the new directory 4519f11ffb7Safresh1 my $orig_dir = getcwd(); 4529f11ffb7Safresh1 chdir $dir or die "Can't chdir to $dir: $!"; 4539f11ffb7Safresh1 # Run the code, but trap the error so we can chdir back 4549f11ffb7Safresh1 my $return; 4559f11ffb7Safresh1 my $ok = eval { $return = $code->(); 1; }; 4569f11ffb7Safresh1 my $err = $@; 4579f11ffb7Safresh1 # chdir back 4589f11ffb7Safresh1 chdir $orig_dir or die "Can't chdir to $orig_dir: $!"; 4599f11ffb7Safresh1 # rethrow if necessary 4609f11ffb7Safresh1 die $err unless $ok; 4619f11ffb7Safresh1 return $return; 4629f11ffb7Safresh1} 4639f11ffb7Safresh1 464b39c5158Smillert=back 465b39c5158Smillert 466b39c5158Smillert=head1 AUTHOR 467b39c5158Smillert 468b39c5158SmillertMichael G Schwern <schwern@pobox.com> 469b39c5158Smillert 470b39c5158Smillert=cut 471b39c5158Smillert 472b39c5158Smillert1; 473