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