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

################################################################################
# Copyright (C) 1998, Alan Burlison
# Version 0.06, 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 SVR4 'pkgadd' 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.05;

# 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);
}

################################################################################
# Replace the front of a pathname with the appropriate prefix

sub replace_prefix($$)
{
my ($file, $src_or_dst) = @_;
$file =~ s/$PROGDIR/\$PROG$src_or_dst/;
$file =~ s/$DOCDIR/\$DOC$src_or_dst/;
return($file);
}

################################################################################
# Return the mode, owner & group of a file or directory

sub get_stat($)
{
my ($file) = @_;
my ($mode, $owner, $group) = (stat($file))[2, 4, 5];
$mode = sprintf("%o", $mode & 07777);
$owner = (getpwuid($owner))[0];
$group = (getgrgid($group))[0];
return($mode, $owner, $group);
}

################################################################################
# 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");
print("\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_namemap($)
{
my ($modules) = @_;
my %namemap;
my $i = "001";
foreach my $module (@$modules)
   {
   $namemap{$module}{prog} = "prog$i";
   $namemap{$module}{doc}  = "doc$i";
   $i++;
   }
return(\%namemap);
}

################################################################################
# Optionally read in an existing pkginfo file if it exists.  Otherwise, ask
# for the required values.  Note ORDER and CLASSES need to be filled in later

sub get_pkginfo()
{
my %pkginfo = ( PKG      => '',
                NAME     => '',
                ARCH     => 'ASK',
                VERSION  => '',
                CATEGORY => 'application',
                DESC     => '',
                CLASSES  => '',
                ISTATES  => 'S s 1 2 3',
                RSTATES  => 'S s 1 2 3',
                ORDER    => '',
                MAXINST  => '1',
                PSTAMP   => 'ASK',
                HOTLINE  => 'ASK',
                EMAIL    => 'ASK' );

# Read in any existing pkginfo file, if required
if (-f 'pkginfo')
   {
   # Read in the pkginfo file
   print("I see you have a pkginfo file.  Do you want me to reuse it ? [y] ");
   my $r = <STDIN>; chomp($r);
   if (! $r || $r =~ /^y/i)
      {
      my $pf = IO::File->new('pkginfo', "r") || die("Can't open pkginfo: $!\n");
      while (defined(my $line = <$pf>))
         {
         chomp($line);
         $line =~ s/\s*#.*//;
         next if (! $line);
         my ($key, $val) = split(/\s*=\s*/, $line);
         $val =~ s/"//g;
         $pkginfo{$key} = $val if ($pkginfo{$key} eq 'ASK');
         }
      }
   }

# Ask for missing bits
if (my @missing = grep($pkginfo{$_} =~ /^ASK$/, sort(keys(%pkginfo))))
   {
   print("I need the following pieces of information for the pkginfo file:\n");
   foreach my $key (@missing)
      {
      print("   $key ? ");
      my $val = <STDIN>;
      chomp($val);
      $pkginfo{$key} = $val;
      }
   }

print("\n");
return(\%pkginfo);
}

################################################################################
# Write out a pkginfo file

sub write_pkginfo($$$$$)
{
my ($pkginfo, $instance, $version, $modules, $namemap) = @_;

print("   pkginfo");

# Make the CLASS and ORDER entries
foreach my $module (@$modules)
   {
   $pkginfo->{CLASSES} .= "$namemap->{$module}{prog} $namemap->{$module}{doc} ";
   }
chop($pkginfo->{CLASSES});
$pkginfo->{ORDER} = $pkginfo->{CLASSES};

my ($pkg) = IO::File->new("pkginfo", "w")
   || die("Can't create pkginfo: $!\n");

# If building for a single add-on module
if (@$modules == 1 && $$modules[0] ne "Perl")
   {
   $pkg->print("# pkginfo file for $$modules[0] version $version\n",
               "# Generated by mksvr4pkg version $VERSION on ",
               scalar(localtime()), "\n",
               "# Author: Alan Burlison <Alan.Burlison\@uk.sun.com>\n\n");
   $pkginfo->{PKG}     = $instance;
   $pkginfo->{NAME}    = $$modules[0];
   $pkginfo->{DESC}    = "Perl add-on module $$modules[0]";
   $pkginfo->{VERSION} = $version;
   }

# Otherwise, building just perl or perl + modules
else
   {
   $pkg->print("# pkginfo file for Perl version $]\n",
               "# Generated by mksvr4pkg version $VERSION on ",
               scalar(localtime()), "\n",
               "# Author: Alan Burlison <Alan.Burlison\@uk.sun.com>\n\n");
   $pkginfo->{PKG}     = $instance;
   $pkginfo->{NAME}    = "Perl5";
   $pkginfo->{DESC}    = "Perl5 scripting language";
   $pkginfo->{VERSION} = $version;
   }

foreach my $key (qw(PKG NAME ARCH VERSION CATEGORY DESC CLASSES ISTATES RSTATES
                    ORDER MAXINST PSTAMP HOTLINE EMAIL ))
   {
   $pkg->print("$key=\"$pkginfo->{$key}\"\n");
   }
$pkg->close();
print("\n");
}

################################################################################
# Write out a prototype file

sub write_prototype($$$$)
{
my ($installed, $version, $modules, $namemap) = @_;

print("   prototype ");
my ($proto) = IO::File->new("prototype", "w")
   || die("Can't create prototype: $!\n");

# If building for a single add-on module
if (@$modules == 1 && $$modules[0] ne "Perl")
   {
   $proto->print("# prototype file for $$modules[0] version $version\n",
                 "# Generated by mksvr4pkg version $VERSION on ",
                 scalar(localtime()), "\n",
                 "# Author: Alan Burlison <Alan.Burlison\@uk.sun.com>\n\n");
   }

# Otherwise, building just perl or perl + modules
else
   {
   $proto->print("# prototype file for Perl version $]\n",
                 "# Generated by mksvr4pkg version $VERSION on ",
                 scalar(localtime()), "\n",
                 "# Author: Alan Burlison <Alan.Burlison\@uk.sun.com>\n\n");
   }

$proto->print("# Module to package name map:\n");
foreach my $module (@$modules)
   {
   $proto->printf("#    %-30s %s %s\n", $module, $namemap->{$module}{prog},
                  $namemap->{$module}{doc});
   }

$proto->print("\n# We don't do relocation (yet!)\n!BASEDIR=/\n\n",
              "# Source/destination for program/documentation files\n",
              "!PROGSRC=$PROGDIR\n!PROGDST=$PROGDIR\n",
              "!DOCSRC=$DOCDIR\n!DOCDST=$DOCDIR\n\n",
              "# Included files\ni pkginfo\ni copyright\ni request\n");

# For each module
foreach my $module (@$modules)
   {
   print(".");
   # For the program and documentation categories
   foreach my $cat (qw(prog doc))
      {
      my $base = $cat eq "prog" ? $PROGDIR : $DOCDIR;
      my $class = $namemap->{$module}{$cat};

      # Output all the directories
      $proto->print("\n# $module $cat directories\n");
      foreach my $dir (sort($installed->directory_tree($module, $cat, $base)))
         {
         my ($mode, $owner, $group) = get_stat($dir);
         $dir = replace_prefix($dir, 'DST');
         $proto->print("d $class $dir $mode $owner $group\n");
         }

      # Output all the files
      $proto->print("\n# $module $cat files\n");
      my $packlist = $installed->packlist($module);
      foreach my $file (sort($installed->files($module, $cat)))
         {
         my ($mode, $owner, $group) = get_stat($file);
         my ($type, $from);
         if ($packlist->{$file}->{from} && ! -l $file)
            {
            $type = 'l';
            $from = $packlist->{$file}->{from};
            }
         elsif (-l $file)
            {
            $type = 's';
            $from = readlink($file);
            }
         else
            {
            $type = 'f';
            $from = $file;
            }
         my $to = replace_prefix($file, 'DST');
         $from = replace_prefix($from, 'SRC');
         $proto->print("$type $class $to=$from $mode $owner $group\n");
         }
      }
   }
print("\n");
}

################################################################################
# Write out the request shell script.  This will prompt the user to select
# The components to be installed during the pkgadd run

sub write_request($$$)
{
my ($modules, $version, $namemap) = @_;

print("   request");
my ($req) = IO::File->new("request", "w") || die("Can't open request: $!\n");
my ($default_class, $mods, $classes);

# If building for a single add-on module
if (@$modules == 1 && $$modules[0] ne "Perl")
   {
   $req->print("#!/bin/sh\n",
               "# request shell script for $$modules[0] version $version\n",
               "# Generated by mksvr4pkg version $VERSION on ",
               scalar(localtime()), "\n",
               "# Author: Alan Burlison <Alan.Burlison\@uk.sun.com>\n\n");
   $default_class = $namemap->{$$modules[0]}{prog};
   $mods = "";
   $classes = "",
   }

# Otherwise, building just perl or perl + modules
else
   {
   $req->print("#!/bin/sh\n",
               "# request shell script for Perl version $]\n",
               "# Generated by mksvr4pkg version $VERSION on ",
               scalar(localtime()), "\n",
               "# Author: Alan Burlison <Alan.Burlison\@uk.sun.com>\n\n");
   $default_class = $namemap->{Perl}{prog};
   $mods = join(" ", @$modules[1 .. $#$modules]);
   $classes = join(" ", map($namemap->{$_}->{prog},
                            @$modules[1 .. $#$modules]));
   }

$req->print("# Ask the user what is to be installed\n",
            "# List of VAR=value statements output to stdout\n\n",
            "trap 'exit 3'  INT QUIT TERM\n\n",
            "# Default classes\n",
            "CLASSES=$default_class\n\n");

if ($mods ne "")
   {
   $req->print("modules=\"$mods\"\n",
               "classes=\"$classes\"\n".
               "for module in \$modules\n",
               "do\n",
               "   ans=`ckyorn -p \"Should the module \$module be ",
                  "installed? \" -d n` || exit \$?\n",
               "   if [ \"\$ans\" = \"y\" ]\n",
               "   then\n",
               "      CLASSES=\"\$CLASSES `echo \$classes | ",
                  "awk '{ print \$1 }'`\"\n",
               "   fi\n",
               "   classes=`echo \$classes | ",
                  "awk '{ for (i = 2; i <= NF; i++) print \$i }'`\n",
               "done\n\n");
   }

$req->print("# Ask if man pages should be installed\n",
            "ans=`ckyorn -p \"Should man pages be installed as well? \" ",
               "-d y` || exit \$?\n",
            "if [ \"\$ans\" = \"y\" ]\n",
            "then\n",
            "   CLASSES=\"\$CLASSES `echo \$CLASSES | ",
               "sed -e 's/prog/doc/g'`\"\n",
            "fi\n\n",
            "cat >\$1 <<EOF\n");
$req->print("BASEDIR=/\n") if ($Config{osname} =~ /solaris/i);
$req->print("PROGSRC=$PROGDIR\n",
            "PROGDST=$PROGDIR\n",
            "DOCSRC=$DOCDIR\n",
            "DOCDST=$DOCDIR\n",
            "CLASSES=\"\$CLASSES\"\n",
            "EOF\n",
            "exit 0\n");
$req->close();
print("\n");
}

################################################################################
# Write out the copyright file.  This will be displayed during pkgadd

sub write_copyright()
{
my ($copy) = IO::File->new("copyright", "w")
   || die("Can't open copyright: $!\n");

print("   copyright");
print $copy <<COPYRIGHT;
                           Perl Kit, Version 5.0

                       Copyright 1989-1998, Larry Wall
                            All rights reserved.

    This program is free software; you can redistribute it and/or modify
    it under the terms of either:

        a) the GNU General Public License as published by the Free
        Software Foundation; either version 1, or (at your option) any
        later version, or

        b) the "Artistic License" which comes with this Kit.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either
    the GNU General Public License or the Artistic License for more details.
COPYRIGHT
$copy->close();
print("\n");
}

################################################################################
# Call the shell commands to make the package

sub generate_package($)
{
my ($instance) = @_;
my ($dir) = (getcwd());
runcmd("pkgmk -o -d $dir $instance");
runcmd("pkgtrans -os $dir $dir/$instance.pkg $instance");
runcmd("/bin/rm -rf $instance");
}

################################################################################
# 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 SVR4 packages for Perl and any selected modules.\n",
      "Modules may either be placed into their own seperate SVR4 packages,\n",
      "or included into the core Perl package.  If you choose to build a\n",
      "single combined package, the user will be prompted to select which\n",
      "modules to install during the pkgadd process.\n\n",
      "Do you wish to build a combined Perl + Module package? [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);

# Process any existing pkginfo file, or prompt for it's contents
my $pkginfo = get_pkginfo();

if ($mode eq "combined")
   {
   print("Creating packaging files\n");

   # Create a map of module names to short names.
   # This is necessary due to lenth restrictions in the prototype file
   my $instance = "Perl";
   my $version = $];
   my $namemap = make_namemap($modules);

   # Output the copyright
   write_copyright();

   # Output the pkginfo file
   write_pkginfo($pkginfo, $instance, $version, $modules, $namemap);

   # Output the prototype file
   write_prototype($installed, $version, $modules, $namemap);

   # Output the request script
   write_request($modules, $version, $namemap);

   # Generate the package
   print("\nGenerating the package\n");
   generate_package($instance);
   print("Finished.  The package file is called $instance.pkg\n");
   }

else   # seperate mode
   {
   foreach my $module (@$modules)
      {
      print("Creating packaging files for $module\n");
      my $modlist = [ $module ];

      # Create a map of module names to short names.
      # This is necessary due to lenth restrictions in the prototype file
      my $instance = $module;
      $instance =~ s/[-:_]//g;
      $instance = substr($instance, 0, 9);
      my $version = $installed->version($module) || "???";
      my $namemap = make_namemap($modlist);

      # Output the copyright
      write_copyright();

      # Output the pkginfo file
      write_pkginfo($pkginfo, $instance, $version, $modlist, $namemap);

      # Output the prototype file
      write_prototype($installed, $version, $modlist, $namemap);

      # Output the request script
      write_request($modlist, $version, $namemap);

      # Generate the package
      print("\nGenerating the package\n");
      generate_package($instance);
      print("   The package file is called $instance.pkg\n\n");
      }
   print("Finished.\n");
   }

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