perl5.005_03

3 files changed, 699 insertions, 0 deletions

diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Installed.pm b/gnu/usr.bin/perl/lib/ExtUtils/Installed.pm
new file mode 100644
index 00000000000..dda594e7843
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/ExtUtils/Installed.pm
@@ -0,0 +1,272 @@
+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.02';
+
+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 EXAMPLE
+
+See the example in L<ExtUtils::Packlist>.
+
+=head1 AUTHOR
+
+Alan Burlison <Alan.Burlison@uk.sun.com>
+
+=cut
diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Packlist.pm b/gnu/usr.bin/perl/lib/ExtUtils/Packlist.pm
new file mode 100644
index 00000000000..eeb0a5b0c1c
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/ExtUtils/Packlist.pm
@@ -0,0 +1,288 @@
+package ExtUtils::Packlist;
+use strict;
+use Carp qw();
+use vars qw($VERSION);
+$VERSION = '0.03';
+
+# Used for generating filehandle globs.  IO::File might not be available!
+my $fhname = "FH1";
+
+sub mkfh()
+{
+no strict;
+my $fh = \*{$fhname++};
+use strict;
+return($fh);
+}
+
+sub new($$)
+{
+my ($class, $packfile) = @_;
+$class = ref($class) || $class;
+my %self;
+tie(%self, $class, $packfile);
+return(bless(\%self, $class));
+}
+
+sub TIEHASH
+{
+my ($class, $packfile) = @_;
+my $self = { packfile => $packfile };
+bless($self, $class);
+$self->read($packfile) if (defined($packfile) && -f $packfile);
+return($self);
+}
+
+sub STORE
+{
+$_[0]->{data}->{$_[1]} = $_[2];
+}
+
+sub FETCH
+{
+return($_[0]->{data}->{$_[1]});
+}
+
+sub FIRSTKEY
+{
+my $reset = scalar(keys(%{$_[0]->{data}}));
+return(each(%{$_[0]->{data}}));
+}
+
+sub NEXTKEY
+{
+return(each(%{$_[0]->{data}}));
+}
+
+sub EXISTS
+{
+return(exists($_[0]->{data}->{$_[1]}));
+}
+
+sub DELETE
+{
+return(delete($_[0]->{data}->{$_[1]}));
+}
+
+sub CLEAR
+{
+%{$_[0]->{data}} = ();
+}
+
+sub DESTROY
+{
+}
+
+sub read($;$)
+{
+my ($self, $packfile) = @_;
+$self = tied(%$self) || $self;
+
+if (defined($packfile)) { $self->{packfile} = $packfile; }
+else { $packfile = $self->{packfile}; }
+Carp::croak("No packlist filename specified") if (! defined($packfile));
+my $fh = mkfh();
+open($fh, "<$packfile") || Carp::croak("Can't open file $packfile: $!");
+$self->{data} = {};
+my ($line);
+while (defined($line = <$fh>))
+   {
+   chomp $line;
+   my ($key, @kvs) = split(' ', $line);
+   $key =~ s!/\./!/!g;   # Some .packlists have spurious '/./' bits in the paths
+   if (! @kvs)
+      {
+      $self->{data}->{$key} = undef;
+      }
+   else
+      {
+      my ($data) = {};
+      foreach my $kv (@kvs)
+         {
+         my ($k, $v) = split('=', $kv);
+         $data->{$k} = $v;
+         }
+      $self->{data}->{$key} = $data;
+      }
+   }
+close($fh);
+}
+
+sub write($;$)
+{
+my ($self, $packfile) = @_;
+$self = tied(%$self) || $self;
+if (defined($packfile)) { $self->{packfile} = $packfile; }
+else { $packfile = $self->{packfile}; }
+Carp::croak("No packlist filename specified") if (! defined($packfile));
+my $fh = mkfh();
+open($fh, ">$packfile") || Carp::croak("Can't open file $packfile: $!");
+foreach my $key (sort(keys(%{$self->{data}})))
+   {
+   print $fh ("$key");
+   if (ref($self->{data}->{$key}))
+      {
+      my $data = $self->{data}->{$key};
+      foreach my $k (sort(keys(%$data)))
+         {
+         print $fh (" $k=$data->{$k}");
+         }
+      }
+   print $fh ("\n");
+   }
+close($fh);
+}
+
+sub validate($;$)
+{
+my ($self, $remove) = @_;
+$self = tied(%$self) || $self;
+my @missing;
+foreach my $key (sort(keys(%{$self->{data}})))
+   {
+   if (! -e $key)
+      {
+      push(@missing, $key);
+      delete($self->{data}{$key}) if ($remove);
+      }
+   }
+return(@missing);
+}
+
+sub packlist_file($)
+{
+my ($self) = @_;
+$self = tied(%$self) || $self;
+return($self->{packfile});
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+ExtUtils::Packlist - manage .packlist files
+
+=head1 SYNOPSIS
+
+   use ExtUtils::Packlist;
+   my ($pl) = ExtUtils::Packlist->new('.packlist');
+   $pl->read('/an/old/.packlist');
+   my @missing_files = $pl->validate();
+   $pl->write('/a/new/.packlist');
+
+   $pl->{'/some/file/name'}++;
+      or
+   $pl->{'/some/other/file/name'} = { type => 'file',
+                                      from => '/some/file' };
+
+=head1 DESCRIPTION
+
+ExtUtils::Packlist provides a standard way to manage .packlist files.
+Functions are provided to read and write .packlist files.  The original
+.packlist format is a simple list of absolute pathnames, one per line.  In
+addition, this package supports an extended format, where as well as a filename
+each line may contain a list of attributes in the form of a space separated
+list of key=value pairs.  This is used by the installperl script to
+differentiate between files and links, for example.
+
+=head1 USAGE
+
+The hash reference returned by the new() function can be used to examine and
+modify the contents of the .packlist.  Items may be added/deleted from the
+.packlist by modifying the hash.  If the value associated with a hash key is a
+scalar, the entry written to the .packlist by any subsequent write() will be a
+simple filename.  If the value is a hash, the entry written will be the
+filename followed by the key=value pairs from the hash.  Reading back the
+.packlist will recreate the original entries.
+
+=head1 FUNCTIONS
+
+=over
+
+=item new()
+
+This takes an optional parameter, the name of a .packlist.  If the file exists,
+it will be opened and the contents of the file will be read.  The new() method
+returns a reference to a hash.  This hash holds an entry for each line in the
+.packlist.  In the case of old-style .packlists, the value associated with each
+key is undef.  In the case of new-style .packlists, the value associated with
+each key is a hash containing the key=value pairs following the filename in the
+.packlist.
+
+=item read()
+
+This takes an optional parameter, the name of the .packlist to be read.  If
+no file is specified, the .packlist specified to new() will be read.  If the
+.packlist does not exist, Carp::croak will be called.
+
+=item write()
+
+This takes an optional parameter, the name of the .packlist to be written.  If
+no file is specified, the .packlist specified to new() will be overwritten.
+
+=item validate()
+
+This checks that every file listed in the .packlist actually exists.  If an
+argument which evaluates to true is given, any missing files will be removed
+from the internal hash.  The return value is a list of the missing files, which
+will be empty if they all exist.
+
+=item packlist_file()
+
+This returns the name of the associated .packlist file
+
+=back
+
+=head1 EXAMPLE
+
+Here's C<modrm>, a little utility to cleanly remove an installed module.
+
+    #!/usr/local/bin/perl -w
+
+    use strict;
+    use IO::Dir;
+    use ExtUtils::Packlist;
+    use ExtUtils::Installed;
+
+    sub emptydir($) {
+	my ($dir) = @_;
+	my $dh = IO::Dir->new($dir) || return(0);
+	my @count = $dh->read();
+	$dh->close();
+	return(@count == 2 ? 1 : 0);
+    }
+
+    # Find all the installed packages
+    print("Finding all installed modules...\n");
+    my $installed = ExtUtils::Installed->new();
+
+    foreach my $module (grep(!/^Perl$/, $installed->modules())) {
+       my $version = $installed->version($module) || "???";
+       print("Found module $module Version $version\n");
+       print("Do you want to delete $module? [n] ");
+       my $r = <STDIN>; chomp($r);
+       if ($r && $r =~ /^y/i) {
+	  # Remove all the files
+	  foreach my $file (sort($installed->files($module))) {
+	     print("rm $file\n");
+	     unlink($file);
+	  }
+	  my $pf = $installed->packlist($module)->packlist_file();
+	  print("rm $pf\n");
+	  unlink($pf);
+	  foreach my $dir (sort($installed->directory_tree($module))) {
+	     if (emptydir($dir)) {
+		print("rmdir $dir\n");
+		rmdir($dir);
+	     }
+	  }
+       }
+    }
+
+=head1 AUTHOR
+
+Alan Burlison <Alan.Burlison@uk.sun.com>
+
+=cut
diff --git a/gnu/usr.bin/perl/lib/ExtUtils/inst b/gnu/usr.bin/perl/lib/ExtUtils/inst
new file mode 100644
index 00000000000..cbf2d01194a
--- /dev/null
+++ b/gnu/usr.bin/perl/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();
+
+################################################################################