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