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