[Summary view] [Print] [Text view]

   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