lib/ExtUtils/Installed.pm

package ExtUtils::Installed;

use 5.00503;
use strict;
use Carp qw();
use ExtUtils::Packlist;
use ExtUtils::MakeMaker;
use Config;
use File::Find;
use File::Basename;
use File::Spec;

my $Is_VMS = $^O eq 'VMS';
my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/);

require VMS::Filespec if $Is_VMS;

use vars qw($VERSION);
$VERSION = '0.08';

sub _is_prefix {
    my ($self, $path, $prefix) = @_;
    return unless defined $prefix && defined $path;

    if( $Is_VMS ) {
        $prefix = VMS::Filespec::unixify($prefix);
        $path   = VMS::Filespec::unixify($path);
    }

    # Sloppy Unix path normalization.
    $prefix =~ s{/+}{/}g;
    $path   =~ s{/+}{/}g;

    return 1 if substr($path, 0, length($prefix)) eq $prefix;

    if ($DOSISH) {
        $path =~ s|\\|/|g;
        $prefix =~ s|\\|/|g;
        return 1 if $path =~ m{^\Q$prefix\E}i;
    }
    return(0);
}

sub _is_doc { 
    my ($self, $path) = @_;
    my $man1dir = $Config{man1direxp};
    my $man3dir = $Config{man3direxp};
    return(($man1dir && $self->_is_prefix($path, $man1dir))
           ||
           ($man3dir && $self->_is_prefix($path, $man3dir))
           ? 1 : 0)
}
 
sub _is_type {
    my ($self, $path, $type) = @_;
    return 1 if $type eq "all";

    return($self->_is_doc($path)) if $type eq "doc";

    if ($type eq "prog") {
        return($self->_is_prefix($path, $Config{prefix} || $Config{prefixexp})
               &&
               !($self->_is_doc($path))
               ? 1 : 0);
    }
    return(0);
}

sub _is_under {
    my ($self, $path, @under) = @_;
    $under[0] = "" if (! @under);
    foreach my $dir (@under) {
        return(1) if ($self->_is_prefix($path, $dir));
    }

    return(0);
}

sub new {
    my ($class) = @_;
    $class = ref($class) || $class;
    my $self = {};

    my $archlib = $Config{archlibexp};
    my $sitearch = $Config{sitearchexp};

    # File::Find does not know how to deal with VMS filepaths.
    if( $Is_VMS ) {
        $archlib  = VMS::Filespec::unixify($archlib);
        $sitearch = VMS::Filespec::unixify($sitearch);
    }

    if ($DOSISH) {
        $archlib =~ s|\\|/|g;
        $sitearch =~ s|\\|/|g;
    }

    # Read the core packlist
    $self->{Perl}{packlist} =
      ExtUtils::Packlist->new( File::Spec->catfile($archlib, '.packlist') );
    $self->{Perl}{version} = $Config{version};

    # Read the module packlists
    my $sub = sub {
        # Only process module .packlists
        return if $_ ne ".packlist" || $File::Find::dir eq $archlib;

        # Hack of the leading bits of the paths & convert to a module name
        my $module = $File::Find::name;

        $module =~ s!\Q$archlib\E/?auto/(.*)/.packlist!$1!s  or
        $module =~ s!\Q$sitearch\E/?auto/(.*)/.packlist!$1!s;
        my $modfile = "$module.pm";
        $module =~ s!/!::!g;

        # Find the top-level module file in @INC
        $self->{$module}{version} = '';
        foreach my $dir (@INC) {
            my $p = File::Spec->catfile($dir, $modfile);
            if (-r $p) {
                $module = _module_name($p, $module) if $Is_VMS;

                require ExtUtils::MM;
                $self->{$module}{version} = MM->parse_version($p);
                last;
            }
        }

        # Read the .packlist
        $self->{$module}{packlist} = 
          ExtUtils::Packlist->new($File::Find::name);
    };

    my(@dirs) = grep { -e } ($archlib, $sitearch);
    find($sub, @dirs) if @dirs;

    return(bless($self, $class));
}

