1package MakeMaker::Test::Utils;
2
3use File::Spec;
4use strict;
5use Config;
6use Cwd qw(getcwd);
7use Carp qw(croak);
8use File::Path;
9use File::Basename;
10
11require Exporter;
12our @ISA = qw(Exporter);
13
14our $Is_VMS     = $^O eq 'VMS';
15our $Is_MacOS   = $^O eq 'MacOS';
16our $Is_FreeBSD = $^O eq 'freebsd';
17
18our @EXPORT = qw(which_perl perl_lib makefile_name makefile_backup
19                 make make_run run make_macro calibrate_mtime
20                 have_compiler slurp
21                 $Is_VMS $Is_MacOS
22                 run_ok
23                 hash2files
24                 in_dir
25                );
26
27
28# Setup the code to clean out %ENV
29{
30    # Environment variables which might effect our testing
31    my @delete_env_keys = qw(
32        PERL_MM_OPT
33        PERL_MM_USE_DEFAULT
34        HARNESS_TIMER
35        HARNESS_OPTIONS
36        HARNESS_VERBOSE
37        PREFIX
38        MAKEFLAGS
39        PERL_INSTALL_QUIET
40    );
41
42    my %default_env_keys;
43
44    # Inform the BSDPAN hacks not to register modules installed for testing.
45    $default_env_keys{PORTOBJFORMAT} = 1 if $Is_FreeBSD;
46
47    # https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker/issues/65
48    $default_env_keys{ACTIVEPERL_CONFIG_SILENT} = 1;
49
50    # Remember the ENV values because on VMS %ENV is global
51    # to the user, not the process.
52    my %restore_env_keys;
53
54    sub clean_env {
55        for my $key (keys %default_env_keys) {
56            $ENV{$key} = $default_env_keys{$key} unless $ENV{$key};
57        }
58
59        for my $key (@delete_env_keys) {
60            if( exists $ENV{$key} ) {
61                $restore_env_keys{$key} = delete $ENV{$key};
62            }
63            else {
64                delete $ENV{$key};
65            }
66        }
67    }
68
69    END {
70        while( my($key, $val) = each %restore_env_keys ) {
71            $ENV{$key} = $val;
72        }
73    }
74}
75clean_env();
76
77
78=head1 NAME
79
80MakeMaker::Test::Utils - Utility routines for testing MakeMaker
81
82=head1 SYNOPSIS
83
84  use MakeMaker::Test::Utils;
85
86  my $perl     = which_perl;
87  perl_lib;
88
89  my $makefile      = makefile_name;
90  my $makefile_back = makefile_backup;
91
92  my $make          = make;
93  my $make_run      = make_run;
94  make_macro($make, $targ, %macros);
95
96  my $mtime         = calibrate_mtime;
97
98  my $out           = run($cmd);
99
100  my $have_compiler = have_compiler();
101
102  my $text          = slurp($filename);
103
104
105=head1 DESCRIPTION
106
107A consolidation of little utility functions used throughout the
108MakeMaker test suite.
109
110=head2 Functions
111
112The following are exported by default.
113
114=over 4
115
116=item B<which_perl>
117
118  my $perl = which_perl;
119
120Returns a path to perl which is safe to use in a command line, no
121matter where you chdir to.
122
123=cut
124
125sub which_perl {
126    my $perl = $^X;
127    $perl ||= 'perl';
128
129    # VMS should have 'perl' aliased properly
130    return $perl if $Is_VMS;
131
132    $perl .= $Config{exe_ext} unless $perl =~ m/$Config{exe_ext}$/i;
133
134    my $perlpath = File::Spec->rel2abs( $perl );
135    unless( $Is_MacOS || -x $perlpath ) {
136        # $^X was probably 'perl'
137
138        # When building in the core, *don't* go off and find
139        # another perl
140        die "Can't find a perl to use (\$^X=$^X), (\$perlpath=$perlpath)"
141          if $ENV{PERL_CORE};
142
143        foreach my $path (File::Spec->path) {
144            $perlpath = File::Spec->catfile($path, $perl);
145            last if -x $perlpath;
146        }
147    }
148    $perlpath = qq{"$perlpath"}; # "safe... in a command line" even with spaces
149
150    return $perlpath;
151}
152
153=item B<perl_lib>
154
155  perl_lib;
156
157Sets up environment variables so perl can find its libraries.
158
159=cut
160
161my $old5lib = $ENV{PERL5LIB};
162my $had5lib = exists $ENV{PERL5LIB};
163sub perl_lib {
164    my $basecwd = (File::Spec->splitdir(getcwd))[-1];
165    croak "Basename of cwd needs to be 't' but is '$basecwd'\n"
166        unless $basecwd eq 't';
167                               # perl-src/t/
168    my $lib =  $ENV{PERL_CORE} ? qq{../lib}
169                               # ExtUtils-MakeMaker/t/
170                               : qq{../blib/lib};
171    $lib = File::Spec->rel2abs($lib);
172    my @libs = ($lib);
173    push @libs, $ENV{PERL5LIB} if exists $ENV{PERL5LIB};
174    $ENV{PERL5LIB} = join($Config{path_sep}, @libs);
175    unshift @INC, $lib;
176}
177
178END {
179    if( $had5lib ) {
180        $ENV{PERL5LIB} = $old5lib;
181    }
182    else {
183        delete $ENV{PERL5LIB};
184    }
185}
186
187
188=item B<makefile_name>
189
190  my $makefile = makefile_name;
191
192MakeMaker doesn't always generate 'Makefile'.  It returns what it
193should generate.
194
195=cut
196
197sub makefile_name {
198    return $Is_VMS ? 'Descrip.MMS' : 'Makefile';
199}
200
201=item B<makefile_backup>
202
203  my $makefile_old = makefile_backup;
204
205Returns the name MakeMaker will use for a backup of the current
206Makefile.
207
208=cut
209
210sub makefile_backup {
211    my $makefile = makefile_name;
212    return $Is_VMS ? "$makefile".'_old' : "$makefile.old";
213}
214
215=item B<make>
216
217  my $make = make;
218
219Returns a good guess at the make to run.
220
221=cut
222
223sub make {
224    my $make = $Config{make};
225    $make = $ENV{MAKE} if exists $ENV{MAKE};
226
227    return $Is_VMS ? $make : qq{"$make"};
228}
229
230=item B<make_run>
231
232  my $make_run = make_run;
233
234Returns the make to run as with make() plus any necessary switches.
235
236=cut
237
238sub make_run {
239    my $make = make;
240    $make .= ' -nologo' if $make eq 'nmake';
241
242    return $make;
243}
244
245=item B<make_macro>
246
247    my $make_cmd = make_macro($make, $target, %macros);
248
249Returns the command necessary to run $make on the given $target using
250the given %macros.
251
252  my $make_test_verbose = make_macro(make_run(), 'test',
253                                     TEST_VERBOSE => 1);
254
255This is important because VMS's make utilities have a completely
256different calling convention than Unix or Windows.
257
258%macros is actually a list of tuples, so the order will be preserved.
259
260=cut
261
262sub make_macro {
263    my($make, $target) = (shift, shift);
264
265    my $is_mms = $make =~ /^MM(K|S)/i;
266
267    my @macros;
268    while( my($key,$val) = splice(@_, 0, 2) ) {
269        push @macros, qq{$key=$val};
270    }
271    my $macros = '';
272    if (scalar(@macros)) {
273        if ($is_mms) {
274            map { $_ = qq{"$_"} } @macros;
275            $macros = '/MACRO=(' . join(',', @macros) . ')';
276        }
277        else {
278            $macros = join(' ', @macros);
279        }
280    }
281
282    return $is_mms ? "$make$macros $target" : "$make $target $macros";
283}
284
285=item B<calibrate_mtime>
286
287  my $mtime = calibrate_mtime;
288
289When building on NFS, file modification times can often lose touch
290with reality.  This returns the mtime of a file which has just been
291touched.
292
293=cut
294
295sub calibrate_mtime {
296    my $file = "calibrate_mtime-$$.tmp";
297    open(FILE, ">$file") || die $!;
298    print FILE "foo";
299    close FILE;
300    my($mtime) = (stat($file))[9];
301    unlink $file;
302    return $mtime;
303}
304
305=item B<run>
306
307  my $out = run($command);
308  my @out = run($command);
309
310Runs the given $command as an external program returning at least STDOUT
311as $out.  If possible it will return STDOUT and STDERR combined as you
312would expect to see on a screen.
313
314=cut
315
316sub run {
317    my $cmd = shift;
318
319    use ExtUtils::MM;
320
321    # Unix, modern Windows and OS/2 from 5.005_54 up can handle 2>&1
322    # This makes our failure diagnostics nicer to read.
323    if (MM->can_redirect_error) {
324        return `$cmd 2>&1`;
325    }
326    else {
327        return `$cmd`;
328    }
329}
330
331
332=item B<run_ok>
333
334  my @out = run_ok($cmd);
335
336Like run() but it tests that the result exited normally.
337
338The output from run() will be used as a diagnostic if it fails.
339
340=cut
341
342sub run_ok {
343    my $tb = Test::Builder->new;
344
345    my @out = run(@_);
346
347    $tb->cmp_ok( $?, '==', 0, "run(@_)" ) || $tb->diag(@out);
348
349    return wantarray ? @out : join "", @out;
350}
351
352=item have_compiler
353
354  $have_compiler = have_compiler;
355
356Returns true if there is a compiler available for XS builds.
357
358=cut
359
360sub have_compiler {
361    my $have_compiler = 0;
362    eval {
363        require ExtUtils::CBuilder;
364        my $cb = ExtUtils::CBuilder->new(quiet=>1);
365        $have_compiler = $cb->have_compiler;
366    };
367    return $have_compiler;
368}
369
370=item slurp
371
372  $contents = slurp($filename);
373
374Returns the $contents of $filename.
375
376Will die if $filename cannot be opened.
377
378=cut
379
380sub slurp {
381    my $filename = shift;
382
383    local $/ = undef;
384    open my $fh, $filename or die "Can't open $filename for reading: $!";
385    my $text = <$fh>;
386    close $fh;
387
388    return $text;
389}
390
391=item hash2files
392
393  hash2files('dirname', { 'filename' => 'some content' });
394
395Goes through given hash-ref, treating each key as a /-separated filename
396under the specified directory, and writing the value into it. Will create
397any necessary directories.
398
399Will die if errors occur.
400
401=cut
402
403sub hash2files {
404    my ($prefix, $hashref) = @_;
405    while(my ($file, $text) = each %$hashref) {
406        # Convert to a relative, native file path.
407        $file = File::Spec->catfile(File::Spec->curdir, $prefix, split m{\/}, $file);
408        my $dir = dirname($file);
409        mkpath $dir;
410        my $utf8 = ($] < 5.008 or !$Config{useperlio}) ? "" : ":utf8";
411        open(FILE, ">$utf8", $file) || die "Can't create $file: $!";
412        print FILE $text;
413        close FILE;
414        # ensure file at least 1 second old for makes that assume
415        # files with the same time are out of date.
416        my $time = calibrate_mtime();
417        utime $time, $time - 1, $file;
418    }
419}
420
421=item in_dir
422
423  $retval = in_dir(\&coderef);
424  $retval = in_dir(\&coderef, $specified_dir);
425  $retval = in_dir { somecode(); };
426  $retval = in_dir { somecode(); } $specified_dir;
427
428Does a C<chdir> to either a directory. If none is specified, one is
429created with L<File::Temp> and then automatically deleted after. It ends
430by C<chdir>ing back to where it started.
431
432If the given code throws an exception, it will be re-thrown after the
433re-C<chdir>.
434
435Returns the return value of the given code.
436
437=cut
438
439sub in_dir(&;$) {
440    my $code = shift;
441    require File::Temp;
442    my $dir = shift || File::Temp::tempdir(TMPDIR => 1, CLEANUP => 1);
443    # chdir to the new directory
444    my $orig_dir = getcwd();
445    chdir $dir or die "Can't chdir to $dir: $!";
446    # Run the code, but trap the error so we can chdir back
447    my $return;
448    my $ok = eval { $return = $code->(); 1; };
449    my $err = $@;
450    # chdir back
451    chdir $orig_dir or die "Can't chdir to $orig_dir: $!";
452    # rethrow if necessary
453    die $err unless $ok;
454    return $return;
455}
456
457=back
458
459=head1 AUTHOR
460
461Michael G Schwern <schwern@pobox.com>
462
463=cut
464
4651;
466