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