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
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 # 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 }
55 clean_env();
56
57
58 =head1 NAME
59
60 MakeMaker::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
76   my $mtime         = calibrate_mtime;
77
78   my $out           = run($cmd);
79
80   my $have_compiler = have_compiler();
81
82   my $text          = slurp($filename);
83
84
85 =head1 DESCRIPTION
86
87 A consolidation of little utility functions used through out the
88 MakeMaker test suite.
89
90 =head2 Functions
91
92 The following are exported by default.
93
94 =over 4
95
96 =item B<which_perl>
97
98   my $perl = which_perl;
99
100 Returns a path to perl which is safe to use in a command line, no
101 matter where you chdir to.
102
103 =cut
104
105 sub which_perl {
106     my $perl = $^X;
107     $perl ||= 'perl';
108
109     # VMS should have 'perl' aliased properly
110     return $perl if $Is_VMS;
111
112     $perl .= $Config{exe_ext} unless $perl =~ m/$Config{exe_ext}$/i;
113
114     my $perlpath = File::Spec->rel2abs( $perl );
115     unless( $Is_MacOS || -x $perlpath ) {
116         # $^X was probably 'perl'
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
123         foreach my $path (File::Spec->path) {
124             $perlpath = File::Spec->catfile($path, $perl);
125             last if -x $perlpath;
126         }
127     }
128
129     return $perlpath;
130 }
131
132 =item B<perl_lib>
133
134   perl_lib;
135
136 Sets up environment variables so perl can find its libraries.
137
138 =cut
139
140 my $old5lib = $ENV{PERL5LIB};
141 my $had5lib = exists $ENV{PERL5LIB};
142 sub perl_lib {
143                                # perl-src/t/
144     my $lib =  $ENV{PERL_CORE} ? qq{../lib}
145                                # ExtUtils-MakeMaker/t/
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
154 END { 
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
168 MakeMaker doesn't always generate 'Makefile'.  It returns what it
169 should generate.
170
171 =cut
172
173 sub makefile_name {
174     return $Is_VMS ? 'Descrip.MMS' : 'Makefile';
175 }   
176
177 =item B<makefile_backup>
178
179   my $makefile_old = makefile_backup;
180
181 Returns the name MakeMaker will use for a backup of the current
182 Makefile.
183
184 =cut
185
186 sub makefile_backup {
187     my $makefile = makefile_name;
188     return $Is_VMS ? "$makefile".'_old' : "$makefile.old";
189 }
190
191 =item B<make>
192
193   my $make = make;
194
195 Returns a good guess at the make to run.
196
197 =cut
198
199 sub 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
210 Returns the make to run as with make() plus any necessary switches.
211
212 =cut
213
214 sub 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
225 Returns the command necessary to run $make on the given $target using
226 the given %macros.
227
228   my $make_test_verbose = make_macro(make_run(), 'test', 
229                                      TEST_VERBOSE => 1);
230
231 This is important because VMS's make utilities have a completely
232 different 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
238 sub 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
257 =item B<calibrate_mtime>
258
259   my $mtime = calibrate_mtime;
260
261 When building on NFS, file modification times can often lose touch
262 with reality.  This returns the mtime of a file which has just been
263 touched.
264
265 =cut
266
267 sub 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
276 =item B<run>
277
278   my $out = run($command);
279   my @out = run($command);
280
281 Runs the given $command as an external program returning at least STDOUT
282 as $out.  If possible it will return STDOUT and STDERR combined as you
283 would expect to see on a screen.
284
285 =cut
286
287 sub run {
288     my $cmd = shift;
289
290     use ExtUtils::MM;
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     }
302 }
303
304 =item B<setup_mm_test_root>
305
306 Creates a rooted logical to avoid the 8-level limit on older VMS systems.  
307 No action taken on non-VMS systems.
308
309 =cut
310
311 sub 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'
322 COMMAND
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
334 Returns true if there is a compiler available for XS builds.
335
336 =cut
337
338 sub have_compiler {
339     my $have_compiler = 0;
340
341     # ExtUtils::CBuilder prints its compilation lines to the screen.
342     # Shut it up.
343     use TieOut;
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
360 =item slurp
361
362   $contents = slurp($filename);
363
364 Returns the $contents of $filename.
365
366 Will die if $filename cannot be opened.
367
368 =cut
369
370 sub slurp {
371     my $filename = shift;
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
378     return $text;
379 }
380
381 =back
382
383 =head1 AUTHOR
384
385 Michael G Schwern <schwern@pobox.com>
386
387 =cut
388
389 1;