lib/ExtUtils/Command.pm Utilities for Make on non-UNIX platforms
lib/ExtUtils/Embed.pm Utilities for embedding Perl in C programs
lib/ExtUtils/Install.pm Handles 'make install' on extensions
+lib/ExtUtils/Installed.pm Information on installed extensions
lib/ExtUtils/Liblist.pm Locates libraries
lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2
lib/ExtUtils/MM_Unix.pm MakeMaker base class for Unix
lib/ExtUtils/Manifest.pm Utilities to write MANIFEST files
lib/ExtUtils/Mkbootstrap.pm Writes a bootstrap file (see MakeMaker)
lib/ExtUtils/Mksymlists.pm Writes a linker options file for extensions
+lib/ExtUtils/inst Give information about installed extensions
lib/ExtUtils/testlib.pm Fixes up @INC to use just-built extension
lib/ExtUtils/typemap Extension interface types
lib/ExtUtils/xsubpp External subroutine preprocessor
use Config;
use Getopt::Long;
use File::Find;
+use File::Copy;
use File::Path qw(mkpath);
+use ExtUtils::Packlist;
use subs qw(unlink chmod rename link);
+use vars qw($packlist);
require Cwd;
umask 022;
-x "t/perl$Config{exe_ext}" || warn "WARNING: You've never run 'make test'!!!",
" (Installing anyway.)\n";
+$packlist = ExtUtils::Packlist->new("$Config{installarchlib}/.packlist");
+
# Install the main pod pages.
runpod2man('pod', $man1dir, $man1ext);
}
}
+$packlist->write() unless $notify;
print STDERR " Installation complete\n";
exit 0;
}
sub link {
- local($from,$to) = @_;
+ my($from,$to) = @_;
+ my($success) = 0;
print STDERR " ln $from $to\n";
- eval { CORE::link($from,$to) }
-|| system('cp', $from, $to) == 0
-|| warn "Couldn't link $from to $to: $!\n" unless $notify;
+ eval {
+ CORE::link($from, $to)
+ ? $success++
+ : ($from =~ m#^/afs/# || $to =~ m#^/afs/#)
+ ? die "AFS" # okay inside eval {}
+ : warn "Couldn't link $from to $to: $!\n"
+ unless $notify;
+ $packlist->{$to} = { type => 'file' };
+ };
+ if ($@) {
+ File::Copy::copy($from, $to)
+ ? $success++
+ : warn "Couldn't copy $from to $to: $!\n"
+ unless $notify;
+ $packlist->{$to} = { type => 'file' };
+ }
+ $success;
}
sub rename {
}
link($from,$to) || return 0;
unlink($from);
+ $packlist->{$to} = { type => 'file' };
}
sub chmod {
use File::Compare;
use File::Copy ();
use File::Path ();
+use ExtUtils::Packlist;
use Config;
use subs qw(unlink link chmod);
+use vars qw($packlist);
# override the ones in the rest of the script
sub mkpath {
chmod(0755, "$installbin/perl.$dlext");
}
+# This will be used to store the packlist
+$packlist = ExtUtils::Packlist->new("$installarchlib/.packlist");
+
# First we install the version-numbered executables.
if ($^O ne 'dos') {
# Link perldiag.pod into archlib
my ($from, $to) = ("${installprivlib}/pod/perldiag.pod",
"${installarchlib}/pod/perldiag.pod");
+ $packlist->{$to} = { from => $from, type => 'link' };
if (compare($from, $to) || $nonono) {
mkpath("${installarchlib}/pod", 1, 0777);
unlink($to);
}
+$packlist->write() unless $nono;
print STDERR " Installation complete\n";
exit 0;
? die "AFS" # okay inside eval {}
: warn "Couldn't link $from to $to: $!\n"
unless $nonono;
+ $packlist->{$to} = { from => $from, type => 'link' };
};
if ($@) {
File::Copy::copy($from, $to)
? $success++
: warn "Couldn't copy $from to $to: $!\n"
unless $nonono;
+ $packlist->{$to} = { type => 'file' };
}
$success;
}
File::Copy::copy($from, $to)
|| warn "Couldn't copy $from to $to: $!\n"
unless $nonono;
+ $packlist->{$to} = { type => 'file' };
}
sub samepath {
#This might not work because $archname might have changed.
unlink("$installarchlib/$name");
}
+ $packlist->{"$installlib/$name"} = { type => 'file' };
if (compare($_, "$installlib/$name") || $nonono) {
unlink("$installlib/$name");
mkpath("$installlib/$dir", 1, 0777);
sub copy_if_diff {
my($from,$to)=@_;
-f $from || die "$0: $from not found";
+ $packlist->{$to} = { type => 'file' };
if (compare($from, $to) || $nonono) {
safe_unlink($to); # In case we don't have write permissions.
if ($nonono) {
use Cwd qw(cwd);
use ExtUtils::MakeMaker; # to implement a MY class
+ use ExtUtils::Packlist;
use File::Basename qw(dirname);
use File::Copy qw(copy);
use File::Find qw(find);
use File::Compare qw(compare);
my(%hash) = %$hash;
- my(%pack, %write, $dir, $warn_permissions);
+ my(%pack, $dir, $warn_permissions);
+ my($packlist) = ExtUtils::Packlist->new();
# -w doesn't work reliably on FAT dirs
$warn_permissions++ if $^O eq 'MSWin32';
- local(*DIR, *P);
+ local(*DIR);
for (qw/read write/) {
$pack{$_}=$hash{$_};
delete $hash{$_};
}
closedir DIR;
}
- if (-f $pack{"read"}) {
- open P, $pack{"read"} or Carp::croak("Couldn't read $pack{'read'}");
- # Remember what you found
- while (<P>) {
- chomp;
- $write{$_}++;
- }
- close P;
- }
+ $packlist->read($pack{"read"}) if (-f $pack{"read"});
my $cwd = cwd();
my $umask = umask 0 unless $Is_VMS;
} else {
inc_uninstall($_,$File::Find::dir,$verbose,0); # nonono set to 0
}
- $write{$targetfile}++;
+ $packlist->{$targetfile}++;
}, ".");
chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
$dir = dirname($pack{'write'});
mkpath($dir,0,0755);
print "Writing $pack{'write'}\n";
- open P, ">$pack{'write'}" or Carp::croak("Couldn't write $pack{'write'}: $!");
- for (sort keys %write) {
- print P "$_\n";
- }
- close P;
+ $packlist->write($pack{'write'});
}
}
}
sub uninstall {
+ use ExtUtils::Packlist;
my($fil,$verbose,$nonono) = @_;
die "no packlist file found: $fil" unless -f $fil;
# my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
# require $my_req; # Hairy, but for the first
- local *P;
- open P, $fil or Carp::croak("uninstall: Could not read packlist " .
- "file $fil: $!");
- while (<P>) {
+ my ($packlist) = ExtUtils::Packlist->new($fil);
+ foreach (sort(keys(%$packlist))) {
chomp;
print "unlink $_\n" if $verbose;
forceunlink($_) unless $nonono;
--- /dev/null
+package ExtUtils::Installed;
+use strict;
+use Carp qw();
+use ExtUtils::Packlist;
+use ExtUtils::MakeMaker;
+use Config;
+use File::Find;
+use File::Basename;
+use vars qw($VERSION);
+$VERSION = '0.01';
+
+sub _is_type($$$)
+{
+my ($self, $path, $type) = @_;
+return(1) if ($type eq "all");
+if ($type eq "doc")
+ {
+ return(substr($path, 0, length($Config{installman1dir}))
+ eq $Config{installman1dir}
+ ||
+ substr($path, 0, length($Config{installman3dir}))
+ eq $Config{installman3dir}
+ ? 1 : 0)
+ }
+if ($type eq "prog")
+ {
+ return(substr($path, 0, length($Config{prefix})) eq $Config{prefix}
+ &&
+ substr($path, 0, length($Config{installman1dir}))
+ ne $Config{installman1dir}
+ &&
+ substr($path, 0, length($Config{installman3dir}))
+ ne $Config{installman3dir}
+ ? 1 : 0);
+ }
+return(0);
+}
+
+sub _is_under($$;)
+{
+my ($self, $path, @under) = @_;
+$under[0] = "" if (! @under);
+foreach my $dir (@under)
+ {
+ return(1) if (substr($path, 0, length($dir)) eq $dir);
+ }
+return(0);
+}
+
+sub new($)
+{
+my ($class) = @_;
+$class = ref($class) || $class;
+my $self = {};
+
+# Read the core packlist
+$self->{Perl}{packlist} =
+ ExtUtils::Packlist->new("$Config{installarchlib}/.packlist");
+$self->{Perl}{version} = $];
+
+# Read the module packlists
+my $sub = sub
+ {
+ # Only process module .packlists
+ return if ($_) ne ".packlist" || $File::Find::dir eq $Config{installarchlib};
+
+ # Hack of the leading bits of the paths & convert to a module name
+ my $module = $File::Find::name;
+ $module =~ s!$Config{archlib}/auto/(.*)/.packlist!$1!;
+ $module =~ s!$Config{sitearch}/auto/(.*)/.packlist!$1!;
+ my $modfile = "$module.pm";
+ $module =~ s!/!::!g;
+
+ # Find the top-level module file in @INC
+ $self->{$module}{version} = '';
+ foreach my $dir (@INC)
+ {
+ my $p = MM->catfile($dir, $modfile);
+ if (-f $p)
+ {
+ $self->{$module}{version} = MM->parse_version($p);
+ last;
+ }
+ }
+
+ # Read the .packlist
+ $self->{$module}{packlist} = ExtUtils::Packlist->new($File::Find::name);
+ };
+find($sub, $Config{archlib}, $Config{sitearch});
+
+return(bless($self, $class));
+}
+
+sub modules($)
+{
+my ($self) = @_;
+return(sort(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});
+}
+
+sub DESTROY
+{
+}
+
+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
+
+=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", "man" 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", "man" 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 directory(), 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 AUTHOR
+
+Alan Burlison <Alan.Burlison@uk.sun.com>
+
+=cut
# ';
sub catdir {
- shift;
+ my $self = shift @_;
my @args = @_;
for (@args) {
# append a slash to each argument unless it has one there
$_ .= "/" if $_ eq '' or substr($_,-1) ne "/";
}
- my $result = join('', @args);
- # remove a trailing slash unless we are root
- substr($result,-1) = ""
- if length($result) > 1 && substr($result,-1) eq "/";
- $result;
+ $self->canonpath(join('', @args));
}
=item catfile
sub catfile {
my $self = shift @_;
my $file = pop @_;
- return $file unless @_;
+ return $self->canonpath($file) unless @_;
my $dir = $self->catdir(@_);
for ($dir) {
$_ .= "/" unless substr($_,length($_)-1,1) eq "/";
}
- return $dir.$file;
+ return $self->canonpath($dir.$file);
}
=item curdir
--- /dev/null
+#!/usr/local/bin/perl -w
+
+use strict;
+use IO::File;
+use ExtUtils::Packlist;
+use ExtUtils::Installed;
+
+use vars qw($Inst @Modules);
+
+################################################################################
+
+sub do_module($)
+{
+my ($module) = @_;
+my $help = <<EOF;
+Available commands are:
+ f [all|prog|doc] - List installed files of a given type
+ d [all|prog|doc] - List the directories used by a module
+ v - Validate the .packlist - check for missing files
+ t <tarfile> - Create a tar archive of the module
+ q - Quit the module
+EOF
+print($help);
+while (1)
+ {
+ print("$module cmd? ");
+ my $reply = <STDIN>; chomp($reply);
+ CASE:
+ {
+ $reply =~ /^f\s*/ and do
+ {
+ my $class = (split(' ', $reply))[1];
+ $class = 'all' if (! $class);
+ my @files;
+ if (eval { @files = $Inst->files($module, $class); })
+ {
+ print("$class files in $module are:\n ",
+ join("\n ", @files), "\n");
+ last CASE;
+ }
+ else
+ { print($@); }
+ };
+ $reply =~ /^d\s*/ and do
+ {
+ my $class = (split(' ', $reply))[1];
+ $class = 'all' if (! $class);
+ my @dirs;
+ if (eval { @dirs = $Inst->directories($module, $class); })
+ {
+ print("$class directories in $module are:\n ",
+ join("\n ", @dirs), "\n");
+ last CASE;
+ }
+ else
+ { print($@); }
+ };
+ $reply =~ /^t\s*/ and do
+ {
+ my $file = (split(' ', $reply))[1];
+ my $tmp = "/tmp/inst.$$";
+ if (my $fh = IO::File->new($tmp, "w"))
+ {
+ $fh->print(join("\n", $Inst->files($module)));
+ $fh->close();
+ system("tar cvf $file -I $tmp");
+ unlink($tmp);
+ last CASE;
+ }
+ else { print("Can't open $file: $!\n"); }
+ last CASE;
+ };
+ $reply eq 'v' and do
+ {
+ if (my @missing = $Inst->validate($module))
+ {
+ print("Files missing from $module are:\n ",
+ join("\n ", @missing), "\n");
+ }
+ else
+ {
+ print("$module has no missing files\n");
+ }
+ last CASE;
+ };
+ $reply eq 'q' and do
+ {
+ return;
+ };
+ # Default
+ print($help);
+ }
+ }
+}
+
+################################################################################
+
+sub toplevel()
+{
+my $help = <<EOF;
+Available commands are:
+ l - List all installed modules
+ m <module> - Select a module
+ q - Quit the program
+EOF
+print($help);
+while (1)
+ {
+ print("cmd? ");
+ my $reply = <STDIN>; chomp($reply);
+ CASE:
+ {
+ $reply eq 'l' and do
+ {
+ print("Installed modules are:\n ", join("\n ", @Modules), "\n");
+ last CASE;
+ };
+ $reply =~ /^m\s+/ and do
+ {
+ do_module((split(' ', $reply))[1]);
+ last CASE;
+ };
+ $reply eq 'q' and do
+ {
+ exit(0);
+ };
+ # Default
+ print($help);
+ }
+ }
+}
+
+################################################################################
+
+$Inst = ExtUtils::Installed->new();
+@Modules = $Inst->modules();
+toplevel();
+
+################################################################################
projects / p5sagit/p5-mst-13.2.git / commitdiff