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