dist/ExtUtils-Install/t/lib/MakeMaker/Test/Utils.pm

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