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 Run this before changing directories.
 139
 140 =cut
 141
 142 my $old5lib = $ENV{PERL5LIB};
 143 my $had5lib = exists $ENV{PERL5LIB};
 144 sub perl_lib {
 145     if ($ENV{PERL_CORE}) {
 146         # Whilst we'll be running in perl-src/cpan/$distname/t/
 147         # instead of blib, our code will be copied with all the other code to
 148         # the top-level library.
 149         # $ENV{PERL5LIB} will be set with this, but (by default) it's a relative
 150         # path.
 151         $ENV{PERL5LIB} = join $Config{path_sep}, map {
 152             File::Spec->rel2abs($_) } split quotemeta($Config{path_sep}), $ENV{PERL5LIB};
 153         @INC = map { File::Spec->rel2abs($_) } @INC;
 154     } else {
 155         my $lib = 'blib/lib';
 156         $lib = File::Spec->rel2abs($lib);
 157         my @libs = ($lib);
 158         push @libs, $ENV{PERL5LIB} if exists $ENV{PERL5LIB};
 159         $ENV{PERL5LIB} = join($Config{path_sep}, @libs);
 160         unshift @INC, $lib;
 161     }
 162 }
 163
 164 END {
 165     if( $had5lib ) {
 166         $ENV{PERL5LIB} = $old5lib;
 167     }
 168     else {
 169         delete $ENV{PERL5LIB};
 170     }
 171 }
 172
 173
 174 =item B<makefile_name>
 175
 176   my $makefile = makefile_name;
 177
 178 MakeMaker doesn't always generate 'Makefile'.  It returns what it
 179 should generate.
 180
 181 =cut
 182
 183 sub makefile_name {
 184     return $Is_VMS ? 'Descrip.MMS' : 'Makefile';
 185 }
 186
 187 =item B<makefile_backup>
 188
 189   my $makefile_old = makefile_backup;
 190
 191 Returns the name MakeMaker will use for a backup of the current
 192 Makefile.
 193
 194 =cut
 195
 196 sub makefile_backup {
 197     my $makefile = makefile_name;
 198     return $Is_VMS ? "$makefile".'_old' : "$makefile.old";
 199 }
 200
 201 =item B<make>
 202
 203   my $make = make;
 204
 205 Returns a good guess at the make to run.
 206
 207 =cut
 208
 209 sub make {
 210     my $make = $Config{make};
 211     $make = $ENV{MAKE} if exists $ENV{MAKE};
 212
 213     return $make;
 214 }
 215
 216 =item B<make_run>
 217
 218   my $make_run = make_run;
 219
 220 Returns the make to run as with make() plus any necessary switches.
 221
 222 =cut
 223
 224 sub make_run {
 225     my $make = make;
 226     $make .= ' -nologo' if $make eq 'nmake';
 227
 228     return $make;
 229 }
 230
 231 =item B<make_macro>
 232
 233     my $make_cmd = make_macro($make, $target, %macros);
 234
 235 Returns the command necessary to run $make on the given $target using
 236 the given %macros.
 237
 238   my $make_test_verbose = make_macro(make_run(), 'test',
 239                                      TEST_VERBOSE => 1);
 240
 241 This is important because VMS's make utilities have a completely
 242 different calling convention than Unix or Windows.
 243
 244 %macros is actually a list of tuples, so the order will be preserved.
 245
 246 =cut
 247
 248 sub make_macro {
 249     my($make, $target) = (shift, shift);
 250
 251     my $is_mms = $make =~ /^MM(K|S)/i;
 252
 253     my $cmd = $make;
 254     my $macros = '';
 255     while( my($key,$val) = splice(@_, 0, 2) ) {
 256         if( $is_mms ) {
 257             $macros .= qq{/macro="$key=$val"};
 258         }
 259         else {
 260             $macros .= qq{ $key=$val};
 261         }
 262     }
 263
 264     return $is_mms ? "$make$macros $target" : "$make $target $macros";
 265 }
 266
 267 =item B<calibrate_mtime>
 268
 269   my $mtime = calibrate_mtime;
 270
 271 When building on NFS, file modification times can often lose touch
 272 with reality.  This returns the mtime of a file which has just been
 273 touched.
 274
 275 =cut
 276
 277 sub calibrate_mtime {
 278     open(FILE, ">calibrate_mtime.tmp") || die $!;
 279     print FILE "foo";
 280     close FILE;
 281     my($mtime) = (stat('calibrate_mtime.tmp'))[9];
 282     unlink 'calibrate_mtime.tmp';
 283     return $mtime;
 284 }
 285
 286 =item B<run>
 287
 288   my $out = run($command);
 289   my @out = run($command);
 290
 291 Runs the given $command as an external program returning at least STDOUT
 292 as $out.  If possible it will return STDOUT and STDERR combined as you
 293 would expect to see on a screen.
 294
 295 =cut
 296
 297 sub run {
 298     my $cmd = shift;
 299
 300     use ExtUtils::MM;
 301
 302     # Unix, modern Windows and OS/2 from 5.005_54 up can handle can handle 2>&1
 303     # This makes our failure diagnostics nicer to read.
 304     if( MM->os_flavor_is('Unix')                                   or
 305         (MM->os_flavor_is('Win32') and !MM->os_flavor_is('Win9x')) or
 306         ($] > 5.00554 and MM->os_flavor_is('OS/2'))
 307       ) {
 308         return `$cmd 2>&1`;
 309     }
 310     else {
 311         return `$cmd`;
 312     }
 313 }
 314
 315
 316 =item B<run_ok>
 317
 318   my @out = run_ok($cmd);
 319
 320 Like run() but it tests that the result exited normally.
 321
 322 The output from run() will be used as a diagnostic if it fails.
 323
 324 =cut
 325
 326 sub run_ok {
 327     my $tb = Test::Builder->new;
 328
 329     my @out = run(@_);
 330
 331     $tb->cmp_ok( $?, '==', 0, "run(@_)" ) || $tb->diag(@out);
 332
 333     return wantarray ? @out : join "", @out;
 334 }
 335
 336 =item B<setup_mm_test_root>
 337
 338 Creates a rooted logical to avoid the 8-level limit on older VMS systems.
 339 No action taken on non-VMS systems.
 340
 341 =cut
 342
 343 sub setup_mm_test_root {
 344     if( $Is_VMS ) {
 345         # On older systems we might exceed the 8-level directory depth limit
 346         # imposed by RMS.  We get around this with a rooted logical, but we
 347         # can't create logical names with attributes in Perl, so we do it
 348         # in a DCL subprocess and put it in the job table so the parent sees it.
 349         open( MMTMP, '>mmtesttmp.com' ) ||
 350           die "Error creating command file; $!";
 351         print MMTMP <<'COMMAND';
 352 $ MM_TEST_ROOT = F$PARSE("SYS$DISK:[--]",,,,"NO_CONCEAL")-".][000000"-"]["-"].;"+".]"
 353 $ DEFINE/JOB/NOLOG/TRANSLATION=CONCEALED MM_TEST_ROOT 'MM_TEST_ROOT'
 354 COMMAND
 355         close MMTMP;
 356
 357         system '@mmtesttmp.com';
 358         1 while unlink 'mmtesttmp.com';
 359     }
 360 }
 361
 362 =item have_compiler
 363
 364   $have_compiler = have_compiler;
 365
 366 Returns true if there is a compiler available for XS builds.
 367
 368 =cut
 369
 370 sub have_compiler {
 371     my $have_compiler = 0;
 372
 373     # ExtUtils::CBuilder prints its compilation lines to the screen.
 374     # Shut it up.
 375     use TieOut;
 376     local *STDOUT = *STDOUT;
 377     local *STDERR = *STDERR;
 378
 379     tie *STDOUT, 'TieOut';
 380     tie *STDERR, 'TieOut';
 381
 382     eval {
 383         require ExtUtils::CBuilder;
 384         my $cb = ExtUtils::CBuilder->new;
 385
 386         $have_compiler = $cb->have_compiler;
 387     };
 388
 389     return $have_compiler;
 390 }
 391
 392 =item slurp
 393
 394   $contents = slurp($filename);
 395
 396 Returns the $contents of $filename.
 397
 398 Will die if $filename cannot be opened.
 399
 400 =cut
 401
 402 sub slurp {
 403     my $filename = shift;
 404
 405     local $/ = undef;
 406     open my $fh, $filename or die "Can't open $filename for reading: $!";
 407     my $text = <$fh>;
 408     close $fh;
 409
 410     return $text;
 411 }
 412
 413 =back
 414
 415 =head1 AUTHOR
 416
 417 Michael G Schwern <schwern@pobox.com>
 418
 419 =cut
 420
 421 1;