1use strict;
2package ExtUtils::Installed;
3
4#use warnings; # XXX requires 5.6
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
18our $VERSION = '2.22';
19$VERSION = eval $VERSION;
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    # Unix path normalization.
31    $prefix = File::Spec->canonpath($prefix);
32
33    return 1 if substr($path, 0, length($prefix)) eq $prefix;
34
35    if ($DOSISH) {
36        $path =~ s|\\|/|g;
37        $prefix =~ s|\\|/|g;
38        return 1 if $path =~ m{^\Q$prefix\E}i;
39    }
40    return(0);
41}
42
43sub _is_doc {
44    my ($self, $path) = @_;
45
46    my $man1dir = $self->{':private:'}{Config}{man1direxp};
47    my $man3dir = $self->{':private:'}{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    my $conf= $self->{':private:'}{Config};
60    if ($type eq "prog") {
61        return($self->_is_prefix($path, $conf->{prefix} || $conf->{prefixexp})
62               && !($self->_is_doc($path)) ? 1 : 0);
63    }
64    return(0);
65}
66
67sub _is_under {
68    my ($self, $path, @under) = @_;
69    $under[0] = "" if (! @under);
70    foreach my $dir (@under) {
71        return(1) if ($self->_is_prefix($path, $dir));
72    }
73
74    return(0);
75}
76
77sub _fix_dirs {
78    my ($self, @dirs)= @_;
79    # File::Find does not know how to deal with VMS filepaths.
80    if( $Is_VMS ) {
81        $_ = VMS::Filespec::unixify($_)
82            for @dirs;
83    }
84
85    if ($DOSISH) {
86        s|\\|/|g for @dirs;
87    }
88    return wantarray ? @dirs : $dirs[0];
89}
90
91sub _make_entry {
92    my ($self, $module, $packlist_file, $modfile)= @_;
93
94    my $data= {
95        module => $module,
96        packlist => scalar(ExtUtils::Packlist->new($packlist_file)),
97        packlist_file => $packlist_file,
98    };
99
100    if (!$modfile) {
101        $data->{version} = $self->{':private:'}{Config}{version};
102    } else {
103        $data->{modfile} = $modfile;
104        # Find the top-level module file in @INC
105        $data->{version} = '';
106        foreach my $dir (@{$self->{':private:'}{INC}}) {
107            my $p = File::Spec->catfile($dir, $modfile);
108            if (-r $p) {
109                $module = _module_name($p, $module) if $Is_VMS;
110
111                $data->{version} = MM->parse_version($p);
112                $data->{version_from} = $p;
113                $data->{packlist_valid} = exists $data->{packlist}{$p};
114                last;
115            }
116        }
117    }
118    $self->{$module}= $data;
119}
120
121our $INSTALLED;
122sub new {
123    my ($class) = shift(@_);
124    $class = ref($class) || $class;
125
126    my %args = @_;
127
128    return $INSTALLED if $INSTALLED and ($args{default_get} || $args{default});
129
130    my $self = bless {}, $class;
131
132    $INSTALLED= $self if $args{default_set} || $args{default};
133
134
135    if ($args{config_override}) {
136        eval {
137            $self->{':private:'}{Config} = { %{$args{config_override}} };
138        } or Carp::croak(
139            "The 'config_override' parameter must be a hash reference."
140        );
141    }
142    else {
143        $self->{':private:'}{Config} = \%Config;
144    }
145
146    for my $tuple ([inc_override => INC => [ @INC ] ],
147                   [ extra_libs => EXTRA => [] ])
148    {
149        my ($arg,$key,$val)=@$tuple;
150        if ( $args{$arg} ) {
151            eval {
152                $self->{':private:'}{$key} = [ @{$args{$arg}} ];
153            } or Carp::croak(
154                "The '$arg' parameter must be an array reference."
155            );
156        }
157        elsif ($val) {
158            $self->{':private:'}{$key} = $val;
159        }
160    }
161    {
162        my %dupe;
163        @{$self->{':private:'}{LIBDIRS}} =
164            grep { $_ ne '.' || ! $args{skip_cwd} }
165            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.
207sub _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
233sub 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
243sub 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
262sub 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
272sub 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
289sub 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
296sub 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
303sub 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
310sub _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
3191;
320
321__END__
322
323=head1 NAME
324
325ExtUtils::Installed - Inventory management of installed modules
326
327=head1 SYNOPSIS
328
329   use ExtUtils::Installed;
330   my ($inst) = ExtUtils::Installed->new( skip_cwd => 1 );
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
341ExtUtils::Installed  provides a standard way to find out what core and module
342files have been installed.  It uses the information stored in .packlist files
343created during installation to provide this information.  In addition it
344provides facilities to classify the installed files and to extract directory
345information from the .packlist files.
346
347=head1 USAGE
348
349The new() function searches for all the installed .packlists on the system, and
350stores their contents. The .packlists can be queried with the functions
351described below. Where it searches by default is determined by the settings found
352in C<%Config::Config>, and what the value is of the PERL5LIB environment variable.
353
354=head1 METHODS
355
356Unless specified otherwise all method can be called as class methods, or as object
357methods. If called as class methods then the "default" object will be used, and if
358necessary 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
366This takes optional named parameters. Without parameters, this
367searches for all the installed .packlists on the system using
368information from C<%Config::Config> and the default module search
369paths C<@INC>. The packlists are read using the
370L<ExtUtils::Packlist> module.
371
372If the named parameter C<skip_cwd> is true, the current directory C<.> will
373be stripped from C<@INC> before searching for .packlists.  This keeps
374ExtUtils::Installed from finding modules installed in other perls that
375happen to be located below the current directory.
376
377If the named parameter C<config_override> is specified,
378it should be a reference to a hash which contains all information
379usually found in C<%Config::Config>. For example, you can obtain
380the configuration information for a separate perl installation and
381pass that in.
382
383    my $yoda_cfg  = get_fake_config('yoda');
384    my $yoda_inst =
385               ExtUtils::Installed->new(config_override=>$yoda_cfg);
386
387Similarly, the parameter C<inc_override> may be a reference to an
388array which is used in place of the default module search paths
389from C<@INC>.
390
391    use Config;
392    my @dirs = split(/\Q$Config{path_sep}\E/, $ENV{PERL5LIB});
393    my $p5libs = ExtUtils::Installed->new(inc_override=>\@dirs);
394
395B<Note>: You probably do not want to use these options alone, almost always
396you will want to set both together.
397
398The parameter C<extra_libs> can be used to specify B<additional> paths to
399search for installed modules. For instance
400
401    my $installed =
402             ExtUtils::Installed->new(extra_libs=>["/my/lib/path"]);
403
404This should only be necessary if F</my/lib/path> is not in PERL5LIB.
405
406Finally there is the 'default', and the related 'default_get' and 'default_set'
407options. These options control the "default" object which is provided by the
408class interface to the methods. Setting C<default_get> to true tells the constructor
409to return the default object if it is defined. Setting C<default_set> to true tells
410the constructor to make the default object the constructed object. Setting the
411C<default> option is like setting both to true. This is used primarily internally
412and probably isn't interesting to any real user.
413
414=item modules()
415
416This returns a list of the names of all the installed modules.  The perl 'core'
417is given the special name 'Perl'.
418
419=item files()
420
421This takes one mandatory parameter, the name of a module.  It returns a list of
422all the filenames from the package.  To obtain a list of core perl files, use
423the module name 'Perl'.  Additional parameters are allowed.  The first is one
424of the strings "prog", "doc" or "all", to select either just program files,
425just manual files or all files.  The remaining parameters are a list of
426directories. The filenames returned will be restricted to those under the
427specified directories.
428
429=item directories()
430
431This takes one mandatory parameter, the name of a module.  It returns a list of
432all the directories from the package.  Additional parameters are allowed.  The
433first is one of the strings "prog", "doc" or "all", to select either just
434program directories, just manual directories or all directories.  The remaining
435parameters are a list of directories. The directories returned will be
436restricted to those under the specified directories.  This method returns only
437the leaf directories that contain files from the specified module.
438
439=item directory_tree()
440
441This is identical in operation to directories(), except that it includes all the
442intermediate directories back up to the specified directories.
443
444=item validate()
445
446This takes one mandatory parameter, the name of a module.  It checks that all
447the files listed in the modules .packlist actually exist, and returns a list of
448any missing files.  If an optional second argument which evaluates to true is
449given any missing files will be removed from the .packlist
450
451=item packlist()
452
453This returns the ExtUtils::Packlist object for the specified module.
454
455=item version()
456
457This returns the version number for the specified module.
458
459=back
460
461=head1 EXAMPLE
462
463See the example in L<ExtUtils::Packlist>.
464
465=head1 AUTHOR
466
467Alan Burlison <Alan.Burlison@uk.sun.com>
468
469=cut
470