t/lib/MakeMaker/Test/Utils.pm

   1 package MakeMaker::Test::Utils;
   2
   3 use File::Spec;
   4 use strict;
   5 use Config;
   6
   7 use vars qw($VERSION @ISA @EXPORT);
   8
   9 require Exporter;
  10 @ISA = qw(Exporter);
  11
  12 $VERSION = 0.02;
  13
  14 @EXPORT = qw(which_perl perl_lib makefile_name makefile_backup
  15              make make_run run make_macro calibrate_mtime
  16             );
  17
  18 my $Is_VMS   = $^O eq 'VMS';
  19 my $Is_MacOS = $^O eq 'MacOS';
  20
  21
  22 =head1 NAME
  23
  24 MakeMaker::Test::Utils - Utility routines for testing MakeMaker
  25
  26 =head1 SYNOPSIS
  27
  28   use MakeMaker::Test::Utils;
  29
  30   my $perl     = which_perl;
  31   perl_lib;
  32
  33   my $makefile      = makefile_name;
  34   my $makefile_back = makefile_backup;
  35
  36   my $make          = make;
  37   my $make_run      = make_run;
  38   make_macro($make, $targ, %macros);
  39
  40   my $mtime         = calibrate_mtime;
  41
  42   my $out           = run($cmd);
  43
  44 =head1 DESCRIPTION
  45
  46 A consolidation of little utility functions used through out the
  47 MakeMaker test suite.
  48
  49 =head2 Functions
  50
  51 The following are exported by default.
  52
  53 =over 4
  54
  55 =item B<which_perl>
  56
  57   my $perl = which_perl;
  58
  59 Returns a path to perl which is safe to use in a command line, no
  60 matter where you chdir to.
  61
  62 =cut
  63
  64 sub which_perl {
  65     my $perl = $^X;
  66     $perl ||= 'perl';
  67
  68     # VMS should have 'perl' aliased properly
  69     return $perl if $Is_VMS;
  70
  71     $perl .= $Config{exe_ext} unless $perl =~ m/$Config{exe_ext}$/i;
  72
  73     my $perlpath = File::Spec->rel2abs( $perl );
  74     unless( $Is_MacOS || -x $perlpath ) {
  75         # $^X was probably 'perl'
  76
  77         # When building in the core, *don't* go off and find
  78         # another perl
  79         die "Can't find a perl to use (\$^X=$^X), (\$perlpath=$perlpath)"
  80           if $ENV{PERL_CORE};
  81
  82         foreach my $path (File::Spec->path) {
  83             $perlpath = File::Spec->catfile($path, $perl);
  84             last if -x $perlpath;
  85         }
  86     }
  87
  88     return $perlpath;
  89 }
  90
  91 =item B<perl_lib>
  92
  93   perl_lib;
  94
  95 Sets up environment variables so perl can find its libraries.
  96
  97 =cut
  98
  99 my $old5lib = $ENV{PERL5LIB};
 100 my $had5lib = exists $ENV{PERL5LIB};
 101 sub perl_lib {
 102                                # perl-src/t/
 103     my $lib =  $ENV{PERL_CORE} ? qq{../lib}
 104                                # ExtUtils-MakeMaker/t/
 105                                : qq{../blib/lib};
 106     $lib = File::Spec->rel2abs($lib);
 107     my @libs = ($lib);
 108     push @libs, $ENV{PERL5LIB} if exists $ENV{PERL5LIB};
 109     $ENV{PERL5LIB} = join($Config{path_sep}, @libs);
 110     unshift @INC, $lib;
 111 }
 112
 113 END {
 114     if( $had5lib ) {
 115         $ENV{PERL5LIB} = $old5lib;
 116     }
 117     else {
 118         delete $ENV{PERL5LIB};
 119     }
 120 }
 121
 122
 123 =item B<makefile_name>
 124
 125   my $makefile = makefile_name;
 126
 127 MakeMaker doesn't always generate 'Makefile'.  It returns what it
 128 should generate.
 129
 130 =cut
 131
 132 sub makefile_name {
 133     return $Is_VMS ? 'Descrip.MMS' : 'Makefile';
 134 }
 135
 136 =item B<makefile_backup>
 137
 138   my $makefile_old = makefile_backup;
 139
 140 Returns the name MakeMaker will use for a backup of the current
 141 Makefile.
 142
 143 =cut
 144
 145 sub makefile_backup {
 146     my $makefile = makefile_name;
 147     return $Is_VMS ? $makefile : "$makefile.old";
 148 }
 149
 150 =item B<make>
 151
 152   my $make = make;
 153
 154 Returns a good guess at the make to run.
 155
 156 =cut
 157
 158 sub make {
 159     my $make = $Config{make};
 160     $make = $ENV{MAKE} if exists $ENV{MAKE};
 161
 162     return $make;
 163 }
 164
 165 =item B<make_run>
 166
 167   my $make_run = make_run;
 168
 169 Returns the make to run as with make() plus any necessary switches.
 170
 171 =cut
 172
 173 sub make_run {
 174     my $make = make;
 175     $make .= ' -nologo' if $make eq 'nmake';
 176
 177     return $make;
 178 }
 179
 180 =item B<make_macro>
 181
 182     my $make_cmd = make_macro($make, $target, %macros);
 183
 184 Returns the command necessary to run $make on the given $target using
 185 the given %macros.
 186
 187   my $make_test_verbose = make_macro(make_run(), 'test',
 188                                      TEST_VERBOSE => 1);
 189
 190 This is important because VMS's make utilities have a completely
 191 different calling convention than Unix or Windows.
 192
 193 %macros is actually a list of tuples, so the order will be preserved.
 194
 195 =cut
 196
 197 sub make_macro {
 198     my($make, $target) = (shift, shift);
 199
 200     my $is_mms = $make =~ /^MM(K|S)/i;
 201
 202     my $cmd = $make;
 203     my $macros = '';
 204     while( my($key,$val) = splice(@_, 0, 2) ) {
 205         if( $is_mms ) {
 206             $macros .= qq{/macro="$key=$val"};
 207         }
 208         else {
 209             $macros .= qq{ $key=$val};
 210         }
 211     }
 212
 213     return $is_mms ? "$make$macros $target" : "$make $target $macros";
 214 }
 215
 216 =item B<calibrate_mtime>
 217
 218   my $mtime = calibrate_mtime;
 219
 220 When building on NFS, file modification times can often lose touch
 221 with reality.  This returns the mtime of a file which has just been
 222 touched.
 223
 224 =cut
 225
 226 sub calibrate_mtime {
 227     open(FILE, ">calibrate_mtime.tmp") || die $!;
 228     print FILE "foo";
 229     close FILE;
 230     my($mtime) = (stat('calibrate_mtime.tmp'))[9];
 231     unlink 'calibrate_mtime.tmp';
 232     return $mtime;
 233 }
 234
 235 =item B<run>
 236
 237   my $out = run($command);
 238   my @out = run($command);
 239
 240 Runs the given $command as an external program returning at least STDOUT
 241 as $out.  If possible it will return STDOUT and STDERR combined as you
 242 would expect to see on a screen.
 243
 244 =cut
 245
 246 sub run {
 247     my $cmd = shift;
 248
 249     require ExtUtils::MM;
 250
 251     # Unix can handle 2>&1 and OS/2 from 5.005_54 up.
 252     # This makes our failure diagnostics nicer to read.
 253     if( MM->os_flavor_is('Unix') or
 254         ($] > 5.00554 and MM->os_flavor_is('OS/2'))
 255       ) {
 256         return `$cmd 2>&1`;
 257     }
 258     else {
 259         return `$cmd`;
 260     }
 261 }
 262
 263 =back
 264
 265 =head1 AUTHOR
 266
 267 Michael G Schwern <schwern@pobox.com>
 268
 269 =cut
 270
 271 1;