Commit | Line | Data |
bb4e9162 |
1 | package MBTest; |
2 | |
3 | use strict; |
4 | |
53fc1c7e |
5 | use IO::File (); |
bb4e9162 |
6 | use File::Spec; |
66e531b6 |
7 | use File::Temp (); |
7a827510 |
8 | use File::Path (); |
bb4e9162 |
9 | |
15cb7b9d |
10 | |
11 | # Setup the code to clean out %ENV |
12 | BEGIN { |
13 | # Environment variables which might effect our testing |
14 | my @delete_env_keys = qw( |
15 | DEVEL_COVER_OPTIONS |
16 | MODULEBUILDRC |
613f422f |
17 | PERL_MB_OPT |
15cb7b9d |
18 | HARNESS_TIMER |
19 | HARNESS_OPTIONS |
20 | HARNESS_VERBOSE |
21 | PREFIX |
22 | INSTALL_BASE |
23 | INSTALLDIRS |
24 | ); |
25 | |
26 | # Remember the ENV values because on VMS %ENV is global |
27 | # to the user, not the process. |
28 | my %restore_env_keys; |
29 | |
30 | sub clean_env { |
31 | for my $key (@delete_env_keys) { |
32 | if( exists $ENV{$key} ) { |
33 | $restore_env_keys{$key} = delete $ENV{$key}; |
34 | } |
35 | else { |
36 | delete $ENV{$key}; |
37 | } |
38 | } |
39 | } |
40 | |
41 | END { |
42 | while( my($key, $val) = each %restore_env_keys ) { |
43 | $ENV{$key} = $val; |
44 | } |
45 | } |
46 | } |
47 | |
48 | |
bb4e9162 |
49 | BEGIN { |
15cb7b9d |
50 | clean_env(); |
bb4e9162 |
51 | |
738349a8 |
52 | # In case the test wants to use our other bundled |
53 | # modules, make sure they can be loaded. |
613f422f |
54 | my $t_lib = File::Spec->catdir('t', 'bundled'); |
55 | push @INC, $t_lib; # Let user's installed version override |
56 | |
57 | if ($ENV{PERL_CORE}) { |
58 | # We change directories, so expand @INC and $^X to absolute paths |
59 | # Also add . |
60 | @INC = (map(File::Spec->rel2abs($_), @INC), "."); |
61 | $^X = File::Spec->rel2abs($^X); |
62 | } |
bb4e9162 |
63 | } |
64 | |
65 | use Exporter; |
66 | use Test::More; |
67 | use Config; |
7a827510 |
68 | use Cwd (); |
bb4e9162 |
69 | |
70 | # We pass everything through to Test::More |
71 | use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); |
66e531b6 |
72 | $VERSION = 0.01_01; |
bb4e9162 |
73 | @ISA = qw(Test::More); # Test::More isa Exporter |
74 | @EXPORT = @Test::More::EXPORT; |
75 | %EXPORT_TAGS = %Test::More::EXPORT_TAGS; |
76 | |
77 | # We have a few extra exports, but Test::More has a special import() |
78 | # that won't take extra additions. |
7a827510 |
79 | my @extra_exports = qw( |
80 | stdout_of |
81 | stderr_of |
82 | stdout_stderr_of |
83 | slurp |
84 | find_in_path |
85 | check_compiler |
86 | have_module |
613f422f |
87 | blib_load |
53fc1c7e |
88 | timed_out |
7a827510 |
89 | ); |
bb4e9162 |
90 | push @EXPORT, @extra_exports; |
91 | __PACKAGE__->export(scalar caller, @extra_exports); |
7a827510 |
92 | # XXX ^-- that should really happen in import() |
15cb7b9d |
93 | |
94 | |
7a827510 |
95 | ######################################################################## |
96 | |
66e531b6 |
97 | # always return to the current directory |
08fc25ad |
98 | { |
613f422f |
99 | my $cwd = File::Spec->rel2abs(Cwd::cwd); |
100 | |
101 | sub original_cwd { return $cwd } |
7a827510 |
102 | |
7a827510 |
103 | END { |
66e531b6 |
104 | # Go back to where you came from! |
105 | chdir $cwd or die "Couldn't chdir to $cwd"; |
7a827510 |
106 | } |
107 | } |
108 | ######################################################################## |
bb4e9162 |
109 | |
7a827510 |
110 | { # backwards compatible temp filename recipe adapted from perlfaq |
111 | my $tmp_count = 0; |
53fc1c7e |
112 | my $tmp_base_name = sprintf("MB-%d-%d", $$, time()); |
7a827510 |
113 | sub temp_file_name { |
114 | sprintf("%s-%04d", $tmp_base_name, ++$tmp_count) |
115 | } |
116 | } |
117 | ######################################################################## |
bb4e9162 |
118 | |
613f422f |
119 | # Setup a temp directory |
120 | sub tmpdir { |
121 | my ($self, @args) = @_; |
122 | my $dir = $ENV{PERL_CORE} ? MBTest->original_cwd : File::Spec->tmpdir; |
123 | return File::Temp::tempdir('MB-XXXXXXXX', CLEANUP => 1, DIR => $dir, @args); |
66e531b6 |
124 | } |
125 | |
bb4e9162 |
126 | sub save_handle { |
127 | my ($handle, $subr) = @_; |
53fc1c7e |
128 | my $outfile = File::Spec->catfile(File::Spec->tmpdir, temp_file_name()); |
bb4e9162 |
129 | |
130 | local *SAVEOUT; |
7a827510 |
131 | open SAVEOUT, ">&" . fileno($handle) |
132 | or die "Can't save output handle: $!"; |
bb4e9162 |
133 | open $handle, "> $outfile" or die "Can't create $outfile: $!"; |
134 | |
135 | eval {$subr->()}; |
136 | open $handle, ">&SAVEOUT" or die "Can't restore output: $!"; |
137 | |
138 | my $ret = slurp($outfile); |
139 | 1 while unlink $outfile; |
140 | return $ret; |
141 | } |
142 | |
143 | sub stdout_of { save_handle(\*STDOUT, @_) } |
144 | sub stderr_of { save_handle(\*STDERR, @_) } |
7a827510 |
145 | sub stdout_stderr_of { |
146 | my $subr = shift; |
147 | my ($stdout, $stderr); |
148 | $stdout = stdout_of ( sub { |
149 | $stderr = stderr_of( $subr ) |
150 | }); |
613f422f |
151 | return wantarray ? ($stdout, $stderr) : $stdout . $stderr; |
7a827510 |
152 | } |
bb4e9162 |
153 | |
154 | sub slurp { |
155 | my $fh = IO::File->new($_[0]) or die "Can't open $_[0]: $!"; |
156 | local $/; |
157 | return scalar <$fh>; |
158 | } |
159 | |
7a827510 |
160 | # Some extensions we should know about if we're looking for executables |
7253302f |
161 | sub exe_exts { |
7253302f |
162 | |
163 | if ($^O eq 'MSWin32') { |
164 | return split($Config{path_sep}, $ENV{PATHEXT} || '.com;.exe;.bat'); |
165 | } |
166 | if ($^O eq 'os2') { |
167 | return qw(.exe .com .pl .cmd .bat .sh .ksh); |
168 | } |
169 | return; |
170 | } |
171 | |
bb4e9162 |
172 | sub find_in_path { |
173 | my $thing = shift; |
613f422f |
174 | |
7253302f |
175 | my @exe_ext = exe_exts(); |
613f422f |
176 | if ( File::Spec->file_name_is_absolute( $thing ) ) { |
7253302f |
177 | foreach my $ext ( '', @exe_ext ) { |
613f422f |
178 | return "$thing$ext" if -e "$thing$ext"; |
179 | } |
180 | } |
181 | else { |
182 | my @path = split $Config{path_sep}, $ENV{PATH}; |
183 | foreach (@path) { |
184 | my $fullpath = File::Spec->catfile($_, $thing); |
185 | foreach my $ext ( '', @exe_ext ) { |
186 | return "$fullpath$ext" if -e "$fullpath$ext"; |
187 | } |
bb4e9162 |
188 | } |
189 | } |
190 | return; |
191 | } |
192 | |
bb4e9162 |
193 | sub check_compiler { |
194 | return (1,1) if $ENV{PERL_CORE}; |
195 | |
196 | local $SIG{__WARN__} = sub {}; |
197 | |
613f422f |
198 | blib_load('Module::Build'); |
bb4e9162 |
199 | my $mb = Module::Build->current; |
200 | $mb->verbose( 0 ); |
201 | |
202 | my $have_c_compiler; |
203 | stderr_of( sub {$have_c_compiler = $mb->have_c_compiler} ); |
204 | |
cdbde1c3 |
205 | # check noexec tmpdir |
206 | my $tmp_exec; |
207 | if ( $have_c_compiler ) { |
208 | my $dir = MBTest->tmpdir; |
209 | my $c_file = File::Spec->catfile($dir,'test.c'); |
210 | open my $fh, ">", $c_file; |
211 | print {$fh} "int main() { return 0; }\n"; |
212 | close $fh; |
213 | my $exe = $mb->cbuilder->link_executable( |
214 | objects => $mb->cbuilder->compile( source => $c_file ) |
215 | ); |
216 | $tmp_exec = 0 == system( $exe ); |
217 | } |
08fc25ad |
218 | return ($have_c_compiler, $tmp_exec); |
bb4e9162 |
219 | } |
220 | |
f943a5bf |
221 | sub have_module { |
222 | my $module = shift; |
613f422f |
223 | return eval "require $module; 1"; |
f943a5bf |
224 | } |
225 | |
613f422f |
226 | sub blib_load { |
227 | # Load the given module and ensure it came from blib/, not the larger system |
738349a8 |
228 | my $mod = shift; |
613f422f |
229 | have_module($mod) or die "Error loading $mod\: $@\n"; |
230 | |
738349a8 |
231 | (my $path = $mod) =~ s{::}{/}g; |
613f422f |
232 | $path .= ".pm"; |
233 | my ($pkg, $file, $line) = caller; |
234 | unless($ENV{PERL_CORE}) { |
235 | unless($INC{$path} =~ m/\bblib\b/) { |
236 | (my $load_from = $INC{$path}) =~ s{$path$}{}; |
237 | die "$mod loaded from '$load_from'\nIt should have been loaded from blib. \@INC contains:\n ", |
238 | join("\n ", @INC) . "\nFatal error occured in blib_load() at $file, line $line.\n"; |
239 | } |
738349a8 |
240 | } |
241 | } |
242 | |
53fc1c7e |
243 | sub timed_out { |
244 | my ($sub, $timeout) = @_; |
245 | return unless $sub; |
246 | $timeout ||= 60; |
247 | |
248 | my $saw_alarm = 0; |
249 | eval { |
250 | local $SIG{ALRM} = sub { $saw_alarm++; die "alarm\n"; }; # NB: \n required |
251 | alarm $timeout; |
252 | $sub->(); |
253 | alarm 0; |
254 | }; |
255 | if ($@) { |
256 | die unless $@ eq "alarm\n"; # propagate unexpected errors |
257 | } |
258 | return $saw_alarm; |
259 | } |
260 | |
261 | sub check_EUI { |
262 | my $timed_out; |
263 | stdout_stderr_of( sub { |
264 | $timed_out = timed_out( sub { |
265 | ExtUtils::Installed->new(extra_libs => [@INC]) |
266 | } |
267 | ); |
268 | } |
269 | ); |
270 | return ! $timed_out; |
271 | } |
272 | |
bb4e9162 |
273 | 1; |
7a827510 |
274 | # vim:ts=2:sw=2:et:sta |