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