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