From: Robin Barker Date: Wed, 13 Feb 2002 17:37:07 +0000 (+0000) Subject: Message-Id: <200202131737.RAA29010@tempest.npl.co.uk> X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=34dcf69d16f4f097bb98d9b67a630a44c9749a3d;p=p5sagit%2Fp5-mst-13.2.git Message-Id: <200202131737.RAA29010@tempest.npl.co.uk> (updated version of the above) p4raw-id: //depot/perl@14688 --- diff --git a/lib/ExtUtils/Installed.pm b/lib/ExtUtils/Installed.pm index c9a6bfc..5b7f663 100644 --- a/lib/ExtUtils/Installed.pm +++ b/lib/ExtUtils/Installed.pm @@ -32,26 +32,31 @@ if ($DOSISH) return(0); } +sub _is_doc($$) +{ +my ($self, $path) = @_; +my $man1dir = $Config{man1direxp}; +my $man3dir = $Config{man3direxp}; +return(($man1dir && $self->_is_prefix($path, $man1dir)) + || + ($man3dir && $self->_is_prefix($path, $man3dir)) + ? 1 : 0) +} + sub _is_type($$$) { my ($self, $path, $type) = @_; return(1) if ($type eq "all"); + if ($type eq "doc") { - return($self->_is_prefix($path, $Config{installman1dir}) - || - $self->_is_prefix($path, $Config{installman3dir}) - ? 1 : 0) + return($self->_is_doc($path)) } if ($type eq "prog") { - return($self->_is_prefix($path, $Config{prefix}) - && - !($Config{installman1dir} && - $self->_is_prefix($path, $Config{installman1dir})) + return($self->_is_prefix($path, $Config{prefixexp}) && - !($Config{installman3dir} && - $self->_is_prefix($path, $Config{installman3dir})) + !($self->_is_doc($path)) ? 1 : 0); } return(0); @@ -74,27 +79,25 @@ my ($class) = @_; $class = ref($class) || $class; my $self = {}; -my $installarchlib = $Config{installarchlib}; -my $archlib = $Config{archlib}; -my $sitearch = $Config{sitearch}; +my $archlib = $Config{archlibexp}; +my $sitearch = $Config{sitearchexp}; if ($DOSISH) { - $installarchlib =~ s|\\|/|g; $archlib =~ s|\\|/|g; $sitearch =~ s|\\|/|g; } # Read the core packlist $self->{Perl}{packlist} = - ExtUtils::Packlist->new( File::Spec->catfile($installarchlib, '.packlist') ); + ExtUtils::Packlist->new( File::Spec->catfile($archlib, '.packlist') ); $self->{Perl}{version} = $Config{version}; # Read the module packlists my $sub = sub { # Only process module .packlists - return if ($_) ne ".packlist" || $File::Find::dir eq $installarchlib; + return if ($_) ne ".packlist" || $File::Find::dir eq $archlib; # Hack of the leading bits of the paths & convert to a module name my $module = $File::Find::name; @@ -256,7 +259,7 @@ is given the special name 'Perl'. This takes one mandatory parameter, the name of a module. It returns a list of all the filenames from the package. To obtain a list of core perl files, use the module name 'Perl'. Additional parameters are allowed. The first is one -of the strings "prog", "man" or "all", to select either just program files, +of the strings "prog", "doc" or "all", to select either just program files, just manual files or all files. The remaining parameters are a list of directories. The filenames returned will be restricted to those under the specified directories. @@ -265,7 +268,7 @@ specified directories. This takes one mandatory parameter, the name of a module. It returns a list of all the directories from the package. Additional parameters are allowed. The -first is one of the strings "prog", "man" or "all", to select either just +first is one of the strings "prog", "doc" or "all", to select either just program directories, just manual directories or all directories. The remaining parameters are a list of directories. The directories returned will be restricted to those under the specified directories. This method returns only @@ -273,7 +276,7 @@ the leaf directories that contain files from the specified module. =item directory_tree() -This is identical in operation to directory(), except that it includes all the +This is identical in operation to directories(), except that it includes all the intermediate directories back up to the specified directories. =item validate() diff --git a/lib/ExtUtils/t/Installed.t b/lib/ExtUtils/t/Installed.t index 8bd7fe6..70287f8 100644 --- a/lib/ExtUtils/t/Installed.t +++ b/lib/ExtUtils/t/Installed.t @@ -26,7 +26,7 @@ use Test::More tests => 43; BEGIN { use_ok( 'ExtUtils::Installed' ) } -my $noman = ! ($Config{installman1dir} && $Config{installman3dir}); +my $mandirs = !!$Config{man1direxp} + !!$Config{man3direxp}; # saves having to qualify package name for class methods my $ei = bless( {}, 'ExtUtils::Installed' ); @@ -40,17 +40,22 @@ is( $ei->_is_prefix('\foo\bar', '\bar'), 0, # _is_type is( $ei->_is_type(0, 'all'), 1, '_is_type() should be true for type of "all"' ); -foreach my $path (qw( installman1dir installman3dir )) { - my $file = $Config{$path} . '/foo'; +foreach my $path (qw( man1dir man3dir )) { +SKIP: { + my $dir = $Config{$path.'exp'}; + skip("no man directory $path on this system", 2 ) unless $dir; + + my $file = $dir . '/foo'; is( $ei->_is_type($file, 'doc'), 1, "... should find doc file in $path" ); is( $ei->_is_type($file, 'prog'), 0, "... but not prog file in $path" ); + } } -is( $ei->_is_type($Config{prefix} . '/bar', 'prog'), 1, - "... should find prog file under $Config{prefix}" ); +is( $ei->_is_type($Config{prefixexp} . '/bar', 'prog'), 1, + "... should find prog file under $Config{prefixexp}" ); SKIP: { - skip('no man directories on this system', 1) if $noman; + skip('no man directories on this system', 1) unless $mandirs; is( $ei->_is_type('bar', 'doc'), 0, '... should not find doc file outside path' ); } @@ -103,15 +108,14 @@ FAKE SKIP: { - skip( "could not write packlist: $!", 3 ) unless $wrotelist; + skip("could not write packlist: $!", 3 ) unless $wrotelist; # avoid warning and death by localizing glob local *ExtUtils::Installed::Config; - my $fake_mod_dir = File::Spec->catdir(cwd(), 'auto', 'FakeMod'); + my $fake_mod_dir = File::Spec->catdir(cwd(), 'auto', 'FakeMod'); %ExtUtils::Installed::Config = ( - archlib => cwd(), - installarchlib => cwd(), - sitearch => $fake_mod_dir, + archlibexp => cwd(), + sitearchexp => $fake_mod_dir, ); # necessary to fool new() @@ -132,9 +136,13 @@ is( join(' ', $ei->modules()), 'abc def ghi', # files $ei->{goodmod} = { packlist => { - File::Spec->catdir($Config{installman1dir}, 'foo') => 1, - File::Spec->catdir($Config{installman3dir}, 'bar') => 1, - File::Spec->catdir($Config{prefix}, 'foobar') => 1, + ($Config{man1direxp} ? + (File::Spec->catdir($Config{man1direxp}, 'foo') => 1) : + ()), + ($Config{man3direxp} ? + (File::Spec->catdir($Config{man3direxp}, 'bar') => 1) : + ()), + File::Spec->catdir($Config{prefixexp}, 'foobar') => 1, foobaz => 1, }, }; @@ -146,13 +154,15 @@ like( $@, qr/type must be/,'files() should croak given bad type' ); my @files; SKIP: { - skip('no man directories on this system', 3) if $noman; - - @files = $ei->files('goodmod', 'doc', $Config{installman1dir}); - is( scalar @files, 1, '... should find doc file under given dir' ); - is( grep({ /foo$/ } @files), 1, '... checking file name' ); - @files = $ei->files('goodmod', 'doc'); - is( scalar @files, 2, '... should find all doc files with no dir' ); + skip('no man directory man1dir on this system', 2) unless $Config{man1direxp}; + @files = $ei->files('goodmod', 'doc', $Config{man1direxp}); + is( scalar @files, 1, '... should find doc file under given dir' ); + is( grep({ /foo$/ } @files), 1, '... checking file name' ); +} +SKIP: { + skip('no man directories on this system', 1) unless $mandirs; + @files = $ei->files('goodmod', 'doc'); + is( scalar @files, $mandirs, '... should find all doc files with no dir' ); } @files = $ei->files('goodmod', 'prog', 'fake', 'fake2'); @@ -161,7 +171,7 @@ is( scalar @files, 0, '... should find no doc files given wrong dirs' ); is( scalar @files, 1, '... should find doc file in correct dir' ); like( $files[0], qr/foobar$/, '... checking file name' ); @files = $ei->files('goodmod'); -is( scalar @files, 4, '... should find all files with no type specified' ); +is( scalar @files, 2 + $mandirs, '... should find all files with no type specified' ); my %dirnames = map { lc($_) => dirname($_) } @files; # directories @@ -169,24 +179,27 @@ my @dirs = $ei->directories('goodmod', 'prog', 'fake'); is( scalar @dirs, 0, 'directories() should return no dirs if no files found' ); SKIP: { - skip('no man directories on this system', 4) if $noman; - - @dirs = $ei->directories('goodmod', 'doc'); - is( scalar @dirs, 2, '... should find all files files() would' ); - @dirs = $ei->directories('goodmod'); - is( scalar @dirs, 4, '... should find all files files() would, again' ); - @files = sort map { exists $dirnames{lc($_)} ? $dirnames{lc($_)} : '' } - @files; - is( join(' ', @files), join(' ', @dirs), '... should sort output' ); - - # directory_tree - my $expectdirs = dirname($Config{installman1dir}) eq - dirname($Config{installman3dir}) ? 3 :2; - - @dirs = $ei->directory_tree('goodmod', 'doc', - dirname($Config{installman1dir})); - is( scalar @dirs, $expectdirs, - 'directory_tree() should report intermediate dirs to those requested' ); + skip('no man directories on this system', 1) unless $mandirs; + @dirs = $ei->directories('goodmod', 'doc'); + is( scalar @dirs, $mandirs, '... should find all files files() would' ); +} +@dirs = $ei->directories('goodmod'); +is( scalar @dirs, 2 + $mandirs, '... should find all files files() would, again' ); +@files = sort map { exists $dirnames{lc($_)} ? $dirnames{lc($_)} : '' } @files; +is( join(' ', @files), join(' ', @dirs), '... should sort output' ); + +# directory_tree +my $expectdirs = + ($mandirs == 2) && + (dirname($Config{man1direxp}) eq dirname($Config{man3direxp})) + ? 3 : 2; + +SKIP: { + skip('no man directories on this system', 1) unless $mandirs; + @dirs = $ei->directory_tree('goodmod', 'doc', $Config{man1direxp} ? + dirname($Config{man1direxp}) : dirname($Config{man3direxp})); + is( scalar @dirs, $expectdirs, + 'directory_tree() should report intermediate dirs to those requested' ); } my $fakepak = Fakepak->new(102);