lib/ExtUtils/Installed.pm

   1 package ExtUtils::Installed;
   2
   3 use 5.00503;
   4 use strict;
   5 use Carp qw();
   6 use ExtUtils::Packlist;
   7 use ExtUtils::MakeMaker;
   8 use Config;
   9 use File::Find;
  10 use File::Basename;
  11 use File::Spec;
  12 require VMS::Filespec if $^O eq 'VMS';
  13
  14 use vars qw($VERSION);
  15 $VERSION = '0.06';
  16
  17 my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/);
  18
  19 sub _is_prefix {
  20     my ($self, $path, $prefix) = @_;
  21     return unless defined $prefix && defined $path;
  22
  23     if( $^O eq 'VMS' ) {
  24         $prefix = VMS::Filespec::unixify($prefix);
  25         $path   = VMS::Filespec::unixify($path);
  26     }
  27     return 1 if substr($path, 0, length($prefix)) eq $prefix;
  28
  29     if ($DOSISH) {
  30         $path =~ s|\\|/|g;
  31         $prefix =~ s|\\|/|g;
  32         return 1 if $path =~ m{^\Q$prefix\E}i;
  33     }
  34     return(0);
  35 }
  36
  37 sub _is_doc {
  38     my ($self, $path) = @_;
  39     my $man1dir = $Config{man1direxp};
  40     my $man3dir = $Config{man3direxp};
  41     return(($man1dir && $self->_is_prefix($path, $man1dir))
  42            ||
  43            ($man3dir && $self->_is_prefix($path, $man3dir))
  44            ? 1 : 0)
  45 }
  46
  47 sub _is_type {
  48     my ($self, $path, $type) = @_;
  49     return 1 if $type eq "all";
  50
  51     return($self->_is_doc($path)) if $type eq "doc";
  52
  53     if ($type eq "prog") {
  54         return($self->_is_prefix($path, $Config{prefix} || $Config{prefixexp})
  55                &&
  56                !($self->_is_doc($path))
  57                ? 1 : 0);
  58     }
  59     return(0);
  60 }
  61
  62 sub _is_under {
  63     my ($self, $path, @under) = @_;
  64     $under[0] = "" if (! @under);
  65     foreach my $dir (@under) {
  66         return(1) if ($self->_is_prefix($path, $dir));
  67     }
  68
  69     return(0);
  70 }
  71
  72 sub new {
  73     my ($class) = @_;
  74     $class = ref($class) || $class;
  75     my $self = {};
  76
  77     my $archlib = $Config{archlibexp};
  78     my $sitearch = $Config{sitearchexp};
  79
  80     # File::Find does not know how to deal with VMS filepaths.
  81     if( $^O eq 'VMS' ) {
  82         $archlib  = VMS::Filespec::unixify($archlib);
  83         $sitearch = VMS::Filespec::unixify($sitearch);
  84     }
  85
  86     if ($DOSISH) {
  87         $archlib =~ s|\\|/|g;
  88         $sitearch =~ s|\\|/|g;
  89     }
  90
  91     # Read the core packlist
  92     $self->{Perl}{packlist} =
  93       ExtUtils::Packlist->new( File::Spec->catfile($archlib, '.packlist') );
  94     $self->{Perl}{version} = $Config{version};
  95
  96     # Read the module packlists
  97     my $sub = sub {
  98         # Only process module .packlists
  99         return if ($_) ne ".packlist" || $File::Find::dir eq $archlib;
 100
 101         # Hack of the leading bits of the paths & convert to a module name
 102         my $module = $File::Find::name;
 103
 104         $module =~ s!\Q$archlib\E/?auto/(.*)/.packlist!$1!s  or
 105         $module =~ s!\Q$sitearch\E/?auto/(.*)/.packlist!$1!s;
 106         my $modfile = "$module.pm";
 107         $module =~ s!/!::!g;
 108
 109         # Find the top-level module file in @INC
 110         $self->{$module}{version} = '';
 111         foreach my $dir (@INC) {
 112             my $p = File::Spec->catfile($dir, $modfile);
 113             if (-f $p) {
 114                 require ExtUtils::MM;
 115                 $self->{$module}{version} = MM->parse_version($p);
 116                 last;
 117             }
 118         }
 119
 120         # Read the .packlist
 121         $self->{$module}{packlist} =
 122           ExtUtils::Packlist->new($File::Find::name);
 123     };
 124
 125     my(@dirs) = grep { -e } ($archlib, $sitearch);
 126     find($sub, @dirs) if @dirs;
 127
 128     return(bless($self, $class));
 129 }
 130
 131 sub modules {
 132     my ($self) = @_;
 133
 134     # Bug/feature of sort in scalar context requires this.
 135     return wantarray ? sort keys %$self : keys %$self;
 136 }
 137
 138 sub files {
 139     my ($self, $module, $type, @under) = @_;
 140
 141     # Validate arguments
 142     Carp::croak("$module is not installed") if (! exists($self->{$module}));
 143     $type = "all" if (! defined($type));
 144     Carp::croak('type must be "all", "prog" or "doc"')
 145         if ($type ne "all" && $type ne "prog" && $type ne "doc");
 146
 147     my (@files);
 148     foreach my $file (keys(%{$self->{$module}{packlist}})) {
 149         push(@files, $file)
 150           if ($self->_is_type($file, $type) &&
 151               $self->_is_under($file, @under));
 152     }
 153     return(@files);
 154 }
 155
 156 sub directories {
 157     my ($self, $module, $type, @under) = @_;
 158     my (%dirs);
 159     foreach my $file ($self->files($module, $type, @under)) {
 160         $dirs{dirname($file)}++;
 161     }
 162     return sort keys %dirs;
 163 }
 164
 165 sub directory_tree {
 166     my ($self, $module, $type, @under) = @_;
 167     my (%dirs);
 168     foreach my $dir ($self->directories($module, $type, @under)) {
 169         $dirs{$dir}++;
 170         my ($last) = ("");
 171         while ($last ne $dir) {
 172             $last = $dir;
 173             $dir = dirname($dir);
 174             last if !$self->_is_under($dir, @under);
 175             $dirs{$dir}++;
 176         }
 177     }
 178     return(sort(keys(%dirs)));
 179 }
 180
 181 sub validate {
 182     my ($self, $module, $remove) = @_;
 183     Carp::croak("$module is not installed") if (! exists($self->{$module}));
 184     return($self->{$module}{packlist}->validate($remove));
 185 }
 186
 187 sub packlist {
 188     my ($self, $module) = @_;
 189     Carp::croak("$module is not installed") if (! exists($self->{$module}));
 190     return($self->{$module}{packlist});
 191 }
 192
 193 sub version {
 194     my ($self, $module) = @_;
 195     Carp::croak("$module is not installed") if (! exists($self->{$module}));
 196     return($self->{$module}{version});
 197 }
 198
 199
 200 1;
 201
 202 __END__
 203
 204 =head1 NAME
 205
 206 ExtUtils::Installed - Inventory management of installed modules
 207
 208 =head1 SYNOPSIS
 209
 210    use ExtUtils::Installed;
 211    my ($inst) = ExtUtils::Installed->new();
 212    my (@modules) = $inst->modules();
 213    my (@missing) = $inst->validate("DBI");
 214    my $all_files = $inst->files("DBI");
 215    my $files_below_usr_local = $inst->files("DBI", "all", "/usr/local");
 216    my $all_dirs = $inst->directories("DBI");
 217    my $dirs_below_usr_local = $inst->directory_tree("DBI", "prog");
 218    my $packlist = $inst->packlist("DBI");
 219
 220 =head1 DESCRIPTION
 221
 222 ExtUtils::Installed  provides a standard way to find out what core and module
 223 files have been installed.  It uses the information stored in .packlist files
 224 created during installation to provide this information.  In addition it
 225 provides facilities to classify the installed files and to extract directory
 226 information from the .packlist files.
 227
 228 =head1 USAGE
 229
 230 The new() function searches for all the installed .packlists on the system, and
 231 stores their contents. The .packlists can be queried with the functions
 232 described below.
 233
 234 =head1 FUNCTIONS
 235
 236 =over 4
 237
 238 =item new()
 239
 240 This takes no parameters, and searches for all the installed .packlists on the
 241 system.  The packlists are read using the ExtUtils::packlist module.
 242
 243 =item modules()
 244
 245 This returns a list of the names of all the installed modules.  The perl 'core'
 246 is given the special name 'Perl'.
 247
 248 =item files()
 249
 250 This takes one mandatory parameter, the name of a module.  It returns a list of
 251 all the filenames from the package.  To obtain a list of core perl files, use
 252 the module name 'Perl'.  Additional parameters are allowed.  The first is one
 253 of the strings "prog", "doc" or "all", to select either just program files,
 254 just manual files or all files.  The remaining parameters are a list of
 255 directories. The filenames returned will be restricted to those under the
 256 specified directories.
 257
 258 =item directories()
 259
 260 This takes one mandatory parameter, the name of a module.  It returns a list of
 261 all the directories from the package.  Additional parameters are allowed.  The
 262 first is one of the strings "prog", "doc" or "all", to select either just
 263 program directories, just manual directories or all directories.  The remaining
 264 parameters are a list of directories. The directories returned will be
 265 restricted to those under the specified directories.  This method returns only
 266 the leaf directories that contain files from the specified module.
 267
 268 =item directory_tree()
 269
 270 This is identical in operation to directories(), except that it includes all the
 271 intermediate directories back up to the specified directories.
 272
 273 =item validate()
 274
 275 This takes one mandatory parameter, the name of a module.  It checks that all
 276 the files listed in the modules .packlist actually exist, and returns a list of
 277 any missing files.  If an optional second argument which evaluates to true is
 278 given any missing files will be removed from the .packlist
 279
 280 =item packlist()
 281
 282 This returns the ExtUtils::Packlist object for the specified module.
 283
 284 =item version()
 285
 286 This returns the version number for the specified module.
 287
 288 =back
 289
 290 =head1 EXAMPLE
 291
 292 See the example in L<ExtUtils::Packlist>.
 293
 294 =head1 AUTHOR
 295
 296 Alan Burlison <Alan.Burlison@uk.sun.com>
 297
 298 =cut