Move Data::Dumper from ext/ to dist/
[perl.git] / ext / ExtUtils-Install / 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 $Is_VMS   = $^O eq 'VMS';
11 our $Is_MacOS = $^O eq 'MacOS';
12
13 our @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 }
56 clean_env();
57
58
59 =head1 NAME
60
61 MakeMaker::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
88 A consolidation of little utility functions used through out the
89 MakeMaker test suite.
90
91 =head2 Functions
92
93 The following are exported by default.
94
95 =over 4
96
97 =item B<which_perl>
98
99   my $perl = which_perl;
100
101 Returns a path to perl which is safe to use in a command line, no
102 matter where you chdir to.
103
104 =cut
105
106 sub 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
137 Sets up environment variables so perl can find its libraries.
138
139 =cut
140
141 my $old5lib = $ENV{PERL5LIB};
142 my $had5lib = exists $ENV{PERL5LIB};
143 sub 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
155 END { 
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
169 MakeMaker doesn't always generate 'Makefile'.  It returns what it
170 should generate.
171
172 =cut
173
174 sub makefile_name {
175     return $Is_VMS ? 'Descrip.MMS' : 'Makefile';
176 }   
177
178 =item B<makefile_backup>
179
180   my $makefile_old = makefile_backup;
181
182 Returns the name MakeMaker will use for a backup of the current
183 Makefile.
184
185 =cut
186
187 sub 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
196 Returns a good guess at the make to run.
197
198 =cut
199
200 sub 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
211 Returns the make to run as with make() plus any necessary switches.
212
213 =cut
214
215 sub 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
226 Returns the command necessary to run $make on the given $target using
227 the given %macros.
228
229   my $make_test_verbose = make_macro(make_run(), 'test', 
230                                      TEST_VERBOSE => 1);
231
232 This is important because VMS's make utilities have a completely
233 different 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
239 sub 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
262 When building on NFS, file modification times can often lose touch
263 with reality.  This returns the mtime of a file which has just been
264 touched.
265
266 =cut
267
268 sub 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
282 Runs the given $command as an external program returning at least STDOUT
283 as $out.  If possible it will return STDOUT and STDERR combined as you
284 would expect to see on a screen.
285
286 =cut
287
288 sub 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
311 Like run() but it tests that the result exited normally.
312
313 The output from run() will be used as a diagnostic if it fails.
314
315 =cut
316
317 sub 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
329 Creates a rooted logical to avoid the 8-level limit on older VMS systems.  
330 No action taken on non-VMS systems.
331
332 =cut
333
334 sub 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'
345 COMMAND
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
357 Returns true if there is a compiler available for XS builds.
358
359 =cut
360
361 sub 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
387 Returns the $contents of $filename.
388
389 Will die if $filename cannot be opened.
390
391 =cut
392
393 sub 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
408 Michael G Schwern <schwern@pobox.com>
409
410 =cut
411
412 1;