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