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