Commit | Line | Data |
f6d6199c |
1 | package MakeMaker::Test::Utils; |
2 | |
3 | use File::Spec; |
4 | use strict; |
5 | use Config; |
6 | |
f6d6199c |
7 | require Exporter; |
a65cb92d |
8 | our @ISA = qw(Exporter); |
f6d6199c |
9 | |
a65cb92d |
10 | our $Is_VMS = $^O eq 'VMS'; |
11 | our $Is_MacOS = $^O eq 'MacOS'; |
f6d6199c |
12 | |
a65cb92d |
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 |
c0956255 |
18 | run_ok |
a65cb92d |
19 | ); |
f6d6199c |
20 | |
21 | |
b5b9b385 |
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 |
c0956255 |
31 | PREFIX |
c0956255 |
32 | MAKEFLAGS |
b5b9b385 |
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 | |
f6d6199c |
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 | |
e0678a30 |
77 | my $mtime = calibrate_mtime; |
78 | |
dedf98bc |
79 | my $out = run($cmd); |
80 | |
7292dc67 |
81 | my $have_compiler = have_compiler(); |
82 | |
bf87a6a1 |
83 | my $text = slurp($filename); |
84 | |
7292dc67 |
85 | |
f6d6199c |
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 | |
e0678a30 |
113 | $perl .= $Config{exe_ext} unless $perl =~ m/$Config{exe_ext}$/i; |
f6d6199c |
114 | |
e0678a30 |
115 | my $perlpath = File::Spec->rel2abs( $perl ); |
d5201bd2 |
116 | unless( $Is_MacOS || -x $perlpath ) { |
f6d6199c |
117 | # $^X was probably 'perl' |
e0678a30 |
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 | |
f6d6199c |
124 | foreach my $path (File::Spec->path) { |
e0678a30 |
125 | $perlpath = File::Spec->catfile($path, $perl); |
126 | last if -x $perlpath; |
f6d6199c |
127 | } |
128 | } |
129 | |
e0678a30 |
130 | return $perlpath; |
f6d6199c |
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 { |
d2c0d57c |
144 | # perl-src/t/ |
145 | my $lib = $ENV{PERL_CORE} ? qq{../lib} |
146 | # ExtUtils-MakeMaker/t/ |
f6d6199c |
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; |
7292dc67 |
189 | return $Is_VMS ? "$makefile".'_old' : "$makefile.old"; |
f6d6199c |
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 | |
e0678a30 |
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 | |
dedf98bc |
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 | |
277189c8 |
291 | use ExtUtils::MM; |
dedf98bc |
292 | |
cb06ebec |
293 | # Unix, modern Windows and OS/2 from 5.005_54 up can handle 2>&1 |
dedf98bc |
294 | # This makes our failure diagnostics nicer to read. |
b6d6132c |
295 | if( MM->os_flavor_is('Unix') or |
296 | (MM->os_flavor_is('Win32') and !MM->os_flavor_is('Win9x')) or |
dedf98bc |
297 | ($] > 5.00554 and MM->os_flavor_is('OS/2')) |
298 | ) { |
299 | return `$cmd 2>&1`; |
300 | } |
301 | else { |
302 | return `$cmd`; |
303 | } |
7292dc67 |
304 | } |
305 | |
c0956255 |
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 | |
7292dc67 |
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. |
277189c8 |
366 | use TieOut; |
7292dc67 |
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 | |
bf87a6a1 |
383 | =item slurp |
384 | |
a65cb92d |
385 | $contents = slurp($filename); |
386 | |
387 | Returns the $contents of $filename. |
bf87a6a1 |
388 | |
a65cb92d |
389 | Will die if $filename cannot be opened. |
bf87a6a1 |
390 | |
391 | =cut |
392 | |
393 | sub slurp { |
394 | my $filename = shift; |
a65cb92d |
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 | |
bf87a6a1 |
401 | return $text; |
402 | } |
dedf98bc |
403 | |
f6d6199c |
404 | =back |
405 | |
406 | =head1 AUTHOR |
407 | |
408 | Michael G Schwern <schwern@pobox.com> |
409 | |
410 | =cut |
411 | |
412 | 1; |