This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Help ExtUtils::Install's tests find PERL_SRC on VMS.
[perl5.git] / dist / ExtUtils-Install / t / lib / MakeMaker / Test / Utils.pm
CommitLineData
fb78ba4b
NC
1package MakeMaker::Test::Utils;
2
3use File::Spec;
4use strict;
5use Config;
6
7require Exporter;
8our @ISA = qw(Exporter);
9
10our $Is_VMS = $^O eq 'VMS';
11our $Is_MacOS = $^O eq 'MacOS';
12
13our @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}
56clean_env();
57
58
59=head1 NAME
60
61MakeMaker::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
88A consolidation of little utility functions used through out the
89MakeMaker test suite.
90
91=head2 Functions
92
93The following are exported by default.
94
95=over 4
96
97=item B<which_perl>
98
99 my $perl = which_perl;
100
101Returns a path to perl which is safe to use in a command line, no
102matter where you chdir to.
103
104=cut
105
106sub 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
137Sets up environment variables so perl can find its libraries.
fc5e5837 138Run this before changing directories.
fb78ba4b
NC
139
140=cut
141
142my $old5lib = $ENV{PERL5LIB};
143my $had5lib = exists $ENV{PERL5LIB};
144sub perl_lib {
fc5e5837
NC
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 }
fb78ba4b
NC
162}
163
164END {
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
178MakeMaker doesn't always generate 'Makefile'. It returns what it
179should generate.
180
181=cut
182
183sub makefile_name {
184 return $Is_VMS ? 'Descrip.MMS' : 'Makefile';
185}
186
187=item B<makefile_backup>
188
189 my $makefile_old = makefile_backup;
190
191Returns the name MakeMaker will use for a backup of the current
192Makefile.
193
194=cut
195
196sub 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
205Returns a good guess at the make to run.
206
207=cut
208
209sub 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
220Returns the make to run as with make() plus any necessary switches.
221
222=cut
223
224sub 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
235Returns the command necessary to run $make on the given $target using
236the given %macros.
237
238 my $make_test_verbose = make_macro(make_run(), 'test',
239 TEST_VERBOSE => 1);
240
241This is important because VMS's make utilities have a completely
242different 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
248sub 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
271When building on NFS, file modification times can often lose touch
272with reality. This returns the mtime of a file which has just been
273touched.
274
275=cut
276
277sub 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
291Runs the given $command as an external program returning at least STDOUT
292as $out. If possible it will return STDOUT and STDERR combined as you
293would expect to see on a screen.
294
295=cut
296
297sub 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
320Like run() but it tests that the result exited normally.
321
322The output from run() will be used as a diagnostic if it fails.
323
324=cut
325
326sub 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
338Creates a rooted logical to avoid the 8-level limit on older VMS systems.
339No action taken on non-VMS systems.
340
341=cut
342
343sub 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';
26c80adc 352$ MM_TEST_ROOT = F$PARSE("SYS$DISK:[--]",,,,"NO_CONCEAL")-".][000000"-"]["-"].;"+".]"
fb78ba4b
NC
353$ DEFINE/JOB/NOLOG/TRANSLATION=CONCEALED MM_TEST_ROOT 'MM_TEST_ROOT'
354COMMAND
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
366Returns true if there is a compiler available for XS builds.
367
368=cut
369
370sub 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
396Returns the $contents of $filename.
397
398Will die if $filename cannot be opened.
399
400=cut
401
402sub 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
417Michael G Schwern <schwern@pobox.com>
418
419=cut
420
4211;