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.43';
  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
  48     my $man1dir = $self->{':private:'}{Config}{man1direxp};
  49     my $man3dir = $self->{':private:'}{Config}{man3direxp};
  50     return(($man1dir && $self->_is_prefix($path, $man1dir))
  51            ||
  52            ($man3dir && $self->_is_prefix($path, $man3dir))
  53            ? 1 : 0)
  54 }
  55
  56 sub _is_type {
  57     my ($self, $path, $type) = @_;
  58     return 1 if $type eq "all";
  59
  60     return($self->_is_doc($path)) if $type eq "doc";
  61
  62     if ($type eq "prog") {
  63         return($self->_is_prefix($path, $self->{':private:'}{Config}{prefix} || $self->{':private:'}{Config}{prefixexp})
  64                &&
  65                !($self->_is_doc($path))
  66                ? 1 : 0);
  67     }
  68     return(0);
  69 }
  70
  71 sub _is_under {
  72     my ($self, $path, @under) = @_;
  73     $under[0] = "" if (! @under);
  74     foreach my $dir (@under) {
  75         return(1) if ($self->_is_prefix($path, $dir));
  76     }
  77
  78     return(0);
  79 }
  80
  81 sub new {
  82     my ($class) = shift(@_);
  83     $class = ref($class) || $class;
  84
  85     my %args = @_;
  86
  87     my $self = {};
  88
  89     if ($args{config_override}) {
  90         eval {
  91             $self->{':private:'}{Config} = { %{$args{config_override}} };
  92         } or Carp::croak(
  93             "The 'config_override' parameter must be a hash reference."
  94         );
  95     }
  96     else {
  97         $self->{':private:'}{Config} = \%Config;
  98     }
  99
 100     for my $tuple ([inc_override => INC => [ @INC ] ],
 101                    [ extra_libs => EXTRA => [] ])
 102     {
 103         my ($arg,$key,$val)=@$tuple;
 104         if ( $args{$arg} ) {
 105             eval {
 106                 $self->{':private:'}{$key} = [ @{$args{$arg}} ];
 107             } or Carp::croak(
 108                 "The '$arg' parameter must be an array reference."
 109             );
 110         }
 111         elsif ($val) {
 112             $self->{':private:'}{$key} = $val;
 113         }
 114     }
 115     {
 116         my %dupe;
 117         @{$self->{':private:'}{INC}} = grep { -e $_ && !$dupe{$_}++ }
 118             @{$self->{':private:'}{INC}}, @{$self->{':private:'}{EXTRA}};
 119     }
 120     my $perl5lib = defined $ENV{PERL5LIB} ? $ENV{PERL5LIB} : "";
 121
 122     my @dirs = ( $self->{':private:'}{Config}{archlibexp},
 123                  $self->{':private:'}{Config}{sitearchexp},
 124                  split(/\Q$Config{path_sep}\E/, $perl5lib),
 125                  @{$self->{':private:'}{EXTRA}},
 126                );
 127
 128     # File::Find does not know how to deal with VMS filepaths.
 129     if( $Is_VMS ) {
 130         $_ = VMS::Filespec::unixify($_)
 131             for @dirs;
 132     }
 133
 134     if ($DOSISH) {
 135         s|\\|/|g for @dirs;
 136     }
 137     my $archlib = $dirs[0];
 138
 139     # Read the core packlist
 140     $self->{Perl}{packlist} =
 141       ExtUtils::Packlist->new( File::Spec->catfile($archlib, '.packlist') );
 142     $self->{Perl}{version} = $self->{':private:'}{Config}{version};
 143
 144     # Read the module packlists
 145     my $sub = sub {
 146         # Only process module .packlists
 147         return if $_ ne ".packlist" || $File::Find::dir eq $archlib;
 148
 149         # Hack of the leading bits of the paths & convert to a module name
 150         my $module = $File::Find::name;
 151         my $found;
 152         for (@dirs) {
 153             $found = $module =~ s!\Q$_\E/?auto/(.*)/.packlist!$1!s
 154                 and last;
 155         }
 156         unless ($found) {
 157             # warn "Woah! \$_=$_\n\$module=$module\n\$File::Find::dir=$File::Find::dir\n",
 158             #    join ("\n",@dirs);
 159             return;
 160         }
 161         my $modfile = "$module.pm";
 162         $module =~ s!/!::!g;
 163
 164         # Find the top-level module file in @INC
 165         $self->{$module}{version} = '';
 166         foreach my $dir (@{$self->{':private:'}{INC}}) {
 167             my $p = File::Spec->catfile($dir, $modfile);
 168             if (-r $p) {
 169                 $module = _module_name($p, $module) if $Is_VMS;
 170
 171                 $self->{$module}{version} = MM->parse_version($p);
 172                 last;
 173             }
 174         }
 175
 176         # Read the .packlist
 177         $self->{$module}{packlist} =
 178           ExtUtils::Packlist->new($File::Find::name);
 179     };
 180     my %dupe;
 181     @dirs= grep { -e $_ && !$dupe{$_}++ } @dirs;
 182     $self->{':private:'}{LIBDIRS} = \@dirs;
 183     find($sub, @dirs) if @dirs;
 184
 185     return(bless($self, $class));
 186 }
 187
 188 # VMS's non-case preserving file-system means the package name can't
 189 # be reconstructed from the filename.
 190 sub _module_name {
 191     my($file, $orig_module) = @_;
 192
 193     my $module = '';
 194     if (open PACKFH, $file) {
 195         while (<PACKFH>) {
 196             if (/package\s+(\S+)\s*;/) {
 197                 my $pack = $1;
 198                 # Make a sanity check, that lower case $module
 199                 # is identical to lowercase $pack before
 200                 # accepting it
 201                 if (lc($pack) eq lc($orig_module)) {
 202                     $module = $pack;
 203                     last;
 204                 }
 205             }
 206         }
 207         close PACKFH;
 208     }
 209
 210     print STDERR "Couldn't figure out the package name for $file\n"
 211       unless $module;
 212
 213     return $module;
 214 }
 215
 216
 217
 218 sub modules {
 219     my ($self) = @_;
 220
 221     # Bug/feature of sort in scalar context requires this.
 222     return wantarray
 223         ? sort grep { not /^:private:$/ } keys %$self
 224         : grep { not /^:private:$/ } keys %$self;
 225 }
 226
 227 sub files {
 228     my ($self, $module, $type, @under) = @_;
 229
 230     # Validate arguments
 231     Carp::croak("$module is not installed") if (! exists($self->{$module}));
 232     $type = "all" if (! defined($type));
 233     Carp::croak('type must be "all", "prog" or "doc"')
 234         if ($type ne "all" && $type ne "prog" && $type ne "doc");
 235
 236     my (@files);
 237     foreach my $file (keys(%{$self->{$module}{packlist}})) {
 238         push(@files, $file)
 239           if ($self->_is_type($file, $type) &&
 240               $self->_is_under($file, @under));
 241     }
 242     return(@files);
 243 }
 244
 245 sub directories {
 246     my ($self, $module, $type, @under) = @_;
 247     my (%dirs);
 248     foreach my $file ($self->files($module, $type, @under)) {
 249         $dirs{dirname($file)}++;
 250     }
 251     return sort keys %dirs;
 252 }
 253
 254 sub directory_tree {
 255     my ($self, $module, $type, @under) = @_;
 256     my (%dirs);
 257     foreach my $dir ($self->directories($module, $type, @under)) {
 258         $dirs{$dir}++;
 259         my ($last) = ("");
 260         while ($last ne $dir) {
 261             $last = $dir;
 262             $dir = dirname($dir);
 263             last if !$self->_is_under($dir, @under);
 264             $dirs{$dir}++;
 265         }
 266     }
 267     return(sort(keys(%dirs)));
 268 }
 269
 270 sub validate {
 271     my ($self, $module, $remove) = @_;
 272     Carp::croak("$module is not installed") if (! exists($self->{$module}));
 273     return($self->{$module}{packlist}->validate($remove));
 274 }
 275
 276 sub packlist {
 277     my ($self, $module) = @_;
 278     Carp::croak("$module is not installed") if (! exists($self->{$module}));
 279     return($self->{$module}{packlist});
 280 }
 281
 282 sub version {
 283     my ($self, $module) = @_;
 284     Carp::croak("$module is not installed") if (! exists($self->{$module}));
 285     return($self->{$module}{version});
 286 }
 287
 288
 289 1;
 290
 291 __END__
 292
 293 =head1 NAME
 294
 295 ExtUtils::Installed - Inventory management of installed modules
 296
 297 =head1 SYNOPSIS
 298
 299    use ExtUtils::Installed;
 300    my ($inst) = ExtUtils::Installed->new();
 301    my (@modules) = $inst->modules();
 302    my (@missing) = $inst->validate("DBI");
 303    my $all_files = $inst->files("DBI");
 304    my $files_below_usr_local = $inst->files("DBI", "all", "/usr/local");
 305    my $all_dirs = $inst->directories("DBI");
 306    my $dirs_below_usr_local = $inst->directory_tree("DBI", "prog");
 307    my $packlist = $inst->packlist("DBI");
 308
 309 =head1 DESCRIPTION
 310
 311 ExtUtils::Installed  provides a standard way to find out what core and module
 312 files have been installed.  It uses the information stored in .packlist files
 313 created during installation to provide this information.  In addition it
 314 provides facilities to classify the installed files and to extract directory
 315 information from the .packlist files.
 316
 317 =head1 USAGE
 318
 319 The new() function searches for all the installed .packlists on the system, and
 320 stores their contents. The .packlists can be queried with the functions
 321 described below. Where it searches by default is determined by the settings found
 322 in C<%Config::Config>, and what the value is of the PERL5LIB environment variable.
 323
 324 =head1 FUNCTIONS
 325
 326 =over 4
 327
 328 =item new()
 329
 330 This takes optional named parameters. Without parameters, this
 331 searches for all the installed .packlists on the system using
 332 information from C<%Config::Config> and the default module search
 333 paths C<@INC>. The packlists are read using the
 334 L<ExtUtils::Packlist> module.
 335
 336 If the named parameter C<config_override> is specified,
 337 it should be a reference to a hash which contains all information
 338 usually found in C<%Config::Config>. For example, you can obtain
 339 the configuration information for a separate perl installation and
 340 pass that in.
 341
 342     my $yoda_cfg  = get_fake_config('yoda');
 343     my $yoda_inst = ExtUtils::Installed->new(config_override=>$yoda_cfg);
 344
 345 Similarly, the parameter C<inc_override> may be a reference to an
 346 array which is used in place of the default module search paths
 347 from C<@INC>.
 348
 349     use Config;
 350     my @dirs = split(/\Q$Config{path_sep}\E/, $ENV{PERL5LIB});
 351     my $p5libs = ExtUtils::Installed->new(inc_override=>\@dirs);
 352
 353 The parameter c<extra_libs> can be used to specify B<additional> paths to
 354 search for installed modules. For instance
 355
 356     my $installed = ExtUtils::Installed->new(extra_libs=>["/my/lib/path"]);
 357
 358 This should only be necessary if C</my/lib/path> is not in PERL5LIB.
 359
 360 =item modules()
 361
 362 This returns a list of the names of all the installed modules.  The perl 'core'
 363 is given the special name 'Perl'.
 364
 365 =item files()
 366
 367 This takes one mandatory parameter, the name of a module.  It returns a list of
 368 all the filenames from the package.  To obtain a list of core perl files, use
 369 the module name 'Perl'.  Additional parameters are allowed.  The first is one
 370 of the strings "prog", "doc" or "all", to select either just program files,
 371 just manual files or all files.  The remaining parameters are a list of
 372 directories. The filenames returned will be restricted to those under the
 373 specified directories.
 374
 375 =item directories()
 376
 377 This takes one mandatory parameter, the name of a module.  It returns a list of
 378 all the directories from the package.  Additional parameters are allowed.  The
 379 first is one of the strings "prog", "doc" or "all", to select either just
 380 program directories, just manual directories or all directories.  The remaining
 381 parameters are a list of directories. The directories returned will be
 382 restricted to those under the specified directories.  This method returns only
 383 the leaf directories that contain files from the specified module.
 384
 385 =item directory_tree()
 386
 387 This is identical in operation to directories(), except that it includes all the
 388 intermediate directories back up to the specified directories.
 389
 390 =item validate()
 391
 392 This takes one mandatory parameter, the name of a module.  It checks that all
 393 the files listed in the modules .packlist actually exist, and returns a list of
 394 any missing files.  If an optional second argument which evaluates to true is
 395 given any missing files will be removed from the .packlist
 396
 397 =item packlist()
 398
 399 This returns the ExtUtils::Packlist object for the specified module.
 400
 401 =item version()
 402
 403 This returns the version number for the specified module.
 404
 405 =back
 406
 407 =head1 EXAMPLE
 408
 409 See the example in L<ExtUtils::Packlist>.
 410
 411 =head1 AUTHOR
 412
 413 Alan Burlison <Alan.Burlison@uk.sun.com>
 414
 415 =cut