ext/Module-Build/t/destinations.t

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use lib 't/lib';
   5 use MBTest tests => 115;
   6
   7 use_ok 'Module::Build';
   8 ensure_blib('Module::Build');
   9
  10 my $tmp = MBTest->tmpdir;
  11
  12 use DistGen;
  13 my $dist = DistGen->new( dir => $tmp );
  14 $dist->regen;
  15
  16 $dist->chdir_in;
  17
  18
  19 use Config;
  20 use File::Spec::Functions qw( catdir splitdir splitpath );
  21
  22 #########################
  23
  24 # We need to create a well defined environment to test install paths.
  25 # We do this by setting up appropriate Config entries.
  26
  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
  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
 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     my $old =  $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     $mb->install_sets->{site} = $old;
 259 }
 260
 261
 262 # Check that we can use install_base after setting prefix.
 263 {
 264     my $install_base = catdir( 'foo', 'bar' );
 265     $mb->install_base( $install_base );
 266
 267     test_install_destinations( $mb, {
 268         lib     => catdir( $install_base, 'lib', 'perl5' ),
 269         arch    => catdir( $install_base, 'lib', 'perl5', $Config{archname} ),
 270         bin     => catdir( $install_base, 'bin' ),
 271         script  => catdir( $install_base, 'bin' ),
 272         bindoc  => catdir( $install_base, 'man', 'man1'),
 273         libdoc  => catdir( $install_base, 'man', 'man3' ),
 274         binhtml => catdir( $install_base, 'html' ),
 275         libhtml => catdir( $install_base, 'html' ),
 276     });
 277 }
 278
 279
 280 sub test_prefix {
 281     my ($prefix, $test_config) = @_;
 282
 283     local $Test::Builder::Level = $Test::Builder::Level + 1;
 284
 285     foreach my $type (qw(lib arch bin script bindoc libdoc binhtml libhtml)) {
 286         my $dest = $mb->install_destination( $type );
 287         ok $mb->dir_contains($prefix, $dest), "$type prefixed";
 288
 289         SKIP: {
 290             skip( "'$type' not configured", 1 )
 291               unless $test_config && $test_config->{$type};
 292
 293             have_same_ending( $dest, $test_config->{$type},
 294                               "  suffix correctish " .
 295                               "($test_config->{$type} + $prefix = $dest)" );
 296         }
 297     }
 298 }
 299
 300 sub have_same_ending {
 301   my ($dir1, $dir2, $message) = @_;
 302
 303   $dir1 =~ s{/$}{} if $^O eq 'cygwin'; # remove any trailing slash
 304   my (undef, $dirs1, undef) = splitpath $dir1;
 305   my @dir1 = splitdir $dirs1;
 306
 307   $dir2 =~ s{/$}{} if $^O eq 'cygwin'; # remove any trailing slash
 308   my (undef, $dirs2, undef) = splitpath $dir2;
 309   my @dir2 = splitdir $dirs2;
 310
 311   is $dir1[-1], $dir2[-1], $message;
 312 }
 313
 314 sub test_install_destinations {
 315     my($build, $expect) = @_;
 316
 317     local $Test::Builder::Level = $Test::Builder::Level + 1;
 318
 319     while( my($type, $expect) = each %$expect ) {
 320         is( $build->install_destination($type), $expect, "$type destination" );
 321     }
 322 }
 323
 324
 325 $dist->remove;