This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
PATCH for 5.004_62 : Add .packlist handling classes to ExtUtils
authorAlan Burlison <Alan.Burlison@uk.sun.com>
Sun, 8 Mar 1998 12:50:23 +0000 (12:50 +0000)
committerMalcolm Beattie <mbeattie@sable.ox.ac.uk>
Mon, 16 Mar 1998 13:17:14 +0000 (13:17 +0000)
plus manual update of MANIFEST

p4raw-id: //depot/perl@814

MANIFEST
installman
installperl
lib/ExtUtils/Install.pm
lib/ExtUtils/Installed.pm [new file with mode: 0644]
lib/ExtUtils/MM_Unix.pm
lib/ExtUtils/inst [new file with mode: 0755]

index 80bae3e..1743430 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -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
index 4d74bcf..e637720 100755 (executable)
@@ -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 {
index 6197e92..4c87f55 100755 (executable)
@@ -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) {
index a3d2481..992d178 100644 (file)
@@ -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 (file)
index 0000000..c6dde68
--- /dev/null
@@ -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
index 888e539..8e61fe0 100644 (file)
@@ -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 (executable)
index 0000000..cbf2d01
--- /dev/null
@@ -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();
+
+################################################################################