#!/usr/local/bin/perl -w

################################################################################
# Copyright (C) 1998, Alan Burlison
# Version 0.02, 10/08/98
# 
# This code is free software; you can redistribute it or modify it
# under the same terms as Perl itself.
#
# This script creates a tar format distribution based on the currently
# installed Perl, along with any additionally installed modules.
################################################################################

use strict;
use Cwd;
use IO::File;
use Config;
use File::Basename;
use ExtUtils::Packlist;
use ExtUtils::Installed;
use vars qw($VERSION);
$VERSION = 0.01;

# List of common directory prefixes
use vars qw(@ALLDIRS);
my @ALLDIRS = reverse(sort(@Config{qw(installprivlib installarchlib
                                      installsitelib installsitearch installbin
                                      installman1dir installman3dir)}));

# Starting point of install trees
use vars qw($PROGDIR $DOCDIR);
$PROGDIR = $Config{prefix};
$DOCDIR = dirname($Config{installman1dir});

################################################################################
# Strip any of the install directory prefixes from the path

sub strip_dir($)
{
my ($path) = @_;
foreach my $dir (@ALLDIRS)
   {
   $path =~ s!^$dir/!!;
   }
return($path);
}

################################################################################
# Run a shell command, reporting what we did & dying if there is an error

sub runcmd($)
{
my ($cmd) = @_;
print("   Executing \"$cmd\"\n");
system($cmd) == 0 || die("Error executing command \"$cmd\"\n");
}

################################################################################
# Return a list of all the modules to be installed

sub which_modules($$)
{
my ($installed, $mode) = @_;

# Get a list of all the core files, without the instXXX prefixes
my $core_packlist = $installed->packlist("Perl");
my %core_files;
foreach my $file (keys(%$core_packlist))
   {
   $core_files{strip_dir($file)} = $file;
   }

my @package_modules;
if ($mode eq "combined")
   {
   push(@package_modules, "Perl");
   }
else
   {
   print("Do you want to package the Perl core? [y] ");
   my $r = <STDIN>; chomp($r);
   push(@package_modules, 'Perl') if (! $r || $r =~ /^y/i);
   }

# Find out what we are to do with each installed module
my %seen_files;
MODULE:
foreach my $module (grep(!/^Perl$/, $installed->modules()))
   {
   print("\n");
   my $packlist = $installed->packlist($module);
   my $version = $installed->version($module) || "???";
   print("Found module $module Version $version\n");

   # Check the module isn't missing any files
   if (my (@missing) = $packlist->validate(1))
      {
      print("The following files seem to be missing from $module:\n   ",
            join("\n   ", @missing),
            "\nDo you want to remove these files & package the module? [y] ");
      my $r = <STDIN>; chomp($r);
      if (! $r && $r =~ /^y/i) { $packlist->write(); }
      next MODULE;
      }

   # Find out which files are shared with the core, or have been seen before
   my ($core_file_count, @dup_files, %module_files) = (0);
   foreach my $file (keys(%$packlist))
      {
      my $f = strip_dir($file);
      $module_files{$f} = $file;
      if (exists($core_files{$f})) { $core_file_count++; }
      elsif (exists($seen_files{$file})) { push(@dup_files, $file); }
      else { $seen_files{$file} = $module };
      }

   # If any of the files are core files, offer to move them into the core
   if ($core_file_count)
      {
      print("$module appears to be an update to the Perl core.  ",
            "Do you wish to update\nthe core .packlist with these files ",
            "and remove $module\'s packlist? [y] ");
      my $r = <STDIN>; chomp($r);
      if (! $r || $r =~ /^y/i)
         {
         while (my ($file, $path) = each(%module_files))
            {
            delete($core_packlist->{$core_files{$file}})
               if (exists($core_files{$file}));
            $core_packlist->{$path} = $packlist->{$path};
            }
         my $pf = $packlist->packlist_file();
         unlink($pf) || die("Can't delete $pf: $!\n");
         $core_packlist->write();
         next MODULE;
         }
      }

   # If any files are seen in two modules, report a warning
   if (@dup_files)
      {
      print("\nThe following files in $module have been seen before:\n");
      foreach my $file (@dup_files)
         {
         print("   Module $seen_files{$file}: $file\n");
         }
      print("In order to create a package these files\n",
            "will have to be removed from $module.\n",
            "Do you still wish to package this module? [y] ");
      my $r = <STDIN>; chomp($r);
      if (! $r || $r =~ /^y/i)
         {
         my $packlist = $installed->packlist($module);
         foreach my $dup (@dup_files) { delete($packlist->{$dup}); }
         $packlist->write();
         push(@package_modules, $module);
         }
      next MODULE;
      }

   # Otherwise, ask if the module is to be included
   print("Do you want to package $module? [y] ");
   my $r = <STDIN>; chomp($r);
   push(@package_modules, $module) if (! $r || $r =~ /^y/i);
   next MODULE;
   }

# Finally, validate the core packlist;
if (my (@missing) = $core_packlist->validate(1))
   {
   print("\nThe following files seem to be missing from the Perl core:\n   ",
         join("\n   ", @missing),
         "\nDo you want to remove them from the core .packlist ",
         "and continue? [y] ");
   my $r = <STDIN>; chomp($r);
   if (! $r || $r =~ /^y/i)
      {
      $core_packlist->write();
      }
   else
      {
      return(undef);
      }
   }

# Add in the .packlist entries (but don't save them to disk)
foreach my $module (@package_modules)
   {
   my $packlist = $installed->packlist($module);
   $packlist->{$packlist->packlist_file()} = {};
   }

print("\n");
return(\@package_modules);
}

