lib/ExtUtils/t/Installed.t

   1 #!/usr/bin/perl -w
   2
   3 BEGIN {
   4     if( $ENV{PERL_CORE} ) {
   5         chdir 't' if -d 't';
   6         @INC = '../lib';
   7     }
   8     else {
   9         unshift @INC, 't/lib/';
  10     }
  11 }
  12 chdir 't';
  13
  14 my $Is_VMS = $^O eq 'VMS';
  15
  16 use strict;
  17
  18 use Config;
  19 use Cwd;
  20 use File::Path;
  21 use File::Basename;
  22 use File::Spec;
  23
  24 use Test::More tests => 63;
  25
  26 BEGIN { use_ok( 'ExtUtils::Installed' ) }
  27
  28 my $mandirs =  !!$Config{man1direxp} + !!$Config{man3direxp};
  29
  30 # saves having to qualify package name for class methods
  31 my $ei = bless( {}, 'ExtUtils::Installed' );
  32
  33 # Make sure meta info is available
  34 $ei->{':private:'}{Config} = \%Config;
  35 $ei->{':private:'}{INC} = \@INC;
  36
  37 # _is_prefix
  38 ok( $ei->_is_prefix('foo/bar', 'foo'),
  39         '_is_prefix() should match valid path prefix' );
  40 ok( !$ei->_is_prefix('\foo\bar', '\bar'),
  41         '... should not match wrong prefix' );
  42
  43 # _is_type
  44 ok( $ei->_is_type(0, 'all'), '_is_type() should be true for type of "all"' );
  45
  46 foreach my $path (qw( man1dir man3dir )) {
  47     SKIP: {
  48         my $dir = $Config{$path.'exp'};
  49         skip("no man directory $path on this system", 2 ) unless $dir;
  50
  51         my $file = $dir . '/foo';
  52         ok( $ei->_is_type($file, 'doc'),   "... should find doc file in $path" );
  53         ok( !$ei->_is_type($file, 'prog'), "... but not prog file in $path" );
  54     }
  55 }
  56
  57 # VMS 5.6.1 doesn't seem to have $Config{prefixexp}
  58 my $prefix = $Config{prefix} || $Config{prefixexp};
  59
  60 # You can concatenate /foo but not foo:, which defaults in the current
  61 # directory
  62 $prefix = VMS::Filespec::unixify($prefix) if $Is_VMS;
  63
  64 # ActivePerl 5.6.1/631 has $Config{prefixexp} as 'p:' for some reason
  65 $prefix = $Config{prefix} if $prefix eq 'p:' && $^O eq 'MSWin32';
  66
  67 ok( $ei->_is_type( File::Spec->catfile($prefix, 'bar'), 'prog'),
  68         "... should find prog file under $prefix" );
  69
  70 SKIP: {
  71     skip('no man directories on this system', 1) unless $mandirs;
  72     is( $ei->_is_type('bar', 'doc'), 0,
  73         '... should not find doc file outside path' );
  74 }
  75
  76 ok( !$ei->_is_type('bar', 'prog'),
  77         '... nor prog file outside path' );
  78 ok( !$ei->_is_type('whocares', 'someother'), '... nor other type anywhere' );
  79
  80 # _is_under
  81 ok( $ei->_is_under('foo'), '_is_under() should return true with no dirs' );
  82
  83 my @under = qw( boo bar baz );
  84 ok( !$ei->_is_under('foo', @under), '... should find no file not under dirs');
  85 ok( $ei->_is_under('baz', @under),  '... should find file under dir' );
  86
  87
  88 rmtree 'auto/FakeMod';
  89 ok( mkpath('auto/FakeMod') );
  90 END { rmtree 'auto' }
  91
  92 ok(open(PACKLIST, '>auto/FakeMod/.packlist'));
  93 print PACKLIST 'list';
  94 close PACKLIST;
  95
  96 ok(open(FAKEMOD, '>auto/FakeMod/FakeMod.pm'));
  97
  98 print FAKEMOD <<'FAKE';
  99 package FakeMod;
 100 use vars qw( $VERSION );
 101 $VERSION = '1.1.1';
 102 1;
 103 FAKE
 104
 105 close FAKEMOD;
 106
 107 my $fake_mod_dir = File::Spec->catdir(cwd(), 'auto', 'FakeMod');
 108 {
 109     # avoid warning and death by localizing glob
 110     local *ExtUtils::Installed::Config;
 111     %ExtUtils::Installed::Config = (
 112         %Config,
 113         archlibexp         => cwd(),
 114         sitearchexp        => $fake_mod_dir,
 115     );
 116
 117     # necessary to fool new()
 118     push @INC, $fake_mod_dir;
 119
 120     my $realei = ExtUtils::Installed->new();
 121     isa_ok( $realei, 'ExtUtils::Installed' );
 122     isa_ok( $realei->{Perl}{packlist}, 'ExtUtils::Packlist' );
 123     is( $realei->{Perl}{version}, $Config{version},
 124         'new() should set Perl version from %Config' );
 125
 126     ok( exists $realei->{FakeMod}, 'new() should find modules with .packlists');
 127     isa_ok( $realei->{FakeMod}{packlist}, 'ExtUtils::Packlist' );
 128     is( $realei->{FakeMod}{version}, '1.1.1',
 129         '... should find version in modules' );
 130 }
 131
 132 # Now try this using PERL5LIB
 133 {
 134     local $ENV{PERL5LIB} = join $Config{path_sep}, $fake_mod_dir;
 135     local *ExtUtils::Installed::Config;
 136     %ExtUtils::Installed::Config = (
 137         %Config,
 138         archlibexp         => cwd(),
 139         sitearchexp        => cwd(),
 140     );
 141
 142     my $realei = ExtUtils::Installed->new();
 143     isa_ok( $realei, 'ExtUtils::Installed' );
 144     isa_ok( $realei->{Perl}{packlist}, 'ExtUtils::Packlist' );
 145     is( $realei->{Perl}{version}, $Config{version},
 146         'new() should set Perl version from %Config' );
 147
 148     ok( exists $realei->{FakeMod},
 149         'new() should find modules with .packlists using PERL5LIB'
 150     );
 151     isa_ok( $realei->{FakeMod}{packlist}, 'ExtUtils::Packlist' );
 152     is( $realei->{FakeMod}{version}, '1.1.1',
 153         '... should find version in modules' );
 154 }
 155
 156 # Do the same thing as the last block, but with overrides for
 157 # %Config and @INC.
 158 {
 159     my $config_override = { %Config::Config };
 160     $config_override->{archlibexp} = cwd();
 161     $config_override->{sitearchexp} = $fake_mod_dir;
 162     $config_override->{version} = 'fake_test_version';
 163
 164     my @inc_override = (@INC, $fake_mod_dir);
 165
 166     my $realei = ExtUtils::Installed->new(
 167         'config_override' => $config_override,
 168         'inc_override' => \@inc_override,
 169     );
 170     isa_ok( $realei, 'ExtUtils::Installed' );
 171     isa_ok( $realei->{Perl}{packlist}, 'ExtUtils::Packlist' );
 172     is( $realei->{Perl}{version}, 'fake_test_version',
 173         'new(config_override => HASH) overrides %Config' );
 174
 175     ok( exists $realei->{FakeMod}, 'new() with overrides should find modules with .packlists');
 176     isa_ok( $realei->{FakeMod}{packlist}, 'ExtUtils::Packlist' );
 177     is( $realei->{FakeMod}{version}, '1.1.1',
 178         '... should find version in modules' );
 179 }
 180
 181 # Check if extra_libs works.
 182 {
 183     my $realei = ExtUtils::Installed->new(
 184         'extra_libs' => [ cwd() ],
 185     );
 186     isa_ok( $realei, 'ExtUtils::Installed' );
 187     isa_ok( $realei->{Perl}{packlist}, 'ExtUtils::Packlist' );
 188     ok( exists $realei->{FakeMod},
 189         'new() with extra_libs should find modules with .packlists');
 190
 191     #{ use Data::Dumper; local $realei->{':private:'}{Config};
 192     #  warn Dumper($realei); }
 193
 194     isa_ok( $realei->{FakeMod}{packlist}, 'ExtUtils::Packlist' );
 195     is( $realei->{FakeMod}{version}, '1.1.1',
 196         '... should find version in modules' );
 197 }
 198
 199 # modules
 200 $ei->{$_} = 1 for qw( abc def ghi );
 201 is( join(' ', $ei->modules()), 'abc def ghi',
 202     'modules() should return sorted keys' );
 203
 204 # This didn't work for a long time due to a sort in scalar context oddity.
 205 is( $ei->modules, 3,    'modules() in scalar context' );
 206
 207 # files
 208 $ei->{goodmod} = {
 209         packlist => {
 210                 ($Config{man1direxp} ?
 211                     (File::Spec->catdir($Config{man1direxp}, 'foo') => 1) :
 212                         ()),
 213                 ($Config{man3direxp} ?
 214                     (File::Spec->catdir($Config{man3direxp}, 'bar') => 1) :
 215                         ()),
 216                 File::Spec->catdir($prefix, 'foobar') => 1,
 217                 foobaz  => 1,
 218         },
 219 };
 220
 221 eval { $ei->files('badmod') };
 222 like( $@, qr/badmod is not installed/,'files() should croak given bad modname');
 223 eval { $ei->files('goodmod', 'badtype' ) };
 224 like( $@, qr/type must be/,'files() should croak given bad type' );
 225
 226 my @files;
 227 SKIP: {
 228     skip('no man directory man1dir on this system', 2)
 229       unless $Config{man1direxp};
 230     @files = $ei->files('goodmod', 'doc', $Config{man1direxp});
 231     is( scalar @files, 1, '... should find doc file under given dir' );
 232     is( (grep { /foo$/ } @files), 1, '... checking file name' );
 233 }
 234 SKIP: {
 235     skip('no man directories on this system', 1) unless $mandirs;
 236     @files = $ei->files('goodmod', 'doc');
 237     is( scalar @files, $mandirs, '... should find all doc files with no dir' );
 238 }
 239
 240 @files = $ei->files('goodmod', 'prog', 'fake', 'fake2');
 241 is( scalar @files, 0, '... should find no doc files given wrong dirs' );
 242 @files = $ei->files('goodmod', 'prog');
 243 is( scalar @files, 1, '... should find doc file in correct dir' );
 244 like( $files[0], qr/foobar[>\]]?$/, '... checking file name' );
 245 @files = $ei->files('goodmod');
 246 is( scalar @files, 2 + $mandirs, '... should find all files with no type specified' );
 247 my %dirnames = map { lc($_) => dirname($_) } @files;
 248
 249 # directories
 250 my @dirs = $ei->directories('goodmod', 'prog', 'fake');
 251 is( scalar @dirs, 0, 'directories() should return no dirs if no files found' );
 252
 253 SKIP: {
 254     skip('no man directories on this system', 1) unless $mandirs;
 255     @dirs = $ei->directories('goodmod', 'doc');
 256     is( scalar @dirs, $mandirs, '... should find all files files() would' );
 257 }
 258 @dirs = $ei->directories('goodmod');
 259 is( scalar @dirs, 2 + $mandirs, '... should find all files files() would, again' );
 260 @files = sort map { exists $dirnames{lc($_)} ? $dirnames{lc($_)} : '' } @files;
 261 is( join(' ', @files), join(' ', @dirs), '... should sort output' );
 262
 263 # directory_tree
 264 my $expectdirs =
 265        ($mandirs == 2) &&
 266        (dirname($Config{man1direxp}) eq dirname($Config{man3direxp}))
 267        ? 3 : 2;
 268
 269 SKIP: {
 270     skip('no man directories on this system', 1) unless $mandirs;
 271     @dirs = $ei->directory_tree('goodmod', 'doc', $Config{man1direxp} ?
 272        dirname($Config{man1direxp}) : dirname($Config{man3direxp}));
 273     is( scalar @dirs, $expectdirs,
 274         'directory_tree() should report intermediate dirs to those requested' );
 275 }
 276
 277 my $fakepak = Fakepak->new(102);
 278
 279 $ei->{yesmod} = {
 280         version         => 101,
 281         packlist        => $fakepak,
 282 };
 283
 284 # these should all croak
 285 foreach my $sub (qw( validate packlist version )) {
 286     eval { $ei->$sub('nomod') };
 287     like( $@, qr/nomod is not installed/,
 288           "$sub() should croak when asked about uninstalled module" );
 289 }
 290
 291 # validate
 292 is( $ei->validate('yesmod'), 'validated',
 293         'validate() should return results of packlist validate() call' );
 294
 295 # packlist
 296 is( ${ $ei->packlist('yesmod') }, 102,
 297         'packlist() should report installed mod packlist' );
 298
 299 # version
 300 is( $ei->version('yesmod'), 101,
 301         'version() should report installed mod version' );
 302
 303
 304 package Fakepak;
 305
 306 sub new {
 307     my $class = shift;
 308     bless(\(my $scalar = shift), $class);
 309 }
 310
 311 sub validate {
 312     return 'validated'
 313 }