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