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