################################################################################

sub make_archives($$)
{
my ($installed, $modules) = @_;
my $filelist = "/tmp/mktarpkg.$$";

# For each module
foreach my $module (@$modules)
   {
   my ($flist) = IO::File->new($filelist, "w")
      || die("Can't create $filelist: $!\n");

   # Output all the files
   foreach my $file (sort($installed->files($module)))
      {
      $flist->print("$file\n");
      }

   # Create the tar archive
   $flist->close();
   runcmd("tar -cf $module.tar -I $filelist");
   unlink($filelist);
   }
print("\n");
}

################################################################################

sub make_install($$)
{ 
my ($installed, $modules) = @_;
my $inst = IO::File->new("install", O_WRONLY | O_CREAT, 0755)
   || die("Can't create install: $!\n");
$inst->print("#!/bin/sh\n",
             "# Perl Archive install script\n",
             "# Generated by mktarpkg version $VERSION on ",
             scalar(localtime()), "\n",
             "# Author: Alan Burlison <Alan.Burlison\@uk.sun.com>\n\n");
my $mods = join(" ", @$modules);
my $date = localtime();

print $inst <<"EOSCRIPT";
#!/bin/sh
# Perl Archive install script
# Generated by mktarpkg version $VERSION on $date
# Author: Alan Burlison <Alan.Burlison\@uk.sun.com>

yes()
{
echo "\$*? [y] \\c"
read reply
if [ "\$reply" != "y" -a "\$reply" != "Y" ]
then
   return 1
else
   return 0
fi
}

modules="$mods"
for module in \$modules
do
   if yes "Do you want to install \$module"
   then
      echo "Installing \$module"
      tar xf PerlArchive.tar \$module.tar
      tar xvf \$module.tar
      rm \$module.tar
      echo "\$module installed\n"
   fi
done
exit 0
EOSCRIPT

$inst->close();
}

################################################################################
# Main

$| = 1;

# Find out if we are to build seperate packages for each module,
# or just one big package.
my $mode = "combined";
print("This will build tar archives for Perl and any selected modules.\n",
      "You can opt either to just build individual tar archives for Perl and\n",
      "selected modules, or you can choose to build a combined archive that\n",
      "also includes an install shell script.  The shell script will allow\n",
      "selection of the modules to be installed.\n",
      "Do you wish to build a combined Perl + module archive? [y] ");
my $r = <STDIN>; chomp($r);
if ($r && $r !~ /^y/i) { $mode = "seperate"; }

# Find all the installed packages
print("Finding all installed modules...\n");
my $installed = ExtUtils::Installed->new();

# Get a list of the packages to install
my $modules = which_modules($installed, $mode);
exit(1) if (! $modules);

print("Creating module tar archives\n");
make_archives($installed, $modules);

if ($mode eq "combined")
   {
   print("Creating install shell script\n");
   make_install($installed, $modules);

   my $tarfiles = "install " . join(".tar ", @$modules) . ".tar";
   print("Creating combined archive\n");
   runcmd("tar cf PerlArchive.tar $tarfiles");

   print("Deleting module tar files\n");
   runcmd("rm $tarfiles");

   print("\nFinished.  The combined archive is called PerlArchive.tar\n",
         "To use the archive, do the following:\n",
         "    tar xf PerlArchive.tar install\n",
         "   ./install\n",
         "and follow the instructions.\n");
   }

else
   {
   print("Finished.  The tar files for the selected modules\n",
         "have been created in your current directory\n");
   }

################################################################################