cpan/Module-Build/t/destinations.t

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use lib 't/lib';
   5 use MBTest tests => 113;
   6
   7 blib_load('Module::Build');
   8
   9 my $tmp = MBTest->tmpdir;
  10
  11 use DistGen;
  12 my $dist = DistGen->new( dir => $tmp );
  13 $dist->regen;
  14
  15 $dist->chdir_in;
  16
  17
  18 use Config;
  19 use File::Spec::Functions qw( catdir splitdir splitpath );
  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 my @installstyle = qw(lib perl5);
  27 my $mb = Module::Build->new_from_context(
  28   installdirs => 'site',
  29   config => {
  30     installstyle    => catdir(@installstyle),
  31
  32     installprivlib  => catdir($tmp, @installstyle),
  33     installarchlib  => catdir($tmp, @installstyle,
  34                               @Config{qw(version archname)}),
  35     installbin      => catdir($tmp, 'bin'),
  36     installscript   => catdir($tmp, 'bin'),
  37     installman1dir  => catdir($tmp, 'man', 'man1'),
  38     installman3dir  => catdir($tmp, 'man', 'man3'),
  39     installhtml1dir => catdir($tmp, 'html'),
  40     installhtml3dir => catdir($tmp, 'html'),
  41
  42     installsitelib      => catdir($tmp, 'site', @installstyle, 'site_perl'),
  43     installsitearch     => catdir($tmp, 'site', @installstyle, 'site_perl',
  44                                   @Config{qw(version archname)}),
  45     installsitebin      => catdir($tmp, 'site', 'bin'),
  46     installsitescript   => catdir($tmp, 'site', 'bin'),
  47     installsiteman1dir  => catdir($tmp, 'site', 'man', 'man1'),
  48     installsiteman3dir  => catdir($tmp, 'site', 'man', 'man3'),
  49     installsitehtml1dir => catdir($tmp, 'site', 'html'),
  50     installsitehtml3dir => catdir($tmp, 'site', 'html'),
  51   }
  52 );
  53 isa_ok( $mb, 'Module::Build::Base' );
  54
  55 # Get us into a known state.
  56 $mb->install_base(undef);
  57 $mb->prefix(undef);
  58
  59
  60 # Check install_path() accessor
  61 {
  62     my( $map, $path );
  63
  64     $map = $mb->install_path();
  65     is_deeply( $map, {}, 'install_path() accessor' );
  66
  67     $path = $mb->install_path('elem' => '/foo/bar');
  68     is( $path, '/foo/bar', '  returns assigned path' );
  69
  70     $path = $mb->install_path('elem');
  71     is( $path, '/foo/bar', '  can read stored path' );
  72
  73     $map = $mb->install_path();
  74     is_deeply( $map, { 'elem' => '/foo/bar' }, '  can access map' );
  75
  76     $path = $mb->install_path('elem' => undef);
  77     is( $path, undef, '  can delete a path element' );
  78
  79     $map = $mb->install_path();
  80     is_deeply( $map, {}, '  deletes path from map' );
  81 }
  82
  83 # Check install_base_relpaths() accessor
  84 {
  85     my( $map, $path );
  86
  87     $map = $mb->install_base_relpaths();
  88     is( ref($map), 'HASH', 'install_base_relpaths() accessor' );
  89
  90     eval{ $path = $mb->install_base_relpaths('elem' => '/foo/bar') };
  91     like( $@, qr/Value must be a relative path/, '  emits error if path not relative' );
  92
  93     $path = $mb->install_base_relpaths('elem' => 'foo/bar');
  94     is( $path, catdir(qw(foo bar)), '  returns assigned path' );
  95
  96     $path = $mb->install_base_relpaths('elem');
  97     is( $path, catdir(qw(foo/bar)), '  can read stored path' );
  98
  99     $map = $mb->install_base_relpaths();
 100     is_deeply( $map->{elem}, [qw(foo bar)], '  can access map' );
 101
 102     $path = $mb->install_base_relpaths('elem' => undef);
 103     is( $path, undef, '  can delete a path element' );
 104
 105     $map = $mb->install_base_relpaths();
 106     is( $map->{elem}, undef, '  deletes path from map' );
 107 }
 108
 109 # Check prefix_relpaths() accessor
 110 {
 111     my( $map, $path );
 112
 113     $map = $mb->prefix_relpaths();
 114     is( ref($map), 'HASH', 'prefix_relpaths() accessor' );
 115
 116     is_deeply( $mb->prefix_relpaths(), $mb->prefix_relpaths('site'),
 117                '  defaults to \'site\'' );
 118
 119     eval{ $path = $mb->prefix_relpaths('site', 'elem' => '/foo/bar') };
 120     like( $@, qr/Value must be a relative path/, '  emits error if path not relative' );
 121
 122     $path = $mb->prefix_relpaths('site', 'elem' => 'foo/bar');
 123     is( $path, catdir(qw(foo bar)), '  returns assigned path' );
 124
 125     $path = $mb->prefix_relpaths('site', 'elem');
 126     is( $path, catdir(qw(foo bar)), '  can read stored path' );
 127
 128     $map = $mb->prefix_relpaths();
 129     is_deeply( $map->{elem}, [qw(foo bar)], '  can access map' );
 130
 131     $path = $mb->prefix_relpaths('site', 'elem' => undef);
 132     is( $path, undef, '  can delete a path element' );
 133
 134     $map = $mb->prefix_relpaths();
 135     is( $map->{elem}, undef, '  deletes path from map' );
 136 }
 137
 138
 139 # Check that we install into the proper default locations.
 140 {
 141     is( $mb->installdirs, 'site' );
 142     is( $mb->install_base, undef );
 143     is( $mb->prefix,       undef );
 144
 145     test_install_destinations( $mb, {
 146       lib     => catdir($tmp, 'site', @installstyle, 'site_perl'),
 147       arch    => catdir($tmp, 'site', @installstyle, 'site_perl',
 148                         @Config{qw(version archname)}),
 149       bin     => catdir($tmp, 'site', 'bin'),
 150       script  => catdir($tmp, 'site', 'bin'),
 151       bindoc  => catdir($tmp, 'site', 'man', 'man1'),
 152       libdoc  => catdir($tmp, 'site', 'man', 'man3'),
 153       binhtml => catdir($tmp, 'site', 'html'),
 154       libhtml => catdir($tmp, 'site', 'html'),
 155     });
 156 }
 157
 158
 159 # Is installdirs honored?
 160 {
 161     $mb->installdirs('core');
 162     is( $mb->installdirs, 'core' );
 163
 164     test_install_destinations( $mb, {
 165       lib     => catdir($tmp, @installstyle),
 166       arch    => catdir($tmp, @installstyle, @Config{qw(version archname)}),
 167       bin     => catdir($tmp, 'bin'),
 168       script  => catdir($tmp, 'bin'),
 169       bindoc  => catdir($tmp, 'man', 'man1'),
 170       libdoc  => catdir($tmp, 'man', 'man3'),
 171       binhtml => catdir($tmp, 'html'),
 172       libhtml => catdir($tmp, 'html'),
 173     });
 174
 175     $mb->installdirs('site');
 176     is( $mb->installdirs, 'site' );
 177 }
 178
 179
 180 # Check install_base()
 181 {
 182     my $install_base = catdir( 'foo', 'bar' );
 183     $mb->install_base( $install_base );
 184
 185     is( $mb->prefix,       undef );
 186     is( $mb->install_base, $install_base );
 187
 188
 189     test_install_destinations( $mb, {
 190         lib     => catdir( $install_base, 'lib', 'perl5' ),
 191         arch    => catdir( $install_base, 'lib', 'perl5', $Config{archname} ),
 192         bin     => catdir( $install_base, 'bin' ),
 193         script  => catdir( $install_base, 'bin' ),
 194         bindoc  => catdir( $install_base, 'man', 'man1'),
 195         libdoc  => catdir( $install_base, 'man', 'man3' ),
 196         binhtml => catdir( $install_base, 'html' ),
 197         libhtml => catdir( $install_base, 'html' ),
 198     });
 199 }
 200
 201
 202 # Basic prefix test.  Ensure everything is under the prefix.
 203 {
 204     $mb->install_base( undef );
 205     ok( !defined $mb->install_base );
 206
 207     my $prefix = catdir( qw( some prefix ) );
 208     $mb->prefix( $prefix );
 209     is( $mb->{properties}{prefix}, $prefix );
 210
 211     test_prefix($prefix, $mb->install_sets('site'));
 212 }
 213
 214
 215 # And now that prefix honors installdirs.
 216 {
 217     $mb->installdirs('core');
 218     is( $mb->installdirs, 'core' );
 219
 220     my $prefix = catdir( qw( some prefix ) );
 221     test_prefix($prefix);
 222
 223     $mb->installdirs('site');
 224     is( $mb->installdirs, 'site' );
 225 }
 226
 227
 228 # Try a config setting which would result in installation locations outside
 229 # the prefix.  Ensure it doesn't.
 230 {
 231     # Get the prefix defaults
 232     my $defaults = $mb->prefix_relpaths('site');
 233
 234     # Create a configuration involving weird paths that are outside of
 235     # the configured prefix.
 236     my @prefixes = (
 237                     [qw(foo bar)],
 238                     [qw(biz)],
 239                     [],
 240                    );
 241
 242     my %test_config;
 243     foreach my $type (keys %$defaults) {
 244         my $prefix = shift @prefixes || [qw(foo bar)];
 245         $test_config{$type} = catdir(File::Spec->rootdir, @$prefix,
 246                                      @{$defaults->{$type}});
 247     }
 248
 249     # Poke at the innards of MB to change the default install locations.
 250     my $old =  $mb->install_sets->{site};
 251     $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