diff options
| -rw-r--r-- | MANIFEST | 2 | ||||
| -rwxr-xr-x | installman | 30 | ||||
| -rwxr-xr-x | installperl | 12 | ||||
| -rw-r--r-- | lib/ExtUtils/Install.pm | 31 | ||||
| -rw-r--r-- | lib/ExtUtils/Installed.pm | 268 | ||||
| -rw-r--r-- | lib/ExtUtils/MM_Unix.pm | 12 | ||||
| -rwxr-xr-x | lib/ExtUtils/inst | 139 |
7 files changed, 461 insertions, 33 deletions
@@ -415,6 +415,7 @@ lib/Exporter.pm Exporter base class 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 @@ -424,6 +425,7 @@ lib/ExtUtils/MakeMaker.pm Write Makefiles for extensions 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 diff --git a/installman b/installman index 4d74bcfea2..e6377204b1 100755 --- a/installman +++ b/installman @@ -3,8 +3,11 @@ BEGIN { @INC = ('lib') } 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; @@ -50,6 +53,8 @@ $notify = $opt_notify || $opt_n; -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); @@ -156,6 +161,7 @@ sub lsmodpods { } } +$packlist->write() unless $notify; print STDERR " Installation complete\n"; exit 0; @@ -194,12 +200,27 @@ print STDERR " unlink $name\n"; } 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 { @@ -214,6 +235,7 @@ warn("Cannot rename to `$to.$i': $!"), return 0 } link($from,$to) || return 0; unlink($from); + $packlist->{$to} = { type => 'file' }; } sub chmod { diff --git a/installperl b/installperl index 6197e92b1d..4c87f553cf 100755 --- a/installperl +++ b/installperl @@ -11,8 +11,10 @@ use File::Find; 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 { @@ -103,6 +105,9 @@ copy("perl.$dlext", "$installbin/perl.$dlext"); 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') { @@ -272,6 +277,7 @@ if (! $versiononly || !($installprivlib =~ m/\Q$]/)) { # 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); @@ -311,6 +317,7 @@ if (!$versiononly) { } +$packlist->write() unless $nono; print STDERR " Installation complete\n"; exit 0; @@ -384,12 +391,14 @@ sub link { ? 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; } @@ -411,6 +420,7 @@ sub copy { File::Copy::copy($from, $to) || warn "Couldn't copy $from to $to: $!\n" unless $nonono; + $packlist->{$to} = { type => 'file' }; } sub samepath { @@ -466,6 +476,7 @@ sub installlib { #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); @@ -493,6 +504,7 @@ sub installlib { 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) { diff --git a/lib/ExtUtils/Install.pm b/lib/ExtUtils/Install.pm index a3d2481224..992d178659 100644 --- a/lib/ExtUtils/Install.pm +++ b/lib/ExtUtils/Install.pm @@ -30,6 +30,7 @@ sub install { 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); @@ -37,10 +38,11 @@ sub install { 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{$_}; @@ -63,15 +65,7 @@ sub install { } 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; @@ -134,7 +128,7 @@ sub install { } 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: $!"); @@ -144,11 +138,7 @@ sub install { $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'}); } } @@ -190,14 +180,13 @@ sub install_default { } 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; diff --git a/lib/ExtUtils/Installed.pm b/lib/ExtUtils/Installed.pm new file mode 100644 index 0000000000..c6dde68b90 --- /dev/null +++ b/lib/ExtUtils/Installed.pm @@ -0,0 +1,268 @@ +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 diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 888e5396dc..8e61fe0703 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -98,17 +98,13 @@ trailing slash :-) # '; 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 @@ -121,12 +117,12 @@ complete path ending with a filename 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 diff --git a/lib/ExtUtils/inst b/lib/ExtUtils/inst new file mode 100755 index 0000000000..cbf2d01194 --- /dev/null +++ b/lib/ExtUtils/inst @@ -0,0 +1,139 @@ +#!/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(); + +################################################################################ |