local-lib5/lib/perl5/ExtUtils/Installed.pm

   1 package ExtUtils::Installed;
   2
   3 use 5.00503;
   4 use strict;
   5 #use warnings; # XXX requires 5.6
   6 use Carp qw();
   7 use ExtUtils::Packlist;
   8 use ExtUtils::MakeMaker;
   9 use Config;
  10 use File::Find;
  11 use File::Basename;
  12 use File::Spec;
  13
  14 my $Is_VMS = $^O eq 'VMS';
  15 my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/);
  16
  17 require VMS::Filespec if $Is_VMS;
  18
  19 use vars qw($VERSION);
  20 $VERSION = '1.999_001';
  21 $VERSION = eval $VERSION;
  22
  23 sub _is_prefix {
  24     my ($self, $path, $prefix) = @_;
  25     return unless defined $prefix && defined $path;
  26
  27     if( $Is_VMS ) {
  28         $prefix = VMS::Filespec::unixify($prefix);
  29         $path   = VMS::Filespec::unixify($path);
  30     }
  31
  32     # Unix path normalization.
  33     $prefix = File::Spec->canonpath($prefix);
  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     my $conf= $self->{':private:'}{Config};
  62     if ($type eq "prog") {
  63         return($self->_is_prefix($path, $conf->{prefix} || $conf->{prefixexp})
  64                && !($self->_is_doc($path)) ? 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 _fix_dirs {
  80     my ($self, @dirs)= @_;
  81     # File::Find does not know how to deal with VMS filepaths.
  82     if( $Is_VMS ) {
  83         $_ = VMS::Filespec::unixify($_)
  84             for @dirs;
  85     }
  86
  87     if ($DOSISH) {
  88         s|\\|/|g for @dirs;
  89     }
  90     return wantarray ? @dirs : $dirs[0];
  91 }
  92
  93 sub _make_entry {
  94     my ($self, $module, $packlist_file, $modfile)= @_;
  95
  96     my $data= {
  97         module => $module,
  98         packlist => scalar(ExtUtils::Packlist->new($packlist_file)),
  99         packlist_file => $packlist_file,
 100     };
 101
 102     if (!$modfile) {
 103         $data->{version} = $self->{':private:'}{Config}{version};
 104     } else {
 105         $data->{modfile} = $modfile;
 106         # Find the top-level module file in @INC
 107         $data->{version} = '';
 108         foreach my $dir (@{$self->{':private:'}{INC}}) {
 109             my $p = File::Spec->catfile($dir, $modfile);
 110             if (-r $p) {
 111                 $module = _module_name($p, $module) if $Is_VMS;
 112
 113                 $data->{version} = MM->parse_version($p);
 114                 $data->{version_from} = $p;
 115                 $data->{packlist_valid} = exists $data->{packlist}{$p};
 116                 last;
 117             }
 118         }
 119     }
 120     $self->{$module}= $data;
 121 }
 122
 123 our $INSTALLED;
 124 sub new {
 125     my ($class) = shift(@_);
 126     $class = ref($class) || $class;
 127
 128     my %args = @_;
 129
 130     return $INSTALLED if $INSTALLED and ($args{default_get} || $args{default});
 131
 132     my $self = bless {}, $class;
 133
 134     $INSTALLED= $self if $args{default_set} || $args{default};
 135
 136
 137     if ($args{config_override}) {
 138         eval {
 139             $self->{':private:'}{Config} = { %{$args{config_override}} };
 140         } or Carp::croak(
 141             "The 'config_override' parameter must be a hash reference."
 142         );
 143     }
 144     else {
 145         $self->{':private:'}{Config} = \%Config;
 146     }
 147
 148     for my $tuple ([inc_override => INC => [ @INC ] ],
 149                    [ extra_libs => EXTRA => [] ])
 150     {
 151         my ($arg,$key,$val)=@$tuple;
 152         if ( $args{$arg} ) {
 153             eval {
 154                 $self->{':private:'}{$key} = [ @{$args{$arg}} ];
 155             } or Carp::croak(
 156                 "The '$arg' parameter must be an array reference."
 157             );
 158         }
 159         elsif ($val) {
 160             $self->{':private:'}{$key} = $val;
 161         }
 162     }
 163     {
 164         my %dupe;
 165         @{$self->{':private:'}{LIBDIRS}} = grep { -e $_ && !$dupe{$_}++ }
 166             @{$self->{':private:'}{EXTRA}}, @{$self->{':private:'}{INC}};
 167     }
 168
 169     my @dirs= $self->_fix_dirs(@{$self->{':private:'}{LIBDIRS}});
 170
 171     # Read the core packlist
 172     my $archlib = $self->_fix_dirs($self->{':private:'}{Config}{archlibexp});
 173     $self->_make_entry("Perl",File::Spec->catfile($archlib, '.packlist'));
 174
 175     my $root;
 176     # Read the module packlists
 177     my $sub = sub {
 178         # Only process module .packlists
 179         return if $_ ne ".packlist" || $File::Find::dir eq $archlib;
 180
 181         # Hack of the leading bits of the paths & convert to a module name
 182         my $module = $File::Find::name;
 183         my $found = $module =~ s!^.*?/auto/(.*)/.packlist!$1!s
 184             or do {
 185             # warn "Woah! \$_=$_\n\$module=$module\n\$File::Find::dir=$File::Find::dir\n",
 186             #    join ("\n",@dirs);
 187             return;
 188         };
 189
 190         my $modfile = "$module.pm";
 191         $module =~ s!/!::!g;
 192
 193         return if $self->{$module}; #shadowing?
 194         $self->_make_entry($module,$File::Find::name,$modfile);
 195     };
 196     while (@dirs) {
 197         $root= shift @dirs;
 198         next if !-d $root;
 199         find($sub,$root);
 200     }
 201
 202     return $self;
 203 }
 204
 205 # VMS's non-case preserving file-system means the package name can't
 206 # be reconstructed from the filename.
 207 sub _module_name {
 208     my($file, $orig_module) = @_;
 209
 210     my $module = '';
 211     if (open PACKFH, $file) {
 212         while (<PACKFH>) {
 213             if (/package\s+(\S+)\s*;/) {
 214                 my $pack = $1;
 215                 # Make a sanity check, that lower case $module
 216                 # is identical to lowercase $pack before
 217                 # accepting it
 218                 if (lc($pack) eq lc($orig_module)) {
 219                     $module = $pack;
 220                     last;
 221                 }
 222             }
 223         }
 224         close PACKFH;
 225     }
 226
 227     print STDERR "Couldn't figure out the package name for $file\n"
 228       unless $module;
 229
 230     return $module;
 231 }
 232
 233 sub modules {
 234     my ($self) = @_;
 235     $self= $self->new(default=>1) if !ref $self;
 236
 237     # Bug/feature of sort in scalar context requires this.
 238     return wantarray
 239         ? sort grep { not /^:private:$/ } keys %$self
 240         : grep { not /^:private:$/ } keys %$self;
 241 }
 242
 243 sub files {
 244     my ($self, $module, $type, @under) = @_;
 245     $self= $self->new(default=>1) if !ref $self;
 246
 247     # Validate arguments
 248     Carp::croak("$module is not installed") if (! exists($self->{$module}));
 249     $type = "all" if (! defined($type));
 250     Carp::croak('type must be "all", "prog" or "doc"')
 251         if ($type ne "all" && $type ne "prog" && $type ne "doc");
 252
 253     my (@files);
 254     foreach my $file (keys(%{$self->{$module}{packlist}})) {
 255         push(@files, $file)
 256           if ($self->_is_type($file, $type) &&
 257               $self->_is_under($file, @under));
 258     }
 259     return(@files);
 260 }
 261
 262 sub directories {
 263     my ($self, $module, $type, @under) = @_;
 264     $self= $self->new(default=>1) if !ref $self;
 265     my (%dirs);
 266     foreach my $file ($self->files($module, $type, @under)) {
 267         $dirs{dirname($file)}++;
 268     }
 269     return sort keys %dirs;
 270 }
 271
 272 sub directory_tree {
 273     my ($self, $module, $type, @under) = @_;
 274     $self= $self->new(default=>1) if !ref $self;
 275     my (%dirs);
 276     foreach my $dir ($self->directories($module, $type, @under)) {
 277         $dirs{$dir}++;
 278         my ($last) = ("");
 279         while ($last ne $dir) {
 280             $last = $dir;
 281             $dir = dirname($dir);
 282             last if !$self->_is_under($dir, @under);
 283             $dirs{$dir}++;
 284         }
 285     }
 286     return(sort(keys(%dirs)));
 287 }
 288
 289 sub validate {
 290     my ($self, $module, $remove) = @_;
 291     $self= $self->new(default=>1) if !ref $self;
 292     Carp::croak("$module is not installed") if (! exists($self->{$module}));
 293     return($self->{$module}{packlist}->validate($remove));
 294 }
 295
 296 sub packlist {
 297     my ($self, $module) = @_;
 298     $self= $self->new(default=>1) if !ref $self;
 299     Carp::croak("$module is not installed") if (! exists($self->{$module}));
 300     return($self->{$module}{packlist});
 301 }
 302
 303 sub version {
 304     my ($self, $module) = @_;
 305     $self= $self->new(default=>1) if !ref $self;
 306     Carp::croak("$module is not installed") if (! exists($self->{$module}));
 307     return($self->{$module}{version});
 308 }
 309
 310 sub debug_dump {
 311     my ($self, $module) = @_;
 312     $self= $self->new(default=>1) if !ref $self;
 313     local $self->{":private:"}{Config};
 314     require Data::Dumper;
 315     print Data::Dumper->new([$self])->Sortkeys(1)->Indent(1)->Dump();
 316 }
 317
 318
 319 1;
 320
 321 __END__
 322
 323 =head1 NAME
 324
 325 ExtUtils::Installed - Inventory management of installed modules
 326
 327 =head1 SYNOPSIS
 328
 329    use ExtUtils::Installed;
 330    my ($inst) = ExtUtils::Installed->new();
 331    my (@modules) = $inst->modules();
 332    my (@missing) = $inst->validate("DBI");
 333    my $all_files = $inst->files("DBI");
 334    my $files_below_usr_local = $inst->files("DBI", "all", "/usr/local");
 335    my $all_dirs = $inst->directories("DBI");
 336    my $dirs_below_usr_local = $inst->directory_tree("DBI", "prog");
 337    my $packlist = $inst->packlist("DBI");
 338
 339 =head1 DESCRIPTION
 340
 341 ExtUtils::Installed  provides a standard way to find out what core and module
 342 files have been installed.  It uses the information stored in .packlist files
 343 created during installation to provide this information.  In addition it
 344 provides facilities to classify the installed files and to extract directory
 345 information from the .packlist files.
 346
 347 =head1 USAGE
 348
 349 The new() function searches for all the installed .packlists on the system, and
 350 stores their contents. The .packlists can be queried with the functions
 351 described below. Where it searches by default is determined by the settings found
 352 in C<%Config::Config>, and what the value is of the PERL5LIB environment variable.
 353
 354 =head1 METHODS
 355
 356 Unless specified otherwise all method can be called as class methods, or as object
 357 methods. If called as class methods then the "default" object will be used, and if
 358 necessary created using the current processes %Config and @INC.  See the
 359 'default' option to new() for details.
 360
 361
 362 =over 4
 363
 364 =item new()
 365
 366 This takes optional named parameters. Without parameters, this
 367 searches for all the installed .packlists on the system using
 368 information from C<%Config::Config> and the default module search
 369 paths C<@INC>. The packlists are read using the
 370 L<ExtUtils::Packlist> module.
 371
 372 If the named parameter C<config_override> is specified,
 373 it should be a reference to a hash which contains all information
 374 usually found in C<%Config::Config>. For example, you can obtain
 375 the configuration information for a separate perl installation and
 376 pass that in.
 377
 378     my $yoda_cfg  = get_fake_config('yoda');
 379     my $yoda_inst = ExtUtils::Installed->new(config_override=>$yoda_cfg);
 380
 381 Similarly, the parameter C<inc_override> may be a reference to an
 382 array which is used in place of the default module search paths
 383 from C<@INC>.
 384
 385     use Config;
 386     my @dirs = split(/\Q$Config{path_sep}\E/, $ENV{PERL5LIB});
 387     my $p5libs = ExtUtils::Installed->new(inc_override=>\@dirs);
 388
 389 B<Note>: You probably do not want to use these options alone, almost always
 390 you will want to set both together.
 391
 392 The parameter c<extra_libs> can be used to specify B<additional> paths to
 393 search for installed modules. For instance
 394
 395     my $installed = ExtUtils::Installed->new(extra_libs=>["/my/lib/path"]);
 396
 397 This should only be necessary if C</my/lib/path> is not in PERL5LIB.
 398
 399 Finally there is the 'default', and the related 'default_get' and 'default_set'
 400 options. These options control the "default" object which is provided by the
 401 class interface to the methods. Setting C<default_get> to true tells the constructor
 402 to return the default object if it is defined. Setting C<default_set> to true tells
 403 the constructor to make the default object the constructed object. Setting the
 404 C<default> option is like setting both to true. This is used primarily internally
 405 and probably isn't interesting to any real user.
 406
 407 =item modules()
 408
 409 This returns a list of the names of all the installed modules.  The perl 'core'
 410 is given the special name 'Perl'.
 411
 412 =item files()
 413
 414 This takes one mandatory parameter, the name of a module.  It returns a list of
 415 all the filenames from the package.  To obtain a list of core perl files, use
 416 the module name 'Perl'.  Additional parameters are allowed.  The first is one
 417 of the strings "prog", "doc" or "all", to select either just program files,
 418 just manual files or all files.  The remaining parameters are a list of
 419 directories. The filenames returned will be restricted to those under the
 420 specified directories.
 421
 422 =item directories()
 423
 424 This takes one mandatory parameter, the name of a module.  It returns a list of
 425 all the directories from the package.  Additional parameters are allowed.  The
 426 first is one of the strings "prog", "doc" or "all", to select either just
 427 program directories, just manual directories or all directories.  The remaining
 428 parameters are a list of directories. The directories returned will be
 429 restricted to those under the specified directories.  This method returns only
 430 the leaf directories that contain files from the specified module.
 431
 432 =item directory_tree()
 433
 434 This is identical in operation to directories(), except that it includes all the
 435 intermediate directories back up to the specified directories.
 436
 437 =item validate()
 438
 439 This takes one mandatory parameter, the name of a module.  It checks that all
 440 the files listed in the modules .packlist actually exist, and returns a list of
 441 any missing files.  If an optional second argument which evaluates to true is
 442 given any missing files will be removed from the .packlist
 443
 444 =item packlist()
 445
 446 This returns the ExtUtils::Packlist object for the specified module.
 447
 448 =item version()
 449
 450 This returns the version number for the specified module.
 451
 452 =back
 453
 454 =head1 EXAMPLE
 455
 456 See the example in L<ExtUtils::Packlist>.
 457
 458 =head1 AUTHOR
 459
 460 Alan Burlison <Alan.Burlison@uk.sun.com>
 461
 462 =cut