Commit | Line | Data |
f6d6199c |
1 | package MakeMaker::Test::Utils; |
2 | |
3 | use File::Spec; |
4 | use strict; |
5 | use Config; |
6 | |
7 | use vars qw($VERSION @ISA @EXPORT); |
8 | |
9 | require Exporter; |
10 | @ISA = qw(Exporter); |
11 | |
e0678a30 |
12 | $VERSION = 0.02; |
f6d6199c |
13 | |
14 | @EXPORT = qw(which_perl perl_lib makefile_name makefile_backup |
dedf98bc |
15 | make make_run run make_macro calibrate_mtime |
f6d6199c |
16 | ); |
17 | |
d5d4ec93 |
18 | my $Is_VMS = $^O eq 'VMS'; |
d5201bd2 |
19 | my $Is_MacOS = $^O eq 'MacOS'; |
f6d6199c |
20 | |
21 | |
22 | =head1 NAME |
23 | |
24 | MakeMaker::Test::Utils - Utility routines for testing MakeMaker |
25 | |
26 | =head1 SYNOPSIS |
27 | |
28 | use MakeMaker::Test::Utils; |
29 | |
30 | my $perl = which_perl; |
31 | perl_lib; |
32 | |
33 | my $makefile = makefile_name; |
34 | my $makefile_back = makefile_backup; |
35 | |
36 | my $make = make; |
37 | my $make_run = make_run; |
38 | make_macro($make, $targ, %macros); |
39 | |
e0678a30 |
40 | my $mtime = calibrate_mtime; |
41 | |
dedf98bc |
42 | my $out = run($cmd); |
43 | |
f6d6199c |
44 | =head1 DESCRIPTION |
45 | |
46 | A consolidation of little utility functions used through out the |
47 | MakeMaker test suite. |
48 | |
49 | =head2 Functions |
50 | |
51 | The following are exported by default. |
52 | |
53 | =over 4 |
54 | |
55 | =item B<which_perl> |
56 | |
57 | my $perl = which_perl; |
58 | |
59 | Returns a path to perl which is safe to use in a command line, no |
60 | matter where you chdir to. |
61 | |
62 | =cut |
63 | |
64 | sub which_perl { |
65 | my $perl = $^X; |
66 | $perl ||= 'perl'; |
67 | |
68 | # VMS should have 'perl' aliased properly |
69 | return $perl if $Is_VMS; |
70 | |
e0678a30 |
71 | $perl .= $Config{exe_ext} unless $perl =~ m/$Config{exe_ext}$/i; |
f6d6199c |
72 | |
e0678a30 |
73 | my $perlpath = File::Spec->rel2abs( $perl ); |
d5201bd2 |
74 | unless( $Is_MacOS || -x $perlpath ) { |
f6d6199c |
75 | # $^X was probably 'perl' |
e0678a30 |
76 | |
77 | # When building in the core, *don't* go off and find |
78 | # another perl |
79 | die "Can't find a perl to use (\$^X=$^X), (\$perlpath=$perlpath)" |
80 | if $ENV{PERL_CORE}; |
81 | |
f6d6199c |
82 | foreach my $path (File::Spec->path) { |
e0678a30 |
83 | $perlpath = File::Spec->catfile($path, $perl); |
84 | last if -x $perlpath; |
f6d6199c |
85 | } |
86 | } |
87 | |
e0678a30 |
88 | return $perlpath; |
f6d6199c |
89 | } |
90 | |
91 | =item B<perl_lib> |
92 | |
93 | perl_lib; |
94 | |
95 | Sets up environment variables so perl can find its libraries. |
96 | |
97 | =cut |
98 | |
99 | my $old5lib = $ENV{PERL5LIB}; |
100 | my $had5lib = exists $ENV{PERL5LIB}; |
101 | sub perl_lib { |
d2c0d57c |
102 | # perl-src/t/ |
103 | my $lib = $ENV{PERL_CORE} ? qq{../lib} |
104 | # ExtUtils-MakeMaker/t/ |
f6d6199c |
105 | : qq{../blib/lib}; |
106 | $lib = File::Spec->rel2abs($lib); |
107 | my @libs = ($lib); |
108 | push @libs, $ENV{PERL5LIB} if exists $ENV{PERL5LIB}; |
109 | $ENV{PERL5LIB} = join($Config{path_sep}, @libs); |
110 | unshift @INC, $lib; |
111 | } |
112 | |
113 | END { |
114 | if( $had5lib ) { |
115 | $ENV{PERL5LIB} = $old5lib; |
116 | } |
117 | else { |
118 | delete $ENV{PERL5LIB}; |
119 | } |
120 | } |
121 | |
122 | |
123 | =item B<makefile_name> |
124 | |
125 | my $makefile = makefile_name; |
126 | |
127 | MakeMaker doesn't always generate 'Makefile'. It returns what it |
128 | should generate. |
129 | |
130 | =cut |
131 | |
132 | sub makefile_name { |
133 | return $Is_VMS ? 'Descrip.MMS' : 'Makefile'; |
134 | } |
135 | |
136 | =item B<makefile_backup> |
137 | |
138 | my $makefile_old = makefile_backup; |
139 | |
140 | Returns the name MakeMaker will use for a backup of the current |
141 | Makefile. |
142 | |
143 | =cut |
144 | |
145 | sub makefile_backup { |
146 | my $makefile = makefile_name; |
147 | return $Is_VMS ? $makefile : "$makefile.old"; |
148 | } |
149 | |
150 | =item B<make> |
151 | |
152 | my $make = make; |
153 | |
154 | Returns a good guess at the make to run. |
155 | |
156 | =cut |
157 | |
158 | sub make { |
159 | my $make = $Config{make}; |
160 | $make = $ENV{MAKE} if exists $ENV{MAKE}; |
161 | |
162 | return $make; |
163 | } |
164 | |
165 | =item B<make_run> |
166 | |
167 | my $make_run = make_run; |
168 | |
169 | Returns the make to run as with make() plus any necessary switches. |
170 | |
171 | =cut |
172 | |
173 | sub make_run { |
174 | my $make = make; |
175 | $make .= ' -nologo' if $make eq 'nmake'; |
176 | |
177 | return $make; |
178 | } |
179 | |
180 | =item B<make_macro> |
181 | |
182 | my $make_cmd = make_macro($make, $target, %macros); |
183 | |
184 | Returns the command necessary to run $make on the given $target using |
185 | the given %macros. |
186 | |
187 | my $make_test_verbose = make_macro(make_run(), 'test', |
188 | TEST_VERBOSE => 1); |
189 | |
190 | This is important because VMS's make utilities have a completely |
191 | different calling convention than Unix or Windows. |
192 | |
193 | %macros is actually a list of tuples, so the order will be preserved. |
194 | |
195 | =cut |
196 | |
197 | sub make_macro { |
198 | my($make, $target) = (shift, shift); |
199 | |
200 | my $is_mms = $make =~ /^MM(K|S)/i; |
201 | |
202 | my $cmd = $make; |
203 | my $macros = ''; |
204 | while( my($key,$val) = splice(@_, 0, 2) ) { |
205 | if( $is_mms ) { |
206 | $macros .= qq{/macro="$key=$val"}; |
207 | } |
208 | else { |
209 | $macros .= qq{ $key=$val}; |
210 | } |
211 | } |
212 | |
213 | return $is_mms ? "$make$macros $target" : "$make $target $macros"; |
214 | } |
215 | |
e0678a30 |
216 | =item B<calibrate_mtime> |
217 | |
218 | my $mtime = calibrate_mtime; |
219 | |
220 | When building on NFS, file modification times can often lose touch |
221 | with reality. This returns the mtime of a file which has just been |
222 | touched. |
223 | |
224 | =cut |
225 | |
226 | sub calibrate_mtime { |
227 | open(FILE, ">calibrate_mtime.tmp") || die $!; |
228 | print FILE "foo"; |
229 | close FILE; |
230 | my($mtime) = (stat('calibrate_mtime.tmp'))[9]; |
231 | unlink 'calibrate_mtime.tmp'; |
232 | return $mtime; |
233 | } |
234 | |
dedf98bc |
235 | =item B<run> |
236 | |
237 | my $out = run($command); |
238 | my @out = run($command); |
239 | |
240 | Runs the given $command as an external program returning at least STDOUT |
241 | as $out. If possible it will return STDOUT and STDERR combined as you |
242 | would expect to see on a screen. |
243 | |
244 | =cut |
245 | |
246 | sub run { |
247 | my $cmd = shift; |
248 | |
249 | require ExtUtils::MM; |
250 | |
251 | # Unix can handle 2>&1 and OS/2 from 5.005_54 up. |
252 | # This makes our failure diagnostics nicer to read. |
253 | if( MM->os_flavor_is('Unix') or |
254 | ($] > 5.00554 and MM->os_flavor_is('OS/2')) |
255 | ) { |
256 | return `$cmd 2>&1`; |
257 | } |
258 | else { |
259 | return `$cmd`; |
260 | } |
261 | } |
262 | |
f6d6199c |
263 | =back |
264 | |
265 | =head1 AUTHOR |
266 | |
267 | Michael G Schwern <schwern@pobox.com> |
268 | |
269 | =cut |
270 | |
271 | 1; |