Commit | Line | Data |
bb4e9162 |
1 | package MBTest; |
2 | |
3 | use strict; |
4 | |
5 | use File::Spec; |
7a827510 |
6 | use File::Path (); |
bb4e9162 |
7 | |
8 | BEGIN { |
9 | # Make sure none of our tests load the users ~/.modulebuildrc file |
10 | $ENV{MODULEBUILDRC} = 'NONE'; |
11 | |
12 | # In case the test wants to use Test::More or our other bundled |
13 | # modules, make sure they can be loaded. They'll still do "use |
14 | # Test::More" in the test script. |
15 | my $t_lib = File::Spec->catdir('t', 'bundled'); |
16 | |
7a827510 |
17 | unless ($ENV{PERL_CORE}) { |
bb4e9162 |
18 | push @INC, $t_lib; # Let user's installed version override |
19 | } else { |
20 | # We change directories, so expand @INC to absolute paths |
21 | # Also add . |
22 | @INC = (map(File::Spec->rel2abs($_), @INC), "."); |
23 | |
24 | # we are in 't', go up a level so we don't create t/t/_tmp |
25 | chdir '..' or die "Couldn't chdir to .."; |
26 | |
27 | push @INC, File::Spec->catdir(qw/lib Module Build/, $t_lib); |
28 | |
29 | # make sure children get @INC pointing to uninstalled files |
30 | require Cwd; |
31 | $ENV{PERL5LIB} = File::Spec->catdir(Cwd::cwd(), 'lib'); |
32 | } |
33 | } |
34 | |
35 | use Exporter; |
36 | use Test::More; |
37 | use Config; |
7a827510 |
38 | use Cwd (); |
bb4e9162 |
39 | |
40 | # We pass everything through to Test::More |
41 | use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); |
42 | $VERSION = 0.01; |
43 | @ISA = qw(Test::More); # Test::More isa Exporter |
44 | @EXPORT = @Test::More::EXPORT; |
45 | %EXPORT_TAGS = %Test::More::EXPORT_TAGS; |
46 | |
47 | # We have a few extra exports, but Test::More has a special import() |
48 | # that won't take extra additions. |
7a827510 |
49 | my @extra_exports = qw( |
50 | stdout_of |
51 | stderr_of |
52 | stdout_stderr_of |
53 | slurp |
54 | find_in_path |
55 | check_compiler |
56 | have_module |
57 | ); |
bb4e9162 |
58 | push @EXPORT, @extra_exports; |
59 | __PACKAGE__->export(scalar caller, @extra_exports); |
7a827510 |
60 | # XXX ^-- that should really happen in import() |
61 | ######################################################################## |
62 | |
63 | { # Setup a temp directory if it doesn't exist |
64 | my $cwd = Cwd::cwd; |
65 | my $tmp = File::Spec->catdir( $cwd, 't', '_tmp.' . $$); |
66 | mkdir $tmp, 0777 unless -d $tmp; |
67 | |
68 | sub tmpdir { $tmp } |
69 | END { |
70 | if(-d $tmp) { |
71 | File::Path::rmtree($tmp) or warn "cannot clean dir '$tmp'"; |
72 | } |
73 | } |
74 | } |
75 | ######################################################################## |
bb4e9162 |
76 | |
7a827510 |
77 | { # backwards compatible temp filename recipe adapted from perlfaq |
78 | my $tmp_count = 0; |
79 | my $tmp_base_name = sprintf("%d-%d", $$, time()); |
80 | sub temp_file_name { |
81 | sprintf("%s-%04d", $tmp_base_name, ++$tmp_count) |
82 | } |
83 | } |
84 | ######################################################################## |
bb4e9162 |
85 | |
86 | sub save_handle { |
87 | my ($handle, $subr) = @_; |
7a827510 |
88 | my $outfile = temp_file_name(); |
bb4e9162 |
89 | |
90 | local *SAVEOUT; |
7a827510 |
91 | open SAVEOUT, ">&" . fileno($handle) |
92 | or die "Can't save output handle: $!"; |
bb4e9162 |
93 | open $handle, "> $outfile" or die "Can't create $outfile: $!"; |
94 | |
95 | eval {$subr->()}; |
96 | open $handle, ">&SAVEOUT" or die "Can't restore output: $!"; |
97 | |
98 | my $ret = slurp($outfile); |
99 | 1 while unlink $outfile; |
100 | return $ret; |
101 | } |
102 | |
103 | sub stdout_of { save_handle(\*STDOUT, @_) } |
104 | sub stderr_of { save_handle(\*STDERR, @_) } |
7a827510 |
105 | sub stdout_stderr_of { |
106 | my $subr = shift; |
107 | my ($stdout, $stderr); |
108 | $stdout = stdout_of ( sub { |
109 | $stderr = stderr_of( $subr ) |
110 | }); |
111 | return ($stdout, $stderr); |
112 | } |
bb4e9162 |
113 | |
114 | sub slurp { |
115 | my $fh = IO::File->new($_[0]) or die "Can't open $_[0]: $!"; |
116 | local $/; |
117 | return scalar <$fh>; |
118 | } |
119 | |
7a827510 |
120 | # Some extensions we should know about if we're looking for executables |
7253302f |
121 | sub exe_exts { |
7253302f |
122 | |
123 | if ($^O eq 'MSWin32') { |
124 | return split($Config{path_sep}, $ENV{PATHEXT} || '.com;.exe;.bat'); |
125 | } |
126 | if ($^O eq 'os2') { |
127 | return qw(.exe .com .pl .cmd .bat .sh .ksh); |
128 | } |
129 | return; |
130 | } |
131 | |
bb4e9162 |
132 | sub find_in_path { |
133 | my $thing = shift; |
134 | |
135 | my @path = split $Config{path_sep}, $ENV{PATH}; |
7253302f |
136 | my @exe_ext = exe_exts(); |
bb4e9162 |
137 | foreach (@path) { |
138 | my $fullpath = File::Spec->catfile($_, $thing); |
7253302f |
139 | foreach my $ext ( '', @exe_ext ) { |
bb4e9162 |
140 | return "$fullpath$ext" if -e "$fullpath$ext"; |
141 | } |
142 | } |
143 | return; |
144 | } |
145 | |
146 | # returns ($have_c_compiler, $C_support_feature); |
147 | sub check_compiler { |
148 | return (1,1) if $ENV{PERL_CORE}; |
149 | |
150 | local $SIG{__WARN__} = sub {}; |
151 | |
152 | my $mb = Module::Build->current; |
153 | $mb->verbose( 0 ); |
154 | |
155 | my $have_c_compiler; |
156 | stderr_of( sub {$have_c_compiler = $mb->have_c_compiler} ); |
157 | |
158 | return ($have_c_compiler, $mb->feature('C_support')); |
159 | } |
160 | |
f943a5bf |
161 | sub have_module { |
162 | my $module = shift; |
163 | return eval "use $module; 1"; |
164 | } |
165 | |
bb4e9162 |
166 | 1; |
7a827510 |
167 | # vim:ts=2:sw=2:et:sta |