Move Data::Dumper from ext/ to dist/
[perl.git] / ext / 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 = '1.999_001';
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}} = grep { -e $_ && !$dupe{$_}++ }
166             @{$self->{':private:'}{EXTRA}}, @{$self->{':private:'}{INC}};
167     }
168
169     my @dirs= $self->_fix_dirs(@{$self->{':private:'}{LIBDIRS}});
170
171     # Read the core packlist
172     my $archlib = $self->_fix_dirs($self->{':private:'}{Config}{archlibexp});
173     $self->_make_entry("Perl",File::Spec->catfile($archlib, '.packlist'));
174
175     my $root;
176     # Read the module packlists
177     my $sub = sub {
178         # Only process module .packlists
179         return if $_ ne ".packlist" || $File::Find::dir eq $archlib;
180
181         # Hack of the leading bits of the paths & convert to a module name
182         my $module = $File::Find::name;
183         my $found = $module =~ s!^.*?/auto/(.*)/.packlist!$1!s
184             or do {
185             # warn "Woah! \$_=$_\n\$module=$module\n\$File::Find::dir=$File::Find::dir\n",
186             #    join ("\n",@dirs);
187             return;
188         };
189
190         my $modfile = "$module.pm";
191         $module =~ s!/!::!g;
192
193         return if $self->{$module}; #shadowing?
194         $self->_make_entry($module,$File::Find::name,$modfile);
195     };
196     while (@dirs) {
197         $root= shift @dirs;
198         next if !-d $root;
199         find($sub,$root);
200     }
201
202     return $self;
203 }
204
205 # VMS's non-case preserving file-system means the package name can't
206 # be reconstructed from the filename.
207 sub _module_name {
208     my($file, $orig_module) = @_;
209
210     my $module = '';
211     if (open PACKFH, $file) {
212         while (<PACKFH>) {
213             if (/package\s+(\S+)\s*;/) {
214                 my $pack = $1;
215                 # Make a sanity check, that lower case $module
216                 # is identical to lowercase $pack before
217                 # accepting it
218                 if (lc($pack) eq lc($orig_module)) {
219                     $module = $pack;
220                     last;
221                 }
222             }
223         }
224         close PACKFH;
225     }
226
227     print STDERR "Couldn't figure out the package name for $file\n"
228       unless $module;
229
230     return $module;
231 }
232
233 sub modules {
234     my ($self) = @_;
235     $self= $self->new(default=>1) if !ref $self;
236
237     # Bug/feature of sort in scalar context requires this.
238     return wantarray
239         ? sort grep { not /^:private:$/ } keys %$self
240         : grep { not /^:private:$/ } keys %$self;
241 }
242
243 sub files {
244     my ($self, $module, $type, @under) = @_;
245     $self= $self->new(default=>1) if !ref $self;
246
247     # Validate arguments
248     Carp::croak("$module is not installed") if (! exists($self->{$module}));
249     $type = "all" if (! defined($type));
250     Carp::croak('type must be "all", "prog" or "doc"')
251         if ($type ne "all" && $type ne "prog" && $type ne "doc");
252
253     my (@files);
254     foreach my $file (keys(%{$self->{$module}{packlist}})) {
255         push(@files, $file)
256           if ($self->_is_type($file, $type) &&
257               $self->_is_under($file, @under));
258     }
259     return(@files);
260 }
261
262 sub directories {
263     my ($self, $module, $type, @under) = @_;
264     $self= $self->new(default=>1) if !ref $self;
265     my (%dirs);
266     foreach my $file ($self->files($module, $type, @under)) {
267         $dirs{dirname($file)}++;
268     }
269     return sort keys %dirs;
270 }
271
272 sub directory_tree {
273     my ($self, $module, $type, @under) = @_;
274     $self= $self->new(default=>1) if !ref $self;
275     my (%dirs);
276     foreach my $dir ($self->directories($module, $type, @under)) {
277         $dirs{$dir}++;
278         my ($last) = ("");
279         while ($last ne $dir) {
280             $last = $dir;
281             $dir = dirname($dir);
282             last if !$self->_is_under($dir, @under);
283             $dirs{$dir}++;
284         }
285     }
286     return(sort(keys(%dirs)));
287 }
288
289 sub validate {
290     my ($self, $module, $remove) = @_;
291     $self= $self->new(default=>1) if !ref $self;
292     Carp::croak("$module is not installed") if (! exists($self->{$module}));
293     return($self->{$module}{packlist}->validate($remove));
294 }
295
296 sub packlist {
297     my ($self, $module) = @_;
298     $self= $self->new(default=>1) if !ref $self;
299     Carp::croak("$module is not installed") if (! exists($self->{$module}));
300     return($self->{$module}{packlist});
301 }
302
303 sub version {
304     my ($self, $module) = @_;
305     $self= $self->new(default=>1) if !ref $self;
306     Carp::croak("$module is not installed") if (! exists($self->{$module}));
307     return($self->{$module}{version});
308 }
309
310 sub debug_dump {
311     my ($self, $module) = @_;
312     $self= $self->new(default=>1) if !ref $self;
313     local $self->{":private:"}{Config};
314     require Data::Dumper;
315     print Data::Dumper->new([$self])->Sortkeys(1)->Indent(1)->Dump();
316 }
317
318
319 1;
320
321 __END__
322
323 =head1 NAME
324
325 ExtUtils::Installed - Inventory management of installed modules
326
327 =head1 SYNOPSIS
328
329    use ExtUtils::Installed;
330    my ($inst) = ExtUtils::Installed->new();
331    my (@modules) = $inst->modules();
332    my (@missing) = $inst->validate("DBI");
333    my $all_files = $inst->files("DBI");
334    my $files_below_usr_local = $inst->files("DBI", "all", "/usr/local");
335    my $all_dirs = $inst->directories("DBI");
336    my $dirs_below_usr_local = $inst->directory_tree("DBI", "prog");
337    my $packlist = $inst->packlist("DBI");
338
339 =head1 DESCRIPTION
340
341 ExtUtils::Installed  provides a standard way to find out what core and module
342 files have been installed.  It uses the information stored in .packlist files
343 created during installation to provide this information.  In addition it
344 provides facilities to classify the installed files and to extract directory
345 information from the .packlist files.
346
347 =head1 USAGE
348
349 The new() function searches for all the installed .packlists on the system, and
350 stores their contents. The .packlists can be queried with the functions
351 described below. Where it searches by default is determined by the settings found
352 in C<%Config::Config>, and what the value is of the PERL5LIB environment variable.
353
354 =head1 METHODS
355
356 Unless specified otherwise all method can be called as class methods, or as object
357 methods. If called as class methods then the "default" object will be used, and if
358 necessary created using the current processes %Config and @INC.  See the
359 'default' option to new() for details.
360
361
362 =over 4
363
364 =item new()
365
366 This takes optional named parameters. Without parameters, this
367 searches for all the installed .packlists on the system using
368 information from C<%Config::Config> and the default module search
369 paths C<@INC>. The packlists are read using the
370 L<ExtUtils::Packlist> module.
371
372 If the named parameter C<config_override> is specified,
373 it should be a reference to a hash which contains all information
374 usually found in C<%Config::Config>. For example, you can obtain
375 the configuration information for a separate perl installation and
376 pass that in.
377
378     my $yoda_cfg  = get_fake_config('yoda');
379     my $yoda_inst = ExtUtils::Installed->new(config_override=>$yoda_cfg);
380
381 Similarly, the parameter C<inc_override> may be a reference to an
382 array which is used in place of the default module search paths
383 from C<@INC>.
384
385     use Config;
386     my @dirs = split(/\Q$Config{path_sep}\E/, $ENV{PERL5LIB});
387     my $p5libs = ExtUtils::Installed->new(inc_override=>\@dirs);
388
389 B<Note>: You probably do not want to use these options alone, almost always
390 you will want to set both together.
391
392 The parameter c<extra_libs> can be used to specify B<additional> paths to
393 search for installed modules. For instance
394
395     my $installed = ExtUtils::Installed->new(extra_libs=>["/my/lib/path"]);
396
397 This should only be necessary if C</my/lib/path> is not in PERL5LIB.
398
399 Finally there is the 'default', and the related 'default_get' and 'default_set'
400 options. These options control the "default" object which is provided by the
401 class interface to the methods. Setting C<default_get> to true tells the constructor
402 to return the default object if it is defined. Setting C<default_set> to true tells
403 the constructor to make the default object the constructed object. Setting the
404 C<default> option is like setting both to true. This is used primarily internally
405 and probably isn't interesting to any real user.
406
407 =item modules()
408
409 This returns a list of the names of all the installed modules.  The perl 'core'
410 is given the special name 'Perl'.
411
412 =item files()
413
414 This takes one mandatory parameter, the name of a module.  It returns a list of
415 all the filenames from the package.  To obtain a list of core perl files, use
416 the module name 'Perl'.  Additional parameters are allowed.  The first is one
417 of the strings "prog", "doc" or "all", to select either just program files,
418 just manual files or all files.  The remaining parameters are a list of
419 directories. The filenames returned will be restricted to those under the
420 specified directories.
421
422 =item directories()
423
424 This takes one mandatory parameter, the name of a module.  It returns a list of
425 all the directories from the package.  Additional parameters are allowed.  The
426 first is one of the strings "prog", "doc" or "all", to select either just
427 program directories, just manual directories or all directories.  The remaining
428 parameters are a list of directories. The directories returned will be
429 restricted to those under the specified directories.  This method returns only
430 the leaf directories that contain files from the specified module.
431
432 =item directory_tree()
433
434 This is identical in operation to directories(), except that it includes all the
435 intermediate directories back up to the specified directories.
436
437 =item validate()
438
439 This takes one mandatory parameter, the name of a module.  It checks that all
440 the files listed in the modules .packlist actually exist, and returns a list of
441 any missing files.  If an optional second argument which evaluates to true is
442 given any missing files will be removed from the .packlist
443
444 =item packlist()
445
446 This returns the ExtUtils::Packlist object for the specified module.
447
448 =item version()
449
450 This returns the version number for the specified module.
451
452 =back
453
454 =head1 EXAMPLE
455
456 See the example in L<ExtUtils::Packlist>.
457
458 =head1 AUTHOR
459
460 Alan Burlison <Alan.Burlison@uk.sun.com>
461
462 =cut