vcs.maemo.org Git - dh-make-perl/blob - dev/arm/libmodule-build-perl/libmodule-build-perl-0.2808.01/t/destinations.t

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use lib $ENV{PERL_CORE} ? '../lib/Module/Build/t/lib' : 't/lib';
   5 use MBTest tests => 113;
   6
   7 use Cwd ();
   8 my $cwd = Cwd::cwd;
   9 my $tmp = MBTest->tmpdir;
  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;
  19 use File::Spec::Functions qw( catdir splitdir );
  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
  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     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
 303   my @dir1 = splitdir $dir1;
 304
 305   $dir2 =~ s{/$}{} if $^O eq 'cygwin'; # remove any trailing slash
 306   my @dir2 = splitdir $dir2;
 307
 308   is $dir1[-1], $dir2[-1], $message;
 309 }
 310
 311 sub test_install_destinations {
 312     my($build, $expect) = @_;
 313
 314     local $Test::Builder::Level = $Test::Builder::Level + 1;
 315
 316     while( my($type, $expect) = each %$expect ) {
 317         is( $build->install_destination($type), $expect, "$type destination" );
 318     }
 319 }
 320
 321
 322 chdir( $cwd ) or die "Can''t chdir to '$cwd': $!";
 323 $dist->remove;
 324
 325 use File::Path;
 326 rmtree( $tmp );