package ExtUtils::Installed;
-use 5.005_64;
+use 5.00503;
use strict;
use Carp qw();
use ExtUtils::Packlist;
use Config;
use File::Find;
use File::Basename;
-our $VERSION = '0.02';
-
-sub _is_type($$$)
-{
-my ($self, $path, $type) = @_;
-return(1) if ($type eq "all");
-if ($type eq "doc")
- {
- return(substr($path, 0, length($Config{installman1dir}))
- eq $Config{installman1dir}
- ||
- substr($path, 0, length($Config{installman3dir}))
- eq $Config{installman3dir}
- ? 1 : 0)
- }
-if ($type eq "prog")
- {
- return(substr($path, 0, length($Config{prefix})) eq $Config{prefix}
- &&
- substr($path, 0, length($Config{installman1dir}))
- ne $Config{installman1dir}
- &&
- substr($path, 0, length($Config{installman3dir}))
- ne $Config{installman3dir}
- ? 1 : 0);
- }
-return(0);
+use File::Spec;
+
+my $Is_VMS = $^O eq 'VMS';
+my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/);
+
+require VMS::Filespec if $Is_VMS;
+
+use vars qw($VERSION);
+$VERSION = '1.43';
+$VERSION = eval $VERSION;
+
+sub _is_prefix {
+ my ($self, $path, $prefix) = @_;
+ return unless defined $prefix && defined $path;
+
+ if( $Is_VMS ) {
+ $prefix = VMS::Filespec::unixify($prefix);
+ $path = VMS::Filespec::unixify($path);
+ }
+
+ # Sloppy Unix path normalization.
+ $prefix =~ s{/+}{/}g;
+ $path =~ s{/+}{/}g;
+
+ return 1 if substr($path, 0, length($prefix)) eq $prefix;
+
+ if ($DOSISH) {
+ $path =~ s|\\|/|g;
+ $prefix =~ s|\\|/|g;
+ return 1 if $path =~ m{^\Q$prefix\E}i;
+ }
+ return(0);
}
-sub _is_under($$;)
-{
-my ($self, $path, @under) = @_;
-$under[0] = "" if (! @under);
-foreach my $dir (@under)
- {
- return(1) if (substr($path, 0, length($dir)) eq $dir);
- }
-return(0);
+sub _is_doc {
+ my ($self, $path) = @_;
+
+ my $man1dir = $self->{':private:'}{Config}{man1direxp};
+ my $man3dir = $self->{':private:'}{Config}{man3direxp};
+ return(($man1dir && $self->_is_prefix($path, $man1dir))
+ ||
+ ($man3dir && $self->_is_prefix($path, $man3dir))
+ ? 1 : 0)
}
-sub new($)
-{
-my ($class) = @_;
-$class = ref($class) || $class;
-my $self = {};
-
-# Read the core packlist
-$self->{Perl}{packlist} =
- ExtUtils::Packlist->new("$Config{installarchlib}/.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 $Config{installarchlib};
-
- # Hack of the leading bits of the paths & convert to a module name
- my $module = $File::Find::name;
- $module =~ s!$Config{archlib}/auto/(.*)/.packlist!$1!s;
- $module =~ s!$Config{sitearch}/auto/(.*)/.packlist!$1!s;
- my $modfile = "$module.pm";
- $module =~ s!/!::!g;
-
- # Find the top-level module file in @INC
- $self->{$module}{version} = '';
- foreach my $dir (@INC)
- {
- my $p = MM->catfile($dir, $modfile);
- if (-f $p)
- {
- $self->{$module}{version} = MM->parse_version($p);
- last;
- }
- }
-
- # Read the .packlist
- $self->{$module}{packlist} = ExtUtils::Packlist->new($File::Find::name);
- };
-find($sub, $Config{archlib}, $Config{sitearch});
-
-return(bless($self, $class));
+sub _is_type {
+ my ($self, $path, $type) = @_;
+ return 1 if $type eq "all";
+
+ return($self->_is_doc($path)) if $type eq "doc";
+
+ if ($type eq "prog") {
+ return($self->_is_prefix($path, $self->{':private:'}{Config}{prefix} || $self->{':private:'}{Config}{prefixexp})
+ &&
+ !($self->_is_doc($path))
+ ? 1 : 0);
+ }
+ return(0);
}
-sub modules($)
-{
-my ($self) = @_;
-return(sort(keys(%$self)));
+sub _is_under {
+ my ($self, $path, @under) = @_;
+ $under[0] = "" if (! @under);
+ foreach my $dir (@under) {
+ return(1) if ($self->_is_prefix($path, $dir));
+ }
+
+ return(0);
}
-sub files($$;$)
-{
-my ($self, $module, $type, @under) = @_;
-
-# Validate arguments
-Carp::croak("$module is not installed") if (! exists($self->{$module}));
-$type = "all" if (! defined($type));
-Carp::croak('type must be "all", "prog" or "doc"')
- if ($type ne "all" && $type ne "prog" && $type ne "doc");
-
-my (@files);
-foreach my $file (keys(%{$self->{$module}{packlist}}))
- {
- push(@files, $file)
- if ($self->_is_type($file, $type) && $self->_is_under($file, @under));
- }
-return(@files);
+sub new {
+ my ($class) = shift(@_);
+ $class = ref($class) || $class;
+
+ my %args = @_;
+
+ my $self = {};
+
+ if ($args{config_override}) {
+ eval {
+ $self->{':private:'}{Config} = { %{$args{config_override}} };
+ } or Carp::croak(
+ "The 'config_override' parameter must be a hash reference."
+ );
+ }
+ else {
+ $self->{':private:'}{Config} = \%Config;
+ }
+
+ for my $tuple ([inc_override => INC => [ @INC ] ],
+ [ extra_libs => EXTRA => [] ])
+ {
+ my ($arg,$key,$val)=@$tuple;
+ if ( $args{$arg} ) {
+ eval {
+ $self->{':private:'}{$key} = [ @{$args{$arg}} ];
+ } or Carp::croak(
+ "The '$arg' parameter must be an array reference."
+ );
+ }
+ elsif ($val) {
+ $self->{':private:'}{$key} = $val;
+ }
+ }
+ {
+ my %dupe;
+ @{$self->{':private:'}{INC}} = grep { -e $_ && !$dupe{$_}++ }
+ @{$self->{':private:'}{INC}}, @{$self->{':private:'}{EXTRA}};
+ }
+ my $perl5lib = defined $ENV{PERL5LIB} ? $ENV{PERL5LIB} : "";
+
+ my @dirs = ( $self->{':private:'}{Config}{archlibexp},
+ $self->{':private:'}{Config}{sitearchexp},
+ split(/\Q$Config{path_sep}\E/, $perl5lib),
+ @{$self->{':private:'}{EXTRA}},
+ );
+
+ # File::Find does not know how to deal with VMS filepaths.
+ if( $Is_VMS ) {
+ $_ = VMS::Filespec::unixify($_)
+ for @dirs;
+ }
+
+ if ($DOSISH) {
+ s|\\|/|g for @dirs;
+ }
+ my $archlib = $dirs[0];
+
+ # Read the core packlist
+ $self->{Perl}{packlist} =
+ ExtUtils::Packlist->new( File::Spec->catfile($archlib, '.packlist') );
+ $self->{Perl}{version} = $self->{':private:'}{Config}{version};
+
+ # Read the module packlists
+ my $sub = sub {
+ # Only process module .packlists
+ 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;
+ my $found;
+ for (@dirs) {
+ $found = $module =~ s!\Q$_\E/?auto/(.*)/.packlist!$1!s
+ and last;
+ }
+ unless ($found) {
+ # warn "Woah! \$_=$_\n\$module=$module\n\$File::Find::dir=$File::Find::dir\n",
+ # join ("\n",@dirs);
+ return;
+ }
+ my $modfile = "$module.pm";
+ $module =~ s!/!::!g;
+
+ # Find the top-level module file in @INC
+ $self->{$module}{version} = '';
+ foreach my $dir (@{$self->{':private:'}{INC}}) {
+ my $p = File::Spec->catfile($dir, $modfile);
+ if (-r $p) {
+ $module = _module_name($p, $module) if $Is_VMS;
+
+ $self->{$module}{version} = MM->parse_version($p);
+ last;
+ }
+ }
+
+ # Read the .packlist
+ $self->{$module}{packlist} =
+ ExtUtils::Packlist->new($File::Find::name);
+ };
+ my %dupe;
+ @dirs= grep { -e $_ && !$dupe{$_}++ } @dirs;
+ $self->{':private:'}{LIBDIRS} = \@dirs;
+ find($sub, @dirs) if @dirs;
+
+ return(bless($self, $class));
}
-sub directories($$;$)
-{
-my ($self, $module, $type, @under) = @_;
-my (%dirs);
-foreach my $file ($self->files($module, $type, @under))
- {
- $dirs{dirname($file)}++;
- }
-return(sort(keys(%dirs)));
+# VMS's non-case preserving file-system means the package name can't
+# be reconstructed from the filename.
+sub _module_name {
+ my($file, $orig_module) = @_;
+
+ my $module = '';
+ if (open PACKFH, $file) {
+ while (<PACKFH>) {
+ if (/package\s+(\S+)\s*;/) {
+ my $pack = $1;
+ # Make a sanity check, that lower case $module
+ # is identical to lowercase $pack before
+ # accepting it
+ if (lc($pack) eq lc($orig_module)) {
+ $module = $pack;
+ last;
+ }
+ }
+ }
+ close PACKFH;
+ }
+
+ print STDERR "Couldn't figure out the package name for $file\n"
+ unless $module;
+
+ return $module;
}
-sub directory_tree($$;$)
-{
-my ($self, $module, $type, @under) = @_;
-my (%dirs);
-foreach my $dir ($self->directories($module, $type, @under))
- {
- $dirs{$dir}++;
- my ($last) = ("");
- while ($last ne $dir)
- {
- $last = $dir;
- $dir = dirname($dir);
- last if (! $self->_is_under($dir, @under));
- $dirs{$dir}++;
- }
- }
-return(sort(keys(%dirs)));
+
+
+sub modules {
+ my ($self) = @_;
+
+ # Bug/feature of sort in scalar context requires this.
+ return wantarray
+ ? sort grep { not /^:private:$/ } keys %$self
+ : grep { not /^:private:$/ } keys %$self;
+}
+
+sub files {
+ my ($self, $module, $type, @under) = @_;
+
+ # Validate arguments
+ Carp::croak("$module is not installed") if (! exists($self->{$module}));
+ $type = "all" if (! defined($type));
+ Carp::croak('type must be "all", "prog" or "doc"')
+ if ($type ne "all" && $type ne "prog" && $type ne "doc");
+
+ my (@files);
+ foreach my $file (keys(%{$self->{$module}{packlist}})) {
+ push(@files, $file)
+ if ($self->_is_type($file, $type) &&
+ $self->_is_under($file, @under));
+ }
+ return(@files);
}
-sub validate($;$)
-{
-my ($self, $module, $remove) = @_;
-Carp::croak("$module is not installed") if (! exists($self->{$module}));
-return($self->{$module}{packlist}->validate($remove));
+sub directories {
+ my ($self, $module, $type, @under) = @_;
+ my (%dirs);
+ foreach my $file ($self->files($module, $type, @under)) {
+ $dirs{dirname($file)}++;
+ }
+ return sort keys %dirs;
}
-sub packlist($$)
-{
-my ($self, $module) = @_;
-Carp::croak("$module is not installed") if (! exists($self->{$module}));
-return($self->{$module}{packlist});
+sub directory_tree {
+ my ($self, $module, $type, @under) = @_;
+ my (%dirs);
+ foreach my $dir ($self->directories($module, $type, @under)) {
+ $dirs{$dir}++;
+ my ($last) = ("");
+ while ($last ne $dir) {
+ $last = $dir;
+ $dir = dirname($dir);
+ last if !$self->_is_under($dir, @under);
+ $dirs{$dir}++;
+ }
+ }
+ return(sort(keys(%dirs)));
}
-sub version($$)
-{
-my ($self, $module) = @_;
-Carp::croak("$module is not installed") if (! exists($self->{$module}));
-return($self->{$module}{version});
+sub validate {
+ my ($self, $module, $remove) = @_;
+ Carp::croak("$module is not installed") if (! exists($self->{$module}));
+ return($self->{$module}{packlist}->validate($remove));
}
-sub DESTROY
-{
+sub packlist {
+ my ($self, $module) = @_;
+ Carp::croak("$module is not installed") if (! exists($self->{$module}));
+ return($self->{$module}{packlist});
}
+sub version {
+ my ($self, $module) = @_;
+ Carp::croak("$module is not installed") if (! exists($self->{$module}));
+ return($self->{$module}{version});
+}
+
+
1;
__END__
The new() function searches for all the installed .packlists on the system, and
stores their contents. The .packlists can be queried with the functions
-described below.
+described below. Where it searches by default is determined by the settings found
+in C<%Config::Config>, and what the value is of the PERL5LIB environment variable.
=head1 FUNCTIONS
=item new()
-This takes no parameters, and searches for all the installed .packlists on the
-system. The packlists are read using the ExtUtils::packlist module.
+This takes optional named parameters. Without parameters, this
+searches for all the installed .packlists on the system using
+information from C<%Config::Config> and the default module search
+paths C<@INC>. The packlists are read using the
+L<ExtUtils::Packlist> module.
+
+If the named parameter C<config_override> is specified,
+it should be a reference to a hash which contains all information
+usually found in C<%Config::Config>. For example, you can obtain
+the configuration information for a separate perl installation and
+pass that in.
+
+ my $yoda_cfg = get_fake_config('yoda');
+ my $yoda_inst = ExtUtils::Installed->new(config_override=>$yoda_cfg);
+
+Similarly, the parameter C<inc_override> may be a reference to an
+array which is used in place of the default module search paths
+from C<@INC>.
+
+ use Config;
+ my @dirs = split(/\Q$Config{path_sep}\E/, $ENV{PERL5LIB});
+ my $p5libs = ExtUtils::Installed->new(inc_override=>\@dirs);
+
+The parameter c<extra_libs> can be used to specify B<additional> paths to
+search for installed modules. For instance
+
+ my $installed = ExtUtils::Installed->new(extra_libs=>["/my/lib/path"]);
+
+This should only be necessary if C</my/lib/path> is not in PERL5LIB.
=item modules()
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.
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
=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()
projects / p5sagit/p5-mst-13.2.git / blobdiff