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