# VMS's non-case preserving file-system means the package name can't
# be reconstructed from the filename.
sub _module_name {
    my($file, $orig_module) = @_;

    my $module = '';
    if (open PACKFH, $file) {
        while (<PACKFH>) {
            if (/package\s+(\S+)\s*;/) {
                my $pack = $1;
                # Make a sanity check, that lower case $module
                # is identical to lowercase $pack before
                # accepting it
                if (lc($pack) eq lc($orig_module)) {
                    $module = $pack;
                    last;
                }
            }
        }
        close PACKFH;
    }

    print STDERR "Couldn't figure out the package name for $file\n"
      unless $module;

    return $module;
}


sub modules {
    my ($self) = @_;

    # Bug/feature of sort in scalar context requires this.
    return wantarray ? sort keys %$self : keys %$self;
}

sub files {
    my ($self, $module, $type, @under) = @_;

    # Validate arguments
    Carp::croak("$module is not installed") if (! exists($self->{$module}));
    $type = "all" if (! defined($type));
    Carp::croak('type must be "all", "prog" or "doc"')
        if ($type ne "all" && $type ne "prog" && $type ne "doc");

    my (@files);
    foreach my $file (keys(%{$self->{$module}{packlist}})) {
        push(@files, $file)
          if ($self->_is_type($file, $type) && 
              $self->_is_under($file, @under));
    }
    return(@files);
}

sub directories {
    my ($self, $module, $type, @under) = @_;
    my (%dirs);
    foreach my $file ($self->files($module, $type, @under)) {
        $dirs{dirname($file)}++;
    }
    return sort keys %dirs;
}

sub directory_tree {
    my ($self, $module, $type, @under) = @_;
    my (%dirs);
    foreach my $dir ($self->directories($module, $type, @under)) {
        $dirs{$dir}++;
        my ($last) = ("");
        while ($last ne $dir) {
            $last = $dir;
            $dir = dirname($dir);
            last if !$self->_is_under($dir, @under);
            $dirs{$dir}++;
        }
    }
    return(sort(keys(%dirs)));
}

sub validate {
    my ($self, $module, $remove) = @_;
    Carp::croak("$module is not installed") if (! exists($self->{$module}));
    return($self->{$module}{packlist}->validate($remove));
}

sub packlist {
    my ($self, $module) = @_;
    Carp::croak("$module is not installed") if (! exists($self->{$module}));
    return($self->{$module}{packlist});
}

sub version {
    my ($self, $module) = @_;
    Carp::croak("$module is not installed") if (! exists($self->{$module}));
    return($self->{$module}{version});
}


1;

__END__

=head1 NAME

ExtUtils::Installed - Inventory management of installed modules

=head1 SYNOPSIS

   use ExtUtils::Installed;
   my ($inst) = ExtUtils::Installed->new();
   my (@modules) = $inst->modules();
   my (@missing) = $inst->validate("DBI");
   my $all_files = $inst->files("DBI");
   my $files_below_usr_local = $inst->files("DBI", "all", "/usr/local");
   my $all_dirs = $inst->directories("DBI");
   my $dirs_below_usr_local = $inst->directory_tree("DBI", "prog");
   my $packlist = $inst->packlist("DBI");

=head1 DESCRIPTION

ExtUtils::Installed  provides a standard way to find out what core and module
files have been installed.  It uses the information stored in .packlist files
created during installation to provide this information.  In addition it
provides facilities to classify the installed files and to extract directory
information from the .packlist files.

=head1 USAGE

The new() function searches for all the installed .packlists on the system, and
stores their contents. The .packlists can be queried with the functions
described below.

=head1 FUNCTIONS

=over 4

=item new()

This takes no parameters, and searches for all the installed .packlists on the
system.  The packlists are read using the ExtUtils::packlist module.

=item modules()

This returns a list of the names of all the installed modules.  The perl 'core'
is given the special name 'Perl'.

=item files()

This takes one mandatory parameter, the name of a module.  It returns a list of
all the filenames from the package.  To obtain a list of core perl files, use
the module name 'Perl'.  Additional parameters are allowed.  The first is one
of the strings "prog", "doc" or "all", to select either just program files,
just manual files or all files.  The remaining parameters are a list of
directories. The filenames returned will be restricted to those under the
specified directories.

=item directories()

This takes one mandatory parameter, the name of a module.  It returns a list of
all the directories from the package.  Additional parameters are allowed.  The
first is one of the strings "prog", "doc" or "all", to select either just
program directories, just manual directories or all directories.  The remaining
parameters are a list of directories. The directories returned will be
restricted to those under the specified directories.  This method returns only
the leaf directories that contain files from the specified module.

=item directory_tree()

This is identical in operation to directories(), except that it includes all the
intermediate directories back up to the specified directories.

=item validate()

This takes one mandatory parameter, the name of a module.  It checks that all
the files listed in the modules .packlist actually exist, and returns a list of
any missing files.  If an optional second argument which evaluates to true is
given any missing files will be removed from the .packlist

=item packlist()

This returns the ExtUtils::Packlist object for the specified module.

=item version()

This returns the version number for the specified module.

=back

=head1 EXAMPLE

See the example in L<ExtUtils::Packlist>.

=head1 AUTHOR

Alan Burlison <Alan.Burlison@uk.sun.com>

=cut
Revision:	1.1
Committed:	Thu Jun 30 14:27:10 2005 UTC (21 years, 4 months ago) by root
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.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 = '0.08';
20
21			sub _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
44			sub _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
54			sub _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
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 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.
142			sub _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
170			sub 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
177			sub 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
195			sub 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
204			sub 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
220			sub 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
226			sub packlist {
227			my ($self, $module) = @_;
228			Carp::croak("$module is not installed") if (! exists($self->{$module}));
229			return($self->{$module}{packlist});
230			}
231
232			sub version {
233			my ($self, $module) = @_;
234			Carp::croak("$module is not installed") if (! exists($self->{$module}));
235			return($self->{$module}{version});
236			}
237
238
239			1;
240
241			__END__
242
243			=head1 NAME
244
245			ExtUtils::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
261			ExtUtils::Installed provides a standard way to find out what core and module
262			files have been installed. It uses the information stored in .packlist files
263			created during installation to provide this information. In addition it
264			provides facilities to classify the installed files and to extract directory
265			information from the .packlist files.
266
267			=head1 USAGE
268
269			The new() function searches for all the installed .packlists on the system, and
270			stores their contents. The .packlists can be queried with the functions
271			described below.
272
273			=head1 FUNCTIONS
274
275			=over 4
276
277			=item new()
278
279			This takes no parameters, and searches for all the installed .packlists on the
280			system. The packlists are read using the ExtUtils::packlist module.
281
282			=item modules()
283
284			This returns a list of the names of all the installed modules. The perl 'core'
285			is given the special name 'Perl'.
286
287			=item files()
288
289			This takes one mandatory parameter, the name of a module. It returns a list of
290			all the filenames from the package. To obtain a list of core perl files, use
291			the module name 'Perl'. Additional parameters are allowed. The first is one
292			of the strings "prog", "doc" or "all", to select either just program files,
293			just manual files or all files. The remaining parameters are a list of
294			directories. The filenames returned will be restricted to those under the
295			specified directories.
296
297			=item directories()
298
299			This takes one mandatory parameter, the name of a module. It returns a list of
300			all the directories from the package. Additional parameters are allowed. The
301			first is one of the strings "prog", "doc" or "all", to select either just
302			program directories, just manual directories or all directories. The remaining
303			parameters are a list of directories. The directories returned will be
304			restricted to those under the specified directories. This method returns only
305			the leaf directories that contain files from the specified module.
306
307			=item directory_tree()
308
309			This is identical in operation to directories(), except that it includes all the
310			intermediate directories back up to the specified directories.
311
312			=item validate()
313
314			This takes one mandatory parameter, the name of a module. It checks that all
315			the files listed in the modules .packlist actually exist, and returns a list of
316			any missing files. If an optional second argument which evaluates to true is
317			given any missing files will be removed from the .packlist
318
319			=item packlist()
320
321			This returns the ExtUtils::Packlist object for the specified module.
322
323			=item version()
324
325			This returns the version number for the specified module.
326
327			=back
328
329			=head1 EXAMPLE
330
331			See the example in L<ExtUtils::Packlist>.
332
333			=head1 AUTHOR
334
335			Alan Burlison <Alan.Burlison@uk.sun.com>
336
337			=cut