This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
061c32916f3e987b34bd150d2ebc8528532bd71b
[perl5.git] / cpan / ExtUtils-Install / lib / ExtUtils / Installed.pm
1 package ExtUtils::Installed;
2
3 use 5.00503;
4 use strict;
5 #use warnings; # XXX requires 5.6
6 use Carp qw();
7 use ExtUtils::Packlist;
8 use ExtUtils::MakeMaker;
9 use Config;
10 use File::Find;
11 use File::Basename;
12 use File::Spec;
13
14 my $Is_VMS = $^O eq 'VMS';
15 my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/);
16
17 require VMS::Filespec if $Is_VMS;
18
19 use vars qw($VERSION);
20 $VERSION = '2.04';
21 $VERSION = eval $VERSION;
22
23 sub _is_prefix {
24     my ($self, $path, $prefix) = @_;
25     return unless defined $prefix && defined $path;
26
27     if( $Is_VMS ) {
28         $prefix = VMS::Filespec::unixify($prefix);
29         $path   = VMS::Filespec::unixify($path);
30     }
31
32     # Unix path normalization.
33     $prefix = File::Spec->canonpath($prefix);
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     my $conf= $self->{':private:'}{Config};
62     if ($type eq "prog") {
63         return($self->_is_prefix($path, $conf->{prefix} || $conf->{prefixexp})
64                && !($self->_is_doc($path)) ? 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 _fix_dirs {
80     my ($self, @dirs)= @_;
81     # File::Find does not know how to deal with VMS filepaths.
82     if( $Is_VMS ) {
83         $_ = VMS::Filespec::unixify($_)
84             for @dirs;
85     }
86
87     if ($DOSISH) {
88         s|\\|/|g for @dirs;
89     }
90     return wantarray ? @dirs : $dirs[0];
91 }
92
93 sub _make_entry {
94     my ($self, $module, $packlist_file, $modfile)= @_;
95
96     my $data= {
97         module => $module,
98         packlist => scalar(ExtUtils::Packlist->new($packlist_file)),
99         packlist_file => $packlist_file,
100     };
101
102     if (!$modfile) {
103         $data->{version} = $self->{':private:'}{Config}{version};
104     } else {
105         $data->{modfile} = $modfile;
106         # Find the top-level module file in @INC
107         $data->{version} = '';
108         foreach my $dir (@{$self->{':private:'}{INC}}) {
109             my $p = File::Spec->catfile($dir, $modfile);
110             if (-r $p) {
111                 $module = _module_name($p, $module) if $Is_VMS;
112
113                 $data->{version} = MM->parse_version($p);
114                 $data->{version_from} = $p;
115                 $data->{packlist_valid} = exists $data->{packlist}{$p};
116                 last;
117             }
118         }
119     }
120     $self->{$module}= $data;
121 }
122
123 our $INSTALLED;
124 sub new {
125     my ($class) = shift(@_);
126     $class = ref($class) || $class;
127
128     my %args = @_;
129
130     return $INSTALLED if $INSTALLED and ($args{default_get} || $args{default});
131
132     my $self = bless {}, $class;
133
134     $INSTALLED= $self if $args{default_set} || $args{default};
135
136
137     if ($args{config_override}) {
138         eval {
139             $self->{':private:'}{Config} = { %{$args{config_override}} };
140         } or Carp::croak(
141             "The 'config_override' parameter must be a hash reference."
142         );
143     }
144     else {
145         $self->{':private:'}{Config} = \%Config;
146     }
147
148     for my $tuple ([inc_override => INC => [ @INC ] ],
149                    [ extra_libs => EXTRA => [] ])
150     {
151         my ($arg,$key,$val)=@$tuple;
152         if ( $args{$arg} ) {
153             eval {
154                 $self->{':private:'}{$key} = [ @{$args{$arg}} ];
155             } or Carp::croak(
156                 "The '$arg' parameter must be an array reference."
157             );
158         }
159         elsif ($val) {
160             $self->{':private:'}{$key} = $val;
161         }
162     }
163     {
164         my %dupe;
165         @{$self->{':private:'}{LIBDIRS}} =
166             grep { $_ ne '.' || ! $args{skip_cwd} }
167             grep { -e $_ && !$dupe{$_}++ }
168             @{$self->{':private:'}{EXTRA}}, @{$self->{':private:'}{INC}};
169     }
170
171     my @dirs= $self->_fix_dirs(@{$self->{':private:'}{LIBDIRS}});
172
173     # Read the core packlist
174     my $archlib = $self->_fix_dirs($self->{':private:'}{Config}{archlibexp});
175     $self->_make_entry("Perl",File::Spec->catfile($archlib, '.packlist'));
176
177     my $root;
178     # Read the module packlists
179     my $sub = sub {
180         # Only process module .packlists
181         return if $_ ne ".packlist" || $File::Find::dir eq $archlib;
182
183         # Hack of the leading bits of the paths & convert to a module name
184         my $module = $File::Find::name;
185         my $found = $module =~ s!^.*?/auto/(.*)/.packlist!$1!s
186             or do {
187             # warn "Woah! \$_=$_\n\$module=$module\n\$File::Find::dir=$File::Find::dir\n",
188             #    join ("\n",@dirs);
189             return;
190         };
191
192         my $modfile = "$module.pm";
193         $module =~ s!/!::!g;
194
195         return if $self->{$module}; #shadowing?
196         $self->_make_entry($module,$File::Find::name,$modfile);
197     };
198     while (@dirs) {
199         $root= shift @dirs;
200         next if !-d $root;
201         find($sub,$root);
202     }
203
204     return $self;
205 }
206
207 # VMS's non-case preserving file-system means the package name can't
208 # be reconstructed from the filename.
209 sub _module_name {
210     my($file, $orig_module) = @_;
211
212     my $module = '';
213     if (open PACKFH, $file) {
214         while (<PACKFH>) {
215             if (/package\s+(\S+)\s*;/) {
216                 my $pack = $1;
217                 # Make a sanity check, that lower case $module
218                 # is identical to lowercase $pack before
219                 # accepting it
220                 if (lc($pack) eq lc($orig_module)) {
221                     $module = $pack;
222                     last;
223                 }
224             }
225         }
226         close PACKFH;
227     }
228
229     print STDERR "Couldn't figure out the package name for $file\n"
230       unless $module;
231
232     return $module;
233 }
234
235 sub modules {
236     my ($self) = @_;
237     $self= $self->new(default=>1) if !ref $self;
238
239     # Bug/feature of sort in scalar context requires this.
240     return wantarray
241         ? sort grep { not /^:private:$/ } keys %$self
242         : grep { not /^:private:$/ } keys %$self;
243 }
244
245 sub files {
246     my ($self, $module, $type, @under) = @_;
247     $self= $self->new(default=>1) if !ref $self;
248
249     # Validate arguments
250     Carp::croak("$module is not installed") if (! exists($self->{$module}));
251     $type = "all" if (! defined($type));
252     Carp::croak('type must be "all", "prog" or "doc"')
253         if ($type ne "all" && $type ne "prog" && $type ne "doc");
254
255     my (@files);
256     foreach my $file (keys(%{$self->{$module}{packlist}})) {
257         push(@files, $file)
258           if ($self->_is_type($file, $type) &&
259               $self->_is_under($file, @under));
260     }
261     return(@files);
262 }
263
264 sub directories {
265     my ($self, $module, $type, @under) = @_;
266     $self= $self->new(default=>1) if !ref $self;
267     my (%dirs);
268     foreach my $file ($self->files($module, $type, @under)) {
269         $dirs{dirname($file)}++;
270     }
271     return sort keys %dirs;
272 }
273
274 sub directory_tree {
275     my ($self, $module, $type, @under) = @_;
276     $self= $self->new(default=>1) if !ref $self;
277     my (%dirs);
278     foreach my $dir ($self->directories($module, $type, @under)) {
279         $dirs{$dir}++;
280         my ($last) = ("");
281         while ($last ne $dir) {
282             $last = $dir;
283             $dir = dirname($dir);
284             last if !$self->_is_under($dir, @under);
285             $dirs{$dir}++;
286         }
287     }
288     return(sort(keys(%dirs)));
289 }
290
291 sub validate {
292     my ($self, $module, $remove) = @_;
293     $self= $self->new(default=>1) if !ref $self;
294     Carp::croak("$module is not installed") if (! exists($self->{$module}));
295     return($self->{$module}{packlist}->validate($remove));
296 }
297
298 sub packlist {
299     my ($self, $module) = @_;
300     $self= $self->new(default=>1) if !ref $self;
301     Carp::croak("$module is not installed") if (! exists($self->{$module}));
302     return($self->{$module}{packlist});
303 }
304
305 sub version {
306     my ($self, $module) = @_;
307     $self= $self->new(default=>1) if !ref $self;
308     Carp::croak("$module is not installed") if (! exists($self->{$module}));
309     return($self->{$module}{version});
310 }
311
312 sub debug_dump {
313     my ($self, $module) = @_;
314     $self= $self->new(default=>1) if !ref $self;
315     local $self->{":private:"}{Config};
316     require Data::Dumper;
317     print Data::Dumper->new([$self])->Sortkeys(1)->Indent(1)->Dump();
318 }
319
320
321 1;
322
323 __END__
324
325 =head1 NAME
326
327 ExtUtils::Installed - Inventory management of installed modules
328
329 =head1 SYNOPSIS
330
331    use ExtUtils::Installed;
332    my ($inst) = ExtUtils::Installed->new( skip_cwd => 1 );
333    my (@modules) = $inst->modules();
334    my (@missing) = $inst->validate("DBI");
335    my $all_files = $inst->files("DBI");
336    my $files_below_usr_local = $inst->files("DBI", "all", "/usr/local");
337    my $all_dirs = $inst->directories("DBI");
338    my $dirs_below_usr_local = $inst->directory_tree("DBI", "prog");
339    my $packlist = $inst->packlist("DBI");
340
341 =head1 DESCRIPTION
342
343 ExtUtils::Installed  provides a standard way to find out what core and module
344 files have been installed.  It uses the information stored in .packlist files
345 created during installation to provide this information.  In addition it
346 provides facilities to classify the installed files and to extract directory
347 information from the .packlist files.
348
349 =head1 USAGE
350
351 The new() function searches for all the installed .packlists on the system, and
352 stores their contents. The .packlists can be queried with the functions
353 described below. Where it searches by default is determined by the settings found
354 in C<%Config::Config>, and what the value is of the PERL5LIB environment variable.
355
356 =head1 METHODS
357
358 Unless specified otherwise all method can be called as class methods, or as object
359 methods. If called as class methods then the "default" object will be used, and if
360 necessary created using the current processes %Config and @INC.  See the
361 'default' option to new() for details.
362
363
364 =over 4
365
366 =item new()
367
368 This takes optional named parameters. Without parameters, this
369 searches for all the installed .packlists on the system using
370 information from C<%Config::Config> and the default module search
371 paths C<@INC>. The packlists are read using the
372 L<ExtUtils::Packlist> module.
373
374 If the named parameter C<skip_cwd> is true, the current directory C<.> will
375 be stripped from C<@INC> before searching for .packlists.  This keeps
376 ExtUtils::Installed from finding modules installed in other perls that
377 happen to be located below the current directory.
378
379 If the named parameter C<config_override> is specified,
380 it should be a reference to a hash which contains all information
381 usually found in C<%Config::Config>. For example, you can obtain
382 the configuration information for a separate perl installation and
383 pass that in.
384
385     my $yoda_cfg  = get_fake_config('yoda');
386     my $yoda_inst =
387                ExtUtils::Installed->new(config_override=>$yoda_cfg);
388
389 Similarly, the parameter C<inc_override> may be a reference to an
390 array which is used in place of the default module search paths
391 from C<@INC>.
392
393     use Config;
394     my @dirs = split(/\Q$Config{path_sep}\E/, $ENV{PERL5LIB});
395     my $p5libs = ExtUtils::Installed->new(inc_override=>\@dirs);
396
397 B<Note>: You probably do not want to use these options alone, almost always
398 you will want to set both together.
399
400 The parameter C<extra_libs> can be used to specify B<additional> paths to
401 search for installed modules. For instance
402
403     my $installed =
404              ExtUtils::Installed->new(extra_libs=>["/my/lib/path"]);
405
406 This should only be necessary if F</my/lib/path> is not in PERL5LIB.
407
408 Finally there is the 'default', and the related 'default_get' and 'default_set'
409 options. These options control the "default" object which is provided by the
410 class interface to the methods. Setting C<default_get> to true tells the constructor
411 to return the default object if it is defined. Setting C<default_set> to true tells
412 the constructor to make the default object the constructed object. Setting the
413 C<default> option is like setting both to true. This is used primarily internally
414 and probably isn't interesting to any real user.
415
416 =item modules()
417
418 This returns a list of the names of all the installed modules.  The perl 'core'
419 is given the special name 'Perl'.
420
421 =item files()
422
423 This takes one mandatory parameter, the name of a module.  It returns a list of
424 all the filenames from the package.  To obtain a list of core perl files, use
425 the module name 'Perl'.  Additional parameters are allowed.  The first is one
426 of the strings "prog", "doc" or "all", to select either just program files,
427 just manual files or all files.  The remaining parameters are a list of
428 directories. The filenames returned will be restricted to those under the
429 specified directories.
430
431 =item directories()
432
433 This takes one mandatory parameter, the name of a module.  It returns a list of
434 all the directories from the package.  Additional parameters are allowed.  The
435 first is one of the strings "prog", "doc" or "all", to select either just
436 program directories, just manual directories or all directories.  The remaining
437 parameters are a list of directories. The directories returned will be
438 restricted to those under the specified directories.  This method returns only
439 the leaf directories that contain files from the specified module.
440
441 =item directory_tree()
442
443 This is identical in operation to directories(), except that it includes all the
444 intermediate directories back up to the specified directories.
445
446 =item validate()
447
448 This takes one mandatory parameter, the name of a module.  It checks that all
449 the files listed in the modules .packlist actually exist, and returns a list of
450 any missing files.  If an optional second argument which evaluates to true is
451 given any missing files will be removed from the .packlist
452
453 =item packlist()
454
455 This returns the ExtUtils::Packlist object for the specified module.
456
457 =item version()
458
459 This returns the version number for the specified module.
460
461 =back
462
463 =head1 EXAMPLE
464
465 See the example in L<ExtUtils::Packlist>.
466
467 =head1 AUTHOR
468
469 Alan Burlison <Alan.Burlison@uk.sun.com>
470
471 =cut