This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
c3c214ced6f66e3c3e7f5ee47f3d9eb3bcb71dab
[perl5.git] / 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 $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;