Commit | Line | Data |
bb4e9162 |
1 | #!/usr/bin/perl -w |
2 | |
3 | use strict; |
4 | use lib $ENV{PERL_CORE} ? '../lib/Module/Build/t/lib' : 't/lib'; |
dc8021d3 |
5 | use MBTest tests => 113; |
bb4e9162 |
6 | |
7 | use Cwd (); |
8 | my $cwd = Cwd::cwd; |
7a827510 |
9 | my $tmp = MBTest->tmpdir; |
bb4e9162 |
10 | |
11 | use DistGen; |
12 | my $dist = DistGen->new( dir => $tmp ); |
13 | $dist->regen; |
14 | |
15 | chdir( $dist->dirname ) or die "Can't chdir to '@{[$dist->dirname]}': $!"; |
16 | |
17 | |
18 | use Config; |
3143ec60 |
19 | use File::Spec::Functions qw( catdir splitdir splitpath ); |
bb4e9162 |
20 | |
21 | ######################### |
22 | |
23 | # We need to create a well defined environment to test install paths. |
24 | # We do this by setting up appropriate Config entries. |
25 | |
26 | use Module::Build; |
27 | my @installstyle = qw(lib perl5); |
28 | my $mb = Module::Build->new_from_context( |
29 | installdirs => 'site', |
30 | config => { |
31 | installstyle => catdir(@installstyle), |
32 | |
33 | installprivlib => catdir($tmp, @installstyle), |
34 | installarchlib => catdir($tmp, @installstyle, |
35 | @Config{qw(version archname)}), |
36 | installbin => catdir($tmp, 'bin'), |
37 | installscript => catdir($tmp, 'bin'), |
38 | installman1dir => catdir($tmp, 'man', 'man1'), |
39 | installman3dir => catdir($tmp, 'man', 'man3'), |
40 | installhtml1dir => catdir($tmp, 'html'), |
41 | installhtml3dir => catdir($tmp, 'html'), |
42 | |
43 | installsitelib => catdir($tmp, 'site', @installstyle, 'site_perl'), |
44 | installsitearch => catdir($tmp, 'site', @installstyle, 'site_perl', |
45 | @Config{qw(version archname)}), |
46 | installsitebin => catdir($tmp, 'site', 'bin'), |
47 | installsitescript => catdir($tmp, 'site', 'bin'), |
48 | installsiteman1dir => catdir($tmp, 'site', 'man', 'man1'), |
49 | installsiteman3dir => catdir($tmp, 'site', 'man', 'man3'), |
50 | installsitehtml1dir => catdir($tmp, 'site', 'html'), |
51 | installsitehtml3dir => catdir($tmp, 'site', 'html'), |
52 | } |
53 | ); |
54 | isa_ok( $mb, 'Module::Build::Base' ); |
55 | |
56 | # Get us into a known state. |
57 | $mb->install_base(undef); |
58 | $mb->prefix(undef); |
59 | |
60 | |
dc8021d3 |
61 | # Check install_path() accessor |
62 | { |
63 | my( $map, $path ); |
64 | |
65 | $map = $mb->install_path(); |
66 | is_deeply( $map, {}, 'install_path() accessor' ); |
67 | |
68 | $path = $mb->install_path('elem' => '/foo/bar'); |
69 | is( $path, '/foo/bar', ' returns assigned path' ); |
70 | |
71 | $path = $mb->install_path('elem'); |
72 | is( $path, '/foo/bar', ' can read stored path' ); |
73 | |
74 | $map = $mb->install_path(); |
75 | is_deeply( $map, { 'elem' => '/foo/bar' }, ' can access map' ); |
76 | |
77 | $path = $mb->install_path('elem' => undef); |
78 | is( $path, undef, ' can delete a path element' ); |
79 | |
80 | $map = $mb->install_path(); |
81 | is_deeply( $map, {}, ' deletes path from map' ); |
82 | } |
83 | |
84 | # Check install_base_relpaths() accessor |
85 | { |
86 | my( $map, $path ); |
87 | |
88 | $map = $mb->install_base_relpaths(); |
89 | is( ref($map), 'HASH', 'install_base_relpaths() accessor' ); |
90 | |
91 | eval{ $path = $mb->install_base_relpaths('elem' => '/foo/bar') }; |
92 | like( $@, qr/Value must be a relative path/, ' emits error if path not relative' ); |
93 | |
94 | $path = $mb->install_base_relpaths('elem' => 'foo/bar'); |
95 | is( $path, catdir(qw(foo bar)), ' returns assigned path' ); |
96 | |
97 | $path = $mb->install_base_relpaths('elem'); |
98 | is( $path, catdir(qw(foo/bar)), ' can read stored path' ); |
99 | |
100 | $map = $mb->install_base_relpaths(); |
101 | is_deeply( $map->{elem}, [qw(foo bar)], ' can access map' ); |
102 | |
103 | $path = $mb->install_base_relpaths('elem' => undef); |
104 | is( $path, undef, ' can delete a path element' ); |
105 | |
106 | $map = $mb->install_base_relpaths(); |
107 | is( $map->{elem}, undef, ' deletes path from map' ); |
108 | } |
109 | |
110 | # Check prefix_relpaths() accessor |
111 | { |
112 | my( $map, $path ); |
113 | |
114 | $map = $mb->prefix_relpaths(); |
115 | is( ref($map), 'HASH', 'prefix_relpaths() accessor' ); |
116 | |
117 | is_deeply( $mb->prefix_relpaths(), $mb->prefix_relpaths('site'), |
118 | ' defaults to \'site\'' ); |
119 | |
120 | eval{ $path = $mb->prefix_relpaths('site', 'elem' => '/foo/bar') }; |
121 | like( $@, qr/Value must be a relative path/, ' emits error if path not relative' ); |
122 | |
123 | $path = $mb->prefix_relpaths('site', 'elem' => 'foo/bar'); |
124 | is( $path, catdir(qw(foo bar)), ' returns assigned path' ); |
125 | |
126 | $path = $mb->prefix_relpaths('site', 'elem'); |
127 | is( $path, catdir(qw(foo bar)), ' can read stored path' ); |
128 | |
129 | $map = $mb->prefix_relpaths(); |
130 | is_deeply( $map->{elem}, [qw(foo bar)], ' can access map' ); |
131 | |
132 | $path = $mb->prefix_relpaths('site', 'elem' => undef); |
133 | is( $path, undef, ' can delete a path element' ); |
134 | |
135 | $map = $mb->prefix_relpaths(); |
136 | is( $map->{elem}, undef, ' deletes path from map' ); |
137 | } |
138 | |
139 | |
bb4e9162 |
140 | # Check that we install into the proper default locations. |
141 | { |
142 | is( $mb->installdirs, 'site' ); |
143 | is( $mb->install_base, undef ); |
144 | is( $mb->prefix, undef ); |
145 | |
146 | test_install_destinations( $mb, { |
147 | lib => catdir($tmp, 'site', @installstyle, 'site_perl'), |
148 | arch => catdir($tmp, 'site', @installstyle, 'site_perl', |
149 | @Config{qw(version archname)}), |
150 | bin => catdir($tmp, 'site', 'bin'), |
151 | script => catdir($tmp, 'site', 'bin'), |
152 | bindoc => catdir($tmp, 'site', 'man', 'man1'), |
153 | libdoc => catdir($tmp, 'site', 'man', 'man3'), |
154 | binhtml => catdir($tmp, 'site', 'html'), |
155 | libhtml => catdir($tmp, 'site', 'html'), |
156 | }); |
157 | } |
158 | |
159 | |
160 | # Is installdirs honored? |
161 | { |
162 | $mb->installdirs('core'); |
163 | is( $mb->installdirs, 'core' ); |
164 | |
165 | test_install_destinations( $mb, { |
166 | lib => catdir($tmp, @installstyle), |
167 | arch => catdir($tmp, @installstyle, @Config{qw(version archname)}), |
168 | bin => catdir($tmp, 'bin'), |
169 | script => catdir($tmp, 'bin'), |
170 | bindoc => catdir($tmp, 'man', 'man1'), |
171 | libdoc => catdir($tmp, 'man', 'man3'), |
172 | binhtml => catdir($tmp, 'html'), |
173 | libhtml => catdir($tmp, 'html'), |
174 | }); |
175 | |
176 | $mb->installdirs('site'); |
177 | is( $mb->installdirs, 'site' ); |
178 | } |
179 | |
180 | |
181 | # Check install_base() |
182 | { |
183 | my $install_base = catdir( 'foo', 'bar' ); |
184 | $mb->install_base( $install_base ); |
185 | |
186 | is( $mb->prefix, undef ); |
187 | is( $mb->install_base, $install_base ); |
188 | |
189 | |
190 | test_install_destinations( $mb, { |
191 | lib => catdir( $install_base, 'lib', 'perl5' ), |
192 | arch => catdir( $install_base, 'lib', 'perl5', $Config{archname} ), |
193 | bin => catdir( $install_base, 'bin' ), |
194 | script => catdir( $install_base, 'bin' ), |
195 | bindoc => catdir( $install_base, 'man', 'man1'), |
196 | libdoc => catdir( $install_base, 'man', 'man3' ), |
197 | binhtml => catdir( $install_base, 'html' ), |
198 | libhtml => catdir( $install_base, 'html' ), |
199 | }); |
200 | } |
201 | |
202 | |
203 | # Basic prefix test. Ensure everything is under the prefix. |
204 | { |
205 | $mb->install_base( undef ); |
206 | ok( !defined $mb->install_base ); |
207 | |
208 | my $prefix = catdir( qw( some prefix ) ); |
209 | $mb->prefix( $prefix ); |
210 | is( $mb->{properties}{prefix}, $prefix ); |
211 | |
212 | test_prefix($prefix, $mb->install_sets('site')); |
213 | } |
214 | |
215 | |
216 | # And now that prefix honors installdirs. |
217 | { |
218 | $mb->installdirs('core'); |
219 | is( $mb->installdirs, 'core' ); |
220 | |
221 | my $prefix = catdir( qw( some prefix ) ); |
222 | test_prefix($prefix); |
223 | |
224 | $mb->installdirs('site'); |
225 | is( $mb->installdirs, 'site' ); |
226 | } |
227 | |
228 | |
229 | # Try a config setting which would result in installation locations outside |
230 | # the prefix. Ensure it doesn't. |
231 | { |
232 | # Get the prefix defaults |
233 | my $defaults = $mb->prefix_relpaths('site'); |
234 | |
235 | # Create a configuration involving weird paths that are outside of |
236 | # the configured prefix. |
237 | my @prefixes = ( |
238 | [qw(foo bar)], |
239 | [qw(biz)], |
240 | [], |
241 | ); |
242 | |
243 | my %test_config; |
244 | foreach my $type (keys %$defaults) { |
245 | my $prefix = shift @prefixes || [qw(foo bar)]; |
246 | $test_config{$type} = catdir(File::Spec->rootdir, @$prefix, |
247 | @{$defaults->{$type}}); |
248 | } |
249 | |
250 | # Poke at the innards of MB to change the default install locations. |
251 | local $mb->install_sets->{site} = \%test_config; |
252 | $mb->config(siteprefixexp => catdir(File::Spec->rootdir, |
253 | 'wierd', 'prefix')); |
254 | |
255 | my $prefix = catdir('another', 'prefix'); |
256 | $mb->prefix($prefix); |
257 | test_prefix($prefix, \%test_config); |
258 | } |
259 | |
260 | |
261 | # Check that we can use install_base after setting prefix. |
262 | { |
263 | my $install_base = catdir( 'foo', 'bar' ); |
264 | $mb->install_base( $install_base ); |
265 | |
266 | test_install_destinations( $mb, { |
267 | lib => catdir( $install_base, 'lib', 'perl5' ), |
268 | arch => catdir( $install_base, 'lib', 'perl5', $Config{archname} ), |
269 | bin => catdir( $install_base, 'bin' ), |
270 | script => catdir( $install_base, 'bin' ), |
271 | bindoc => catdir( $install_base, 'man', 'man1'), |
272 | libdoc => catdir( $install_base, 'man', 'man3' ), |
273 | binhtml => catdir( $install_base, 'html' ), |
274 | libhtml => catdir( $install_base, 'html' ), |
275 | }); |
276 | } |
277 | |
278 | |
279 | sub test_prefix { |
280 | my ($prefix, $test_config) = @_; |
281 | |
282 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
283 | |
284 | foreach my $type (qw(lib arch bin script bindoc libdoc binhtml libhtml)) { |
285 | my $dest = $mb->install_destination( $type ); |
286 | ok $mb->dir_contains($prefix, $dest), "$type prefixed"; |
287 | |
288 | SKIP: { |
289 | skip( "'$type' not configured", 1 ) |
290 | unless $test_config && $test_config->{$type}; |
291 | |
292 | have_same_ending( $dest, $test_config->{$type}, |
293 | " suffix correctish " . |
294 | "($test_config->{$type} + $prefix = $dest)" ); |
295 | } |
296 | } |
297 | } |
298 | |
299 | sub have_same_ending { |
300 | my ($dir1, $dir2, $message) = @_; |
301 | |
302 | $dir1 =~ s{/$}{} if $^O eq 'cygwin'; # remove any trailing slash |
3143ec60 |
303 | my (undef, $dirs1, undef) = splitpath $dir1; |
304 | my @dir1 = splitdir $dirs1; |
bb4e9162 |
305 | |
306 | $dir2 =~ s{/$}{} if $^O eq 'cygwin'; # remove any trailing slash |
3143ec60 |
307 | my (undef, $dirs2, undef) = splitpath $dir2; |
308 | my @dir2 = splitdir $dirs2; |
bb4e9162 |
309 | |
310 | is $dir1[-1], $dir2[-1], $message; |
311 | } |
312 | |
313 | sub test_install_destinations { |
314 | my($build, $expect) = @_; |
315 | |
316 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
317 | |
318 | while( my($type, $expect) = each %$expect ) { |
319 | is( $build->install_destination($type), $expect, "$type destination" ); |
320 | } |
321 | } |
322 | |
323 | |
324 | chdir( $cwd ) or die "Can''t chdir to '$cwd': $!"; |
325 | $dist->remove; |
326 | |
327 | use File::Path; |
328 | rmtree( $tmp ); |