This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
As well as @INC, also convert $^X to an absolute path in MBTest.
[perl5.git] / lib / Module / Build / t / lib / MBTest.pm
CommitLineData
bb4e9162
YST
1package MBTest;
2
3use strict;
4
5use File::Spec;
7a827510 6use File::Path ();
bb4e9162
YST
7
8BEGIN {
9 # Make sure none of our tests load the users ~/.modulebuildrc file
10 $ENV{MODULEBUILDRC} = 'NONE';
11
738349a8
SH
12 # In case the test wants to use our other bundled
13 # modules, make sure they can be loaded.
bb4e9162
YST
14 my $t_lib = File::Spec->catdir('t', 'bundled');
15
7a827510 16 unless ($ENV{PERL_CORE}) {
bb4e9162
YST
17 push @INC, $t_lib; # Let user's installed version override
18 } else {
5f259b1a 19 # We change directories, so expand @INC and $^X to absolute paths
bb4e9162
YST
20 # Also add .
21 @INC = (map(File::Spec->rel2abs($_), @INC), ".");
5f259b1a 22 $^X = File::Spec->rel2abs($^X);
bb4e9162
YST
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
35use Exporter;
36use Test::More;
37use Config;
7a827510 38use Cwd ();
bb4e9162
YST
39
40# We pass everything through to Test::More
41use 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
RGS
49my @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
738349a8 57 ensure_blib
7a827510 58);
bb4e9162
YST
59push @EXPORT, @extra_exports;
60__PACKAGE__->export(scalar caller, @extra_exports);
7a827510
RGS
61# XXX ^-- that should really happen in import()
62########################################################################
63
64{ # Setup a temp directory if it doesn't exist
65 my $cwd = Cwd::cwd;
3143ec60 66 my $tmp = File::Spec->catdir( $cwd, 't', '_tmp' . $$);
7a827510
RGS
67 mkdir $tmp, 0777 unless -d $tmp;
68
69 sub tmpdir { $tmp }
70 END {
71 if(-d $tmp) {
738349a8
SH
72 # Go back to where you came from!
73 chdir $cwd or die "Couldn't chdir to $cwd";
74 File::Path::rmtree($tmp) or diag "cannot clean dir '$tmp'";
7a827510
RGS
75 }
76 }
77}
78########################################################################
bb4e9162 79
7a827510
RGS
80{ # backwards compatible temp filename recipe adapted from perlfaq
81 my $tmp_count = 0;
82 my $tmp_base_name = sprintf("%d-%d", $$, time());
83 sub temp_file_name {
84 sprintf("%s-%04d", $tmp_base_name, ++$tmp_count)
85 }
86}
87########################################################################
bb4e9162
YST
88
89sub save_handle {
90 my ($handle, $subr) = @_;
7a827510 91 my $outfile = temp_file_name();
bb4e9162
YST
92
93 local *SAVEOUT;
7a827510
RGS
94 open SAVEOUT, ">&" . fileno($handle)
95 or die "Can't save output handle: $!";
bb4e9162
YST
96 open $handle, "> $outfile" or die "Can't create $outfile: $!";
97
98 eval {$subr->()};
99 open $handle, ">&SAVEOUT" or die "Can't restore output: $!";
100
101 my $ret = slurp($outfile);
102 1 while unlink $outfile;
103 return $ret;
104}
105
106sub stdout_of { save_handle(\*STDOUT, @_) }
107sub stderr_of { save_handle(\*STDERR, @_) }
7a827510
RGS
108sub stdout_stderr_of {
109 my $subr = shift;
110 my ($stdout, $stderr);
111 $stdout = stdout_of ( sub {
112 $stderr = stderr_of( $subr )
113 });
114 return ($stdout, $stderr);
115}
bb4e9162
YST
116
117sub slurp {
118 my $fh = IO::File->new($_[0]) or die "Can't open $_[0]: $!";
119 local $/;
120 return scalar <$fh>;
121}
122
7a827510 123# Some extensions we should know about if we're looking for executables
7253302f 124sub exe_exts {
7253302f
SP
125
126 if ($^O eq 'MSWin32') {
127 return split($Config{path_sep}, $ENV{PATHEXT} || '.com;.exe;.bat');
128 }
129 if ($^O eq 'os2') {
130 return qw(.exe .com .pl .cmd .bat .sh .ksh);
131 }
132 return;
133}
134
bb4e9162
YST
135sub find_in_path {
136 my $thing = shift;
137
138 my @path = split $Config{path_sep}, $ENV{PATH};
7253302f 139 my @exe_ext = exe_exts();
bb4e9162
YST
140 foreach (@path) {
141 my $fullpath = File::Spec->catfile($_, $thing);
7253302f 142 foreach my $ext ( '', @exe_ext ) {
bb4e9162
YST
143 return "$fullpath$ext" if -e "$fullpath$ext";
144 }
145 }
146 return;
147}
148
149# returns ($have_c_compiler, $C_support_feature);
150sub check_compiler {
151 return (1,1) if $ENV{PERL_CORE};
152
153 local $SIG{__WARN__} = sub {};
154
155 my $mb = Module::Build->current;
156 $mb->verbose( 0 );
157
158 my $have_c_compiler;
159 stderr_of( sub {$have_c_compiler = $mb->have_c_compiler} );
160
161 return ($have_c_compiler, $mb->feature('C_support'));
162}
163
f943a5bf
SP
164sub have_module {
165 my $module = shift;
166 return eval "use $module; 1";
167}
168
738349a8
SH
169sub ensure_blib {
170 # Make sure the given module was loaded from blib/, not the larger system
171 my $mod = shift;
172 (my $path = $mod) =~ s{::}{/}g;
173
174 SKIP: {
175 skip "no blib in core", 1 if $ENV{PERL_CORE};
176 like $INC{"$path.pm"}, qr/\bblib\b/, "Make sure $mod was loaded from blib/";
177 }
178}
179
bb4e9162 1801;
7a827510 181# vim:ts=2:sw=2:et:sta