1package MBTest;
2
3use strict;
4
5use File::Spec;
6use File::Temp ();
7use File::Path ();
8
9
10# Setup the code to clean out %ENV
11BEGIN {
12    # Environment variables which might effect our testing
13    my @delete_env_keys = qw(
14        HOME
15        DEVEL_COVER_OPTIONS
16        MODULEBUILDRC
17        PERL_MB_OPT
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
49BEGIN {
50  clean_env();
51
52  # In case the test wants to use our other bundled
53  # modules, make sure they can be loaded.
54  my $t_lib = File::Spec->catdir('t', 'bundled');
55  push @INC, $t_lib; # Let user's installed version override
56
57  # We change directories, so expand @INC and $^X to absolute paths
58  # Also add .
59  @INC = (map(File::Spec->rel2abs($_), @INC), ".");
60  $^X = File::Spec->rel2abs($^X);
61}
62
63use Exporter;
64use Test::More;
65use Config;
66use Cwd ();
67
68# We pass everything through to Test::More
69use vars qw($VERSION @ISA @EXPORT $TODO);
70@ISA = ('Exporter');
71$VERSION = 0.01_01;
72
73# We have a few extra exports, but Test::More has a special import()
74# that won't take extra additions.
75@EXPORT = (
76    qw(
77      stdout_of
78      stderr_of
79      stdout_stderr_of
80      slurp
81      find_in_path
82      check_compiler
83      have_module
84      blib_load
85      timed_out
86      $TODO
87    ),
88    @Test::More::EXPORT,
89);
90
91sub import {
92    my $class = shift;
93    my $caller = caller;
94
95    my @imports;
96
97    while (my $item = shift @_) {
98        if ($item eq 'tests' || $item eq 'skip_all') {
99            my $arg = shift @_;
100            plan($item => $arg);
101        }
102        elsif($item eq 'no_plan') {
103            plan($item);
104        }
105        else {
106            push @imports => $item;
107        }
108    }
109
110    @imports = @EXPORT unless @imports;
111
112    $class->export($caller, @imports);
113}
114
115
116########################################################################
117
118# always return to the current directory
119{
120  my $cwd;
121  # must be done in BEGIN because tmpdir uses it in BEGIN for $ENV{HOME}
122  BEGIN {
123    $cwd = File::Spec->rel2abs(Cwd::cwd);
124  }
125
126  sub original_cwd { return $cwd }
127
128  END {
129    # Go back to where you came from!
130    chdir $cwd or die "Couldn't chdir to $cwd";
131  }
132}
133########################################################################
134
135{ # backwards compatible temp filename recipe adapted from perlfaq
136  my $tmp_count = 0;
137  my $tmp_base_name = sprintf("MB-%d-%d", $$, time());
138  sub temp_file_name {
139    sprintf("%s-%04d", $tmp_base_name, ++$tmp_count)
140  }
141}
142########################################################################
143
144# Setup a temp directory
145sub tmpdir {
146  my ($self, @args) = @_;
147  local $ENV{TMPDIR} = $ENV{TMPDIR} || '';
148  my $dir = $ENV{PERL_CORE} ? MBTest->original_cwd : File::Spec->tmpdir;
149  return File::Temp::tempdir('MB-XXXXXXXX', CLEANUP => 1, DIR => $dir, @args);
150}
151
152BEGIN {
153  $ENV{HOME} = tmpdir; # don't want .modulebuildrc or other things interfering
154}
155
156sub save_handle {
157  my ($handle, $subr) = @_;
158  my $outfile = File::Spec->catfile(File::Spec->tmpdir, temp_file_name());
159
160  local *SAVEOUT;
161  open SAVEOUT, ">&" . fileno($handle)
162    or die "Can't save output handle: $!";
163  open $handle, "> $outfile" or die "Can't create $outfile: $!";
164
165  eval {$subr->()};
166  open $handle, ">&SAVEOUT" or die "Can't restore output: $!";
167
168  my $ret = slurp($outfile);
169  1 while unlink $outfile;
170  return $ret;
171}
172
173sub stdout_of { save_handle(\*STDOUT, @_) }
174sub stderr_of { save_handle(\*STDERR, @_) }
175sub stdout_stderr_of {
176  my $subr = shift;
177  my ($stdout, $stderr);
178  $stdout = stdout_of ( sub {
179      $stderr = stderr_of( $subr )
180  });
181  return wantarray ? ($stdout, $stderr) : $stdout . $stderr;
182}
183
184sub slurp {
185  open(my $fh, '<', $_[0]) or die "Can't open $_[0]: $!";
186  local $/;
187  return scalar <$fh>;
188}
189
190# Some extensions we should know about if we're looking for executables
191sub exe_exts {
192
193  if ($^O eq 'MSWin32') {
194    return split($Config{path_sep}, $ENV{PATHEXT} || '.com;.exe;.bat');
195  }
196  if ($^O eq 'os2') {
197    return qw(.exe .com .pl .cmd .bat .sh .ksh);
198  }
199  return;
200}
201
202sub find_in_path {
203  my $thing = shift;
204
205  my @exe_ext = exe_exts();
206  if ( File::Spec->file_name_is_absolute( $thing ) ) {
207    foreach my $ext ( '', @exe_ext ) {
208      return "$thing$ext" if -e "$thing$ext";
209    }
210  }
211  else {
212    my @path = split $Config{path_sep}, $ENV{PATH};
213    foreach (@path) {
214      my $fullpath = File::Spec->catfile($_, $thing);
215      foreach my $ext ( '', @exe_ext ) {
216        return "$fullpath$ext" if -e "$fullpath$ext";
217      }
218    }
219  }
220  return;
221}
222
223sub check_compiler {
224  if ($ENV{PERL_CORE}) {
225    require IPC::Cmd;
226    if ( $Config{usecrosscompile} && !IPC::Cmd::can_run($Config{cc}) ) {
227      return;
228    }
229    else {
230      return(1,1);
231    }
232  }
233
234  local $SIG{__WARN__} = sub {};
235
236  blib_load('Module::Build');
237  my $mb = Module::Build->current;
238  $mb->verbose( 0 );
239
240  my $have_c_compiler;
241  stderr_of( sub {$have_c_compiler = $mb->have_c_compiler} );
242  # XXX link_executable() is not yet implemented for Windows
243  # and noexec tmpdir is irrelevant on Windows
244  return ($have_c_compiler, 1) if $^O eq "MSWin32";
245
246  # check noexec tmpdir
247  my $tmp_exec;
248  if ( $have_c_compiler ) {
249    my $dir = MBTest->tmpdir;
250    my $c_file = File::Spec->catfile($dir,'test.c');
251    open my $fh, ">", $c_file;
252    print {$fh} "int main() { return 0; }\n";
253    close $fh;
254    my $exe = $mb->cbuilder->link_executable(
255      objects => $mb->cbuilder->compile( source => $c_file )
256    );
257    $tmp_exec = 0 == system( $exe );
258  }
259  return ($have_c_compiler, $tmp_exec);
260}
261
262sub have_module {
263  my $module = shift;
264  return eval "require $module; 1";
265}
266
267sub blib_load {
268  # Load the given module and ensure it came from blib/, not the larger system
269  my $mod = shift;
270  have_module($mod) or die "Error loading $mod\: $@\n";
271
272  (my $path = $mod) =~ s{::}{/}g;
273  $path .= ".pm";
274  my ($pkg, $file, $line) = caller;
275  unless($ENV{PERL_CORE}) {
276    unless($INC{$path} =~ m/\bblib\b/) {
277      (my $load_from = $INC{$path}) =~ s{$path$}{};
278      die "$mod loaded from '$load_from'\nIt should have been loaded from blib.  \@INC contains:\n  ",
279      join("\n  ", @INC) . "\nFatal error occured in blib_load() at $file, line $line.\n";
280    }
281  }
282}
283
284sub timed_out {
285  my ($sub, $timeout) = @_;
286  return unless $sub;
287  $timeout ||= 60;
288
289  my $saw_alarm = 0;
290  eval {
291    local $SIG{ALRM} = sub { $saw_alarm++; die "alarm\n"; }; # NB: \n required
292    alarm $timeout;
293    $sub->();
294    alarm 0;
295  };
296  if ($@) {
297    die unless $@ eq "alarm\n";   # propagate unexpected errors
298  }
299  return $saw_alarm;
300}
301
302sub check_EUI {
303  my $timed_out;
304  stdout_stderr_of( sub {
305      $timed_out = timed_out( sub {
306          ExtUtils::Installed->new(extra_libs => [@INC])
307        }
308      );
309    }
310  );
311  return ! $timed_out;
312}
313
3141;
315# vim:ts=2:sw=2:et:sta
316