| 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 | |
| 336 | =cut |