1package MakeMaker::Test::Utils;
2use strict;
3
4use File::Spec;
5use Config;
6
7require Exporter;
8our @ISA = qw(Exporter);
9
10our $Is_VMS   = $^O eq 'VMS';
11our $Is_MacOS = $^O eq 'MacOS';
12
13our @EXPORT = qw(which_perl perl_lib makefile_name makefile_backup
14                 make make_run run make_macro calibrate_mtime
15                 have_compiler slurp
16                 $Is_VMS $Is_MacOS
17                 run_ok
18                );
19
20
21# Setup the code to clean out %ENV
22{
23    # Environment variables which might effect our testing
24    my @delete_env_keys = qw(
25        PERL_MM_OPT
26        PERL_MM_USE_DEFAULT
27        HARNESS_TIMER
28        HARNESS_OPTIONS
29        HARNESS_VERBOSE
30        PREFIX
31        MAKEFLAGS
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
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
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
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
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
136Sets up environment variables so perl can find its libraries.
137Run this before changing directories.
138
139=cut
140
141my $old5lib = $ENV{PERL5LIB};
142my $had5lib = exists $ENV{PERL5LIB};
143sub perl_lib {
144    if ($ENV{PERL_CORE}) {
145	# Whilst we'll be running in perl-src/cpan/$distname/t/
146	# instead of blib, our code will be copied with all the other code to
147	# the top-level library.
148	# $ENV{PERL5LIB} will be set with this, but (by default) it's a relative
149	# path.
150	$ENV{PERL5LIB} = join $Config{path_sep}, map {
151	    File::Spec->rel2abs($_) } split quotemeta($Config{path_sep}), $ENV{PERL5LIB};
152	@INC = map { File::Spec->rel2abs($_) } @INC;
153    } else {
154	my $lib = 'blib/lib';
155	$lib = File::Spec->rel2abs($lib);
156	my @libs = ($lib);
157	push @libs, $ENV{PERL5LIB} if exists $ENV{PERL5LIB};
158	$ENV{PERL5LIB} = join($Config{path_sep}, @libs);
159	unshift @INC, $lib;
160    }
161}
162
163END {
164    if( $had5lib ) {
165        $ENV{PERL5LIB} = $old5lib;
166    }
167    else {
168        delete $ENV{PERL5LIB};
169    }
170}
171
172
173=item B<makefile_name>
174
175  my $makefile = makefile_name;
176
177MakeMaker doesn't always generate 'Makefile'.  It returns what it
178should generate.
179
180=cut
181
182sub makefile_name {
183    return $Is_VMS ? 'Descrip.MMS' : 'Makefile';
184}
185
186=item B<makefile_backup>
187
188  my $makefile_old = makefile_backup;
189
190Returns the name MakeMaker will use for a backup of the current
191Makefile.
192
193=cut
194
195sub makefile_backup {
196    my $makefile = makefile_name;
197    return $Is_VMS ? "$makefile".'_old' : "$makefile.old";
198}
199
200=item B<make>
201
202  my $make = make;
203
204Returns a good guess at the make to run.
205
206=cut
207
208sub make {
209    my $make = $Config{make};
210    $make = $ENV{MAKE} if exists $ENV{MAKE};
211
212    return if !can_run($make);
213    return $make;
214}
215
216=item B<make_run>
217
218  my $make_run = make_run;
219
220Returns the make to run as with make() plus any necessary switches.
221
222=cut
223
224sub make_run {
225    my $make = make;
226    return if !$make;
227    $make .= ' -nologo' if $make eq 'nmake';
228
229    return $make;
230}
231
232=item B<make_macro>
233
234    my $make_cmd = make_macro($make, $target, %macros);
235
236Returns the command necessary to run $make on the given $target using
237the given %macros.
238
239  my $make_test_verbose = make_macro(make_run(), 'test',
240                                     TEST_VERBOSE => 1);
241
242This is important because VMS's make utilities have a completely
243different calling convention than Unix or Windows.
244
245%macros is actually a list of tuples, so the order will be preserved.
246
247=cut
248
249sub make_macro {
250    my($make, $target) = (shift, shift);
251
252    my $is_mms = $make =~ /^MM(K|S)/i;
253
254    my $cmd = $make;
255    my $macros = '';
256    while( my($key,$val) = splice(@_, 0, 2) ) {
257        if( $is_mms ) {
258            $macros .= qq{/macro="$key=$val"};
259        }
260        else {
261            $macros .= qq{ $key=$val};
262        }
263    }
264
265    return $is_mms ? "$make$macros $target" : "$make $target $macros";
266}
267
268=item B<calibrate_mtime>
269
270  my $mtime = calibrate_mtime;
271
272When building on NFS, file modification times can often lose touch
273with reality.  This returns the mtime of a file which has just been
274touched.
275
276=cut
277
278sub calibrate_mtime {
279    open(FILE, ">calibrate_mtime.tmp") || die $!;
280    print FILE "foo";
281    close FILE;
282    my($mtime) = (stat('calibrate_mtime.tmp'))[9];
283    unlink 'calibrate_mtime.tmp';
284    return $mtime;
285}
286
287=item B<run>
288
289  my $out = run($command);
290  my @out = run($command);
291
292Runs the given $command as an external program returning at least STDOUT
293as $out.  If possible it will return STDOUT and STDERR combined as you
294would expect to see on a screen.
295
296=cut
297
298sub run {
299    my $cmd = shift;
300
301    use ExtUtils::MM;
302
303    # Unix, modern Windows and OS/2 from 5.005_54 up can handle can handle 2>&1
304    # This makes our failure diagnostics nicer to read.
305    if( MM->os_flavor_is('Unix')                                   or
306        (MM->os_flavor_is('Win32') and !MM->os_flavor_is('Win9x')) or
307        ($] > 5.00554 and MM->os_flavor_is('OS/2'))
308      ) {
309        return `$cmd 2>&1`;
310    }
311    else {
312        return `$cmd`;
313    }
314}
315
316
317=item B<run_ok>
318
319  my @out = run_ok($cmd);
320
321Like run() but it tests that the result exited normally.
322
323The output from run() will be used as a diagnostic if it fails.
324
325=cut
326
327sub run_ok {
328    my $tb = Test::Builder->new;
329
330    my @out = run(@_);
331
332    $tb->cmp_ok( $?, '==', 0, "run(@_)" ) || $tb->diag(@out);
333
334    return wantarray ? @out : join "", @out;
335}
336
337=item have_compiler
338
339  $have_compiler = have_compiler;
340
341Returns true if there is a compiler available for XS builds.
342
343=cut
344
345sub have_compiler {
346    my $have_compiler = 0;
347
348    # ExtUtils::CBuilder prints its compilation lines to the screen.
349    # Shut it up.
350    use TieOut;
351    local *STDOUT = *STDOUT;
352    local *STDERR = *STDERR;
353
354    tie *STDOUT, 'TieOut';
355    tie *STDERR, 'TieOut';
356
357    eval {
358	require ExtUtils::CBuilder;
359	my $cb = ExtUtils::CBuilder->new;
360
361	$have_compiler = $cb->have_compiler;
362    };
363
364    return $have_compiler;
365}
366
367=item slurp
368
369  $contents = slurp($filename);
370
371Returns the $contents of $filename.
372
373Will die if $filename cannot be opened.
374
375=cut
376
377sub slurp {
378    my $filename = shift;
379
380    local $/ = undef;
381    open my $fh, $filename or die "Can't open $filename for reading: $!";
382    my $text = <$fh>;
383    close $fh;
384
385    return $text;
386}
387
388=item can_run
389
390C<can_run> takes only one argument: the name of a binary you wish
391to locate. C<can_run> works much like the unix binary C<which> or the bash
392command C<type>, which scans through your path, looking for the requested
393binary.
394
395Unlike C<which> and C<type>, this function is platform independent and
396will also work on, for example, Win32.
397
398If called in a scalar context it will return the full path to the binary
399you asked for if it was found, or C<undef> if it was not.
400
401If called in a list context and the global variable C<$INSTANCES> is a true
402value, it will return a list of the full paths to instances
403of the binary where found in C<PATH>, or an empty list if it was not found.
404
405=cut
406
407sub can_run {
408    my $command = shift;
409
410    # a lot of VMS executables have a symbol defined
411    # check those first
412    if ( $^O eq 'VMS' ) {
413        require VMS::DCLsym;
414        my $syms = VMS::DCLsym->new;
415        return $command if scalar $syms->getsym( uc $command );
416    }
417
418    require File::Spec;
419    require ExtUtils::MakeMaker;
420
421    my @possibles;
422
423    if( File::Spec->file_name_is_absolute($command) ) {
424        return MM->maybe_command($command);
425
426    } else {
427        for my $dir (
428            File::Spec->path,
429            File::Spec->curdir
430        ) {
431            next if ! $dir || ! -d $dir;
432            my $abs = File::Spec->catfile( $^O eq 'MSWin32' ? Win32::GetShortPathName( $dir ) : $dir, $command);
433            push @possibles, $abs if $abs = MM->maybe_command($abs);
434        }
435    }
436    return @possibles if wantarray;
437    return shift @possibles;
438}
439
440=back
441
442=head1 AUTHOR
443
444Michael G Schwern <schwern@pobox.com>
445
446=cut
447
4481;
449