1package ExtUtils::Installed; 2 3use 5.00503; 4use strict; 5use Carp qw(); 6use ExtUtils::Packlist; 7use ExtUtils::MakeMaker; 8use Config; 9use File::Find; 10use File::Basename; 11use File::Spec; 12 13my $Is_VMS = $^O eq 'VMS'; 14my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/); 15 16require VMS::Filespec if $Is_VMS; 17 18use vars qw($VERSION); 19$VERSION = '0.08'; 20 21sub _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 44sub _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 54sub _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 69sub _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 79sub 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. 142sub _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 170sub 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 177sub 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 195sub 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 204sub 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 220sub 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 226sub packlist { 227 my ($self, $module) = @_; 228 Carp::croak("$module is not installed") if (! exists($self->{$module})); 229 return($self->{$module}{packlist}); 230} 231 232sub version { 233 my ($self, $module) = @_; 234 Carp::croak("$module is not installed") if (! exists($self->{$module})); 235 return($self->{$module}{version}); 236} 237 238 2391; 240 241__END__ 242 243=head1 NAME 244 245ExtUtils::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 261ExtUtils::Installed provides a standard way to find out what core and module 262files have been installed. It uses the information stored in .packlist files 263created during installation to provide this information. In addition it 264provides facilities to classify the installed files and to extract directory 265information from the .packlist files. 266 267=head1 USAGE 268 269The new() function searches for all the installed .packlists on the system, and 270stores their contents. The .packlists can be queried with the functions 271described below. 272 273=head1 FUNCTIONS 274 275=over 4 276 277=item new() 278 279This takes no parameters, and searches for all the installed .packlists on the 280system. The packlists are read using the ExtUtils::packlist module. 281 282=item modules() 283 284This returns a list of the names of all the installed modules. The perl 'core' 285is given the special name 'Perl'. 286 287=item files() 288 289This takes one mandatory parameter, the name of a module. It returns a list of 290all the filenames from the package. To obtain a list of core perl files, use 291the module name 'Perl'. Additional parameters are allowed. The first is one 292of the strings "prog", "doc" or "all", to select either just program files, 293just manual files or all files. The remaining parameters are a list of 294directories. The filenames returned will be restricted to those under the 295specified directories. 296 297=item directories() 298 299This takes one mandatory parameter, the name of a module. It returns a list of 300all the directories from the package. Additional parameters are allowed. The 301first is one of the strings "prog", "doc" or "all", to select either just 302program directories, just manual directories or all directories. The remaining 303parameters are a list of directories. The directories returned will be 304restricted to those under the specified directories. This method returns only 305the leaf directories that contain files from the specified module. 306 307=item directory_tree() 308 309This is identical in operation to directories(), except that it includes all the 310intermediate directories back up to the specified directories. 311 312=item validate() 313 314This takes one mandatory parameter, the name of a module. It checks that all 315the files listed in the modules .packlist actually exist, and returns a list of 316any missing files. If an optional second argument which evaluates to true is 317given any missing files will be removed from the .packlist 318 319=item packlist() 320 321This returns the ExtUtils::Packlist object for the specified module. 322 323=item version() 324 325This returns the version number for the specified module. 326 327=back 328 329=head1 EXAMPLE 330 331See the example in L<ExtUtils::Packlist>. 332 333=head1 AUTHOR 334 335Alan Burlison <Alan.Burlison@uk.sun.com> 336 337=cut 338