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.05';
  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     return sort keys %$self;
 134 }
 135
 136 sub files {
 137     my ($self, $module, $type, @under) = @_;
 138
 139     # Validate arguments
 140     Carp::croak("$module is not installed") if (! exists($self->{$module}));
 141     $type = "all" if (! defined($type));
 142     Carp::croak('type must be "all", "prog" or "doc"')
 143         if ($type ne "all" && $type ne "prog" && $type ne "doc");
 144
 145     my (@files);
 146     foreach my $file (keys(%{$self->{$module}{packlist}})) {
 147         push(@files, $file)
 148           if ($self->_is_type($file, $type) &&
 149               $self->_is_under($file, @under));
 150     }
 151     return(@files);
 152 }
 153
 154 sub directories {
 155     my ($self, $module, $type, @under) = @_;
 156     my (%dirs);
 157     foreach my $file ($self->files($module, $type, @under)) {
 158         $dirs{dirname($file)}++;
 159     }
 160     return sort keys %dirs;
 161 }
 162
 163 sub directory_tree {
 164     my ($self, $module, $type, @under) = @_;
 165     my (%dirs);
 166     foreach my $dir ($self->directories($module, $type, @under)) {
 167         $dirs{$dir}++;
 168         my ($last) = ("");
 169         while ($last ne $dir) {
 170             $last = $dir;
 171             $dir = dirname($dir);
 172             last if !$self->_is_under($dir, @under);
 173             $dirs{$dir}++;
 174         }
 175     }
 176     return(sort(keys(%dirs)));
 177 }
 178
 179 sub validate {
 180     my ($self, $module, $remove) = @_;
 181     Carp::croak("$module is not installed") if (! exists($self->{$module}));
 182     return($self->{$module}{packlist}->validate($remove));
 183 }
 184
 185 sub packlist {
 186     my ($self, $module) = @_;
 187     Carp::croak("$module is not installed") if (! exists($self->{$module}));
 188     return($self->{$module}{packlist});
 189 }
 190
 191 sub version {
 192     my ($self, $module) = @_;
 193     Carp::croak("$module is not installed") if (! exists($self->{$module}));
 194     return($self->{$module}{version});
 195 }
 196
 197
 198 1;
 199
 200 __END__
 201
 202 =head1 NAME
 203
 204 ExtUtils::Installed - Inventory management of installed modules
 205
 206 =head1 SYNOPSIS
 207
 208    use ExtUtils::Installed;
 209    my ($inst) = ExtUtils::Installed->new();
 210    my (@modules) = $inst->modules();
 211    my (@missing) = $inst->validate("DBI");
 212    my $all_files = $inst->files("DBI");
 213    my $files_below_usr_local = $inst->files("DBI", "all", "/usr/local");
 214    my $all_dirs = $inst->directories("DBI");
 215    my $dirs_below_usr_local = $inst->directory_tree("DBI", "prog");
 216    my $packlist = $inst->packlist("DBI");
 217
 218 =head1 DESCRIPTION
 219
 220 ExtUtils::Installed  provides a standard way to find out what core and module
 221 files have been installed.  It uses the information stored in .packlist files
 222 created during installation to provide this information.  In addition it
 223 provides facilities to classify the installed files and to extract directory
 224 information from the .packlist files.
 225
 226 =head1 USAGE
 227
 228 The new() function searches for all the installed .packlists on the system, and
 229 stores their contents. The .packlists can be queried with the functions
 230 described below.
 231
 232 =head1 FUNCTIONS
 233
 234 =over 4
 235
 236 =item new()
 237
 238 This takes no parameters, and searches for all the installed .packlists on the
 239 system.  The packlists are read using the ExtUtils::packlist module.
 240
 241 =item modules()
 242
 243 This returns a list of the names of all the installed modules.  The perl 'core'
 244 is given the special name 'Perl'.
 245
 246 =item files()
 247
 248 This takes one mandatory parameter, the name of a module.  It returns a list of
 249 all the filenames from the package.  To obtain a list of core perl files, use
 250 the module name 'Perl'.  Additional parameters are allowed.  The first is one
 251 of the strings "prog", "doc" or "all", to select either just program files,
 252 just manual files or all files.  The remaining parameters are a list of
 253 directories. The filenames returned will be restricted to those under the
 254 specified directories.
 255
 256 =item directories()
 257
 258 This takes one mandatory parameter, the name of a module.  It returns a list of
 259 all the directories from the package.  Additional parameters are allowed.  The
 260 first is one of the strings "prog", "doc" or "all", to select either just
 261 program directories, just manual directories or all directories.  The remaining
 262 parameters are a list of directories. The directories returned will be
 263 restricted to those under the specified directories.  This method returns only
 264 the leaf directories that contain files from the specified module.
 265
 266 =item directory_tree()
 267
 268 This is identical in operation to directories(), except that it includes all the
 269 intermediate directories back up to the specified directories.
 270
 271 =item validate()
 272
 273 This takes one mandatory parameter, the name of a module.  It checks that all
 274 the files listed in the modules .packlist actually exist, and returns a list of
 275 any missing files.  If an optional second argument which evaluates to true is
 276 given any missing files will be removed from the .packlist
 277
 278 =item packlist()
 279
 280 This returns the ExtUtils::Packlist object for the specified module.
 281
 282 =item version()
 283
 284 This returns the version number for the specified module.
 285
 286 =back
 287
 288 =head1 EXAMPLE
 289
 290 See the example in L<ExtUtils::Packlist>.
 291
 292 =head1 AUTHOR
 293
 294 Alan Burlison <Alan.Burlison@uk.sun.com>
 295
 296 =cut