[ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
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 = '1.43'; 20 $VERSION = eval $VERSION; 21 22 sub _is_prefix { 23 my ($self, $path, $prefix) = @_; 24 return unless defined $prefix && defined $path; 25 26 if( $Is_VMS ) { 27 $prefix = VMS::Filespec::unixify($prefix); 28 $path = VMS::Filespec::unixify($path); 29 } 30 31 # Sloppy Unix path normalization. 32 $prefix =~ s{/+}{/}g; 33 $path =~ s{/+}{/}g; 34 35 return 1 if substr($path, 0, length($prefix)) eq $prefix; 36 37 if ($DOSISH) { 38 $path =~ s|\\|/|g; 39 $prefix =~ s|\\|/|g; 40 return 1 if $path =~ m{^\Q$prefix\E}i; 41 } 42 return(0); 43 } 44 45 sub _is_doc { 46 my ($self, $path) = @_; 47 48 my $man1dir = $self->{':private:'}{Config}{man1direxp}; 49 my $man3dir = $self->{':private:'}{Config}{man3direxp}; 50 return(($man1dir && $self->_is_prefix($path, $man1dir)) 51 || 52 ($man3dir && $self->_is_prefix($path, $man3dir)) 53 ? 1 : 0) 54 } 55 56 sub _is_type { 57 my ($self, $path, $type) = @_; 58 return 1 if $type eq "all"; 59 60 return($self->_is_doc($path)) if $type eq "doc"; 61 62 if ($type eq "prog") { 63 return($self->_is_prefix($path, $self->{':private:'}{Config}{prefix} || $self->{':private:'}{Config}{prefixexp}) 64 && 65 !($self->_is_doc($path)) 66 ? 1 : 0); 67 } 68 return(0); 69 } 70 71 sub _is_under { 72 my ($self, $path, @under) = @_; 73 $under[0] = "" if (! @under); 74 foreach my $dir (@under) { 75 return(1) if ($self->_is_prefix($path, $dir)); 76 } 77 78 return(0); 79 } 80 81 sub new { 82 my ($class) = shift(@_); 83 $class = ref($class) || $class; 84 85 my %args = @_; 86 87 my $self = {}; 88 89 if ($args{config_override}) { 90 eval { 91 $self->{':private:'}{Config} = { %{$args{config_override}} }; 92 } or Carp::croak( 93 "The 'config_override' parameter must be a hash reference." 94 ); 95 } 96 else { 97 $self->{':private:'}{Config} = \%Config; 98 } 99 100 for my $tuple ([inc_override => INC => [ @INC ] ], 101 [ extra_libs => EXTRA => [] ]) 102 { 103 my ($arg,$key,$val)=@$tuple; 104 if ( $args{$arg} ) { 105 eval { 106 $self->{':private:'}{$key} = [ @{$args{$arg}} ]; 107 } or Carp::croak( 108 "The '$arg' parameter must be an array reference." 109 ); 110 } 111 elsif ($val) { 112 $self->{':private:'}{$key} = $val; 113 } 114 } 115 { 116 my %dupe; 117 @{$self->{':private:'}{INC}} = grep { -e $_ && !$dupe{$_}++ } 118 @{$self->{':private:'}{INC}}, @{$self->{':private:'}{EXTRA}}; 119 } 120 my $perl5lib = defined $ENV{PERL5LIB} ? $ENV{PERL5LIB} : ""; 121 122 my @dirs = ( $self->{':private:'}{Config}{archlibexp}, 123 $self->{':private:'}{Config}{sitearchexp}, 124 split(/\Q$Config{path_sep}\E/, $perl5lib), 125 @{$self->{':private:'}{EXTRA}}, 126 ); 127 128 # File::Find does not know how to deal with VMS filepaths. 129 if( $Is_VMS ) { 130 $_ = VMS::Filespec::unixify($_) 131 for @dirs; 132 } 133 134 if ($DOSISH) { 135 s|\\|/|g for @dirs; 136 } 137 my $archlib = $dirs[0]; 138 139 # Read the core packlist 140 $self->{Perl}{packlist} = 141 ExtUtils::Packlist->new( File::Spec->catfile($archlib, '.packlist') ); 142 $self->{Perl}{version} = $self->{':private:'}{Config}{version}; 143 144 # Read the module packlists 145 my $sub = sub { 146 # Only process module .packlists 147 return if $_ ne ".packlist" || $File::Find::dir eq $archlib; 148 149 # Hack of the leading bits of the paths & convert to a module name 150 my $module = $File::Find::name; 151 my $found; 152 for (@dirs) { 153 $found = $module =~ s!\Q$_\E/?auto/(.*)/.packlist!$1!s 154 and last; 155 } 156 unless ($found) { 157 # warn "Woah! \$_=$_\n\$module=$module\n\$File::Find::dir=$File::Find::dir\n", 158 # join ("\n",@dirs); 159 return; 160 } 161 my $modfile = "$module.pm"; 162 $module =~ s!/!::!g; 163 164 # Find the top-level module file in @INC 165 $self->{$module}{version} = ''; 166 foreach my $dir (@{$self->{':private:'}{INC}}) { 167 my $p = File::Spec->catfile($dir, $modfile); 168 if (-r $p) { 169 $module = _module_name($p, $module) if $Is_VMS; 170 171 $self->{$module}{version} = MM->parse_version($p); 172 last; 173 } 174 } 175 176 # Read the .packlist 177 $self->{$module}{packlist} = 178 ExtUtils::Packlist->new($File::Find::name); 179 }; 180 my %dupe; 181 @dirs= grep { -e $_ && !$dupe{$_}++ } @dirs; 182 $self->{':private:'}{LIBDIRS} = \@dirs; 183 find($sub, @dirs) if @dirs; 184 185 return(bless($self, $class)); 186 } 187 188 # VMS's non-case preserving file-system means the package name can't 189 # be reconstructed from the filename. 190 sub _module_name { 191 my($file, $orig_module) = @_; 192 193 my $module = ''; 194 if (open PACKFH, $file) { 195 while (<PACKFH>) { 196 if (/package\s+(\S+)\s*;/) { 197 my $pack = $1; 198 # Make a sanity check, that lower case $module 199 # is identical to lowercase $pack before 200 # accepting it 201 if (lc($pack) eq lc($orig_module)) { 202 $module = $pack; 203 last; 204 } 205 } 206 } 207 close PACKFH; 208 } 209 210 print STDERR "Couldn't figure out the package name for $file\n" 211 unless $module; 212 213 return $module; 214 } 215 216 217 218 sub modules { 219 my ($self) = @_; 220 221 # Bug/feature of sort in scalar context requires this. 222 return wantarray 223 ? sort grep { not /^:private:$/ } keys %$self 224 : grep { not /^:private:$/ } keys %$self; 225 } 226 227 sub files { 228 my ($self, $module, $type, @under) = @_; 229 230 # Validate arguments 231 Carp::croak("$module is not installed") if (! exists($self->{$module})); 232 $type = "all" if (! defined($type)); 233 Carp::croak('type must be "all", "prog" or "doc"') 234 if ($type ne "all" && $type ne "prog" && $type ne "doc"); 235 236 my (@files); 237 foreach my $file (keys(%{$self->{$module}{packlist}})) { 238 push(@files, $file) 239 if ($self->_is_type($file, $type) && 240 $self->_is_under($file, @under)); 241 } 242 return(@files); 243 } 244 245 sub directories { 246 my ($self, $module, $type, @under) = @_; 247 my (%dirs); 248 foreach my $file ($self->files($module, $type, @under)) { 249 $dirs{dirname($file)}++; 250 } 251 return sort keys %dirs; 252 } 253 254 sub directory_tree { 255 my ($self, $module, $type, @under) = @_; 256 my (%dirs); 257 foreach my $dir ($self->directories($module, $type, @under)) { 258 $dirs{$dir}++; 259 my ($last) = (""); 260 while ($last ne $dir) { 261 $last = $dir; 262 $dir = dirname($dir); 263 last if !$self->_is_under($dir, @under); 264 $dirs{$dir}++; 265 } 266 } 267 return(sort(keys(%dirs))); 268 } 269 270 sub validate { 271 my ($self, $module, $remove) = @_; 272 Carp::croak("$module is not installed") if (! exists($self->{$module})); 273 return($self->{$module}{packlist}->validate($remove)); 274 } 275 276 sub packlist { 277 my ($self, $module) = @_; 278 Carp::croak("$module is not installed") if (! exists($self->{$module})); 279 return($self->{$module}{packlist}); 280 } 281 282 sub version { 283 my ($self, $module) = @_; 284 Carp::croak("$module is not installed") if (! exists($self->{$module})); 285 return($self->{$module}{version}); 286 } 287 288 289 1; 290 291 __END__ 292 293 =head1 NAME 294 295 ExtUtils::Installed - Inventory management of installed modules 296 297 =head1 SYNOPSIS 298 299 use ExtUtils::Installed; 300 my ($inst) = ExtUtils::Installed->new(); 301 my (@modules) = $inst->modules(); 302 my (@missing) = $inst->validate("DBI"); 303 my $all_files = $inst->files("DBI"); 304 my $files_below_usr_local = $inst->files("DBI", "all", "/usr/local"); 305 my $all_dirs = $inst->directories("DBI"); 306 my $dirs_below_usr_local = $inst->directory_tree("DBI", "prog"); 307 my $packlist = $inst->packlist("DBI"); 308 309 =head1 DESCRIPTION 310 311 ExtUtils::Installed provides a standard way to find out what core and module 312 files have been installed. It uses the information stored in .packlist files 313 created during installation to provide this information. In addition it 314 provides facilities to classify the installed files and to extract directory 315 information from the .packlist files. 316 317 =head1 USAGE 318 319 The new() function searches for all the installed .packlists on the system, and 320 stores their contents. The .packlists can be queried with the functions 321 described below. Where it searches by default is determined by the settings found 322 in C<%Config::Config>, and what the value is of the PERL5LIB environment variable. 323 324 =head1 FUNCTIONS 325 326 =over 4 327 328 =item new() 329 330 This takes optional named parameters. Without parameters, this 331 searches for all the installed .packlists on the system using 332 information from C<%Config::Config> and the default module search 333 paths C<@INC>. The packlists are read using the 334 L<ExtUtils::Packlist> module. 335 336 If the named parameter C<config_override> is specified, 337 it should be a reference to a hash which contains all information 338 usually found in C<%Config::Config>. For example, you can obtain 339 the configuration information for a separate perl installation and 340 pass that in. 341 342 my $yoda_cfg = get_fake_config('yoda'); 343 my $yoda_inst = ExtUtils::Installed->new(config_override=>$yoda_cfg); 344 345 Similarly, the parameter C<inc_override> may be a reference to an 346 array which is used in place of the default module search paths 347 from C<@INC>. 348 349 use Config; 350 my @dirs = split(/\Q$Config{path_sep}\E/, $ENV{PERL5LIB}); 351 my $p5libs = ExtUtils::Installed->new(inc_override=>\@dirs); 352 353 The parameter c<extra_libs> can be used to specify B<additional> paths to 354 search for installed modules. For instance 355 356 my $installed = ExtUtils::Installed->new(extra_libs=>["/my/lib/path"]); 357 358 This should only be necessary if C</my/lib/path> is not in PERL5LIB. 359 360 =item modules() 361 362 This returns a list of the names of all the installed modules. The perl 'core' 363 is given the special name 'Perl'. 364 365 =item files() 366 367 This takes one mandatory parameter, the name of a module. It returns a list of 368 all the filenames from the package. To obtain a list of core perl files, use 369 the module name 'Perl'. Additional parameters are allowed. The first is one 370 of the strings "prog", "doc" or "all", to select either just program files, 371 just manual files or all files. The remaining parameters are a list of 372 directories. The filenames returned will be restricted to those under the 373 specified directories. 374 375 =item directories() 376 377 This takes one mandatory parameter, the name of a module. It returns a list of 378 all the directories from the package. Additional parameters are allowed. The 379 first is one of the strings "prog", "doc" or "all", to select either just 380 program directories, just manual directories or all directories. The remaining 381 parameters are a list of directories. The directories returned will be 382 restricted to those under the specified directories. This method returns only 383 the leaf directories that contain files from the specified module. 384 385 =item directory_tree() 386 387 This is identical in operation to directories(), except that it includes all the 388 intermediate directories back up to the specified directories. 389 390 =item validate() 391 392 This takes one mandatory parameter, the name of a module. It checks that all 393 the files listed in the modules .packlist actually exist, and returns a list of 394 any missing files. If an optional second argument which evaluates to true is 395 given any missing files will be removed from the .packlist 396 397 =item packlist() 398 399 This returns the ExtUtils::Packlist object for the specified module. 400 401 =item version() 402 403 This returns the version number for the specified module. 404 405 =back 406 407 =head1 EXAMPLE 408 409 See the example in L<ExtUtils::Packlist>. 410 411 =head1 AUTHOR 412 413 Alan Burlison <Alan.Burlison@uk.sun.com> 414 415 =cut
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |