#!/usr/bin/perl -w
#
# perlpkg -- Tool for packaging perl modules.
# 
# Copyright (C) 2001, Michael Jennings
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies of the Software, its documentation and marketing & publicity
# materials, and acknowledgment shall be given in the documentation, materials
# and software packages that this Software was used.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
# THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
# IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
# CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
#
# $Id: perlpkg,v 1.5 2005/05/07 05:26:19 mej Exp $
#

use strict;
use vars '$progname', '$version', '$opt_v', '$opt_h', '$opt_d',
    '$opt_t', '$opt_s', '$opt_p', '$opt_n', '$opt_u', '$opt_L';
use CPAN;
use POSIX;
use Getopt::Long;
use Mezzanine::Util;
use Mezzanine::Template;
use Mezzanine::RPM '&rpm_compare_versions';

my ($SAVE_STDIN, $SAVE_STDOUT, $SAVE_STDERR);
my %distributions;
my @tried;
my @built;
my ($template, $save_pwd);
my ($handle_build_deps, $pkgonly, $update, $local_mode);

# Print usage information
sub
print_usage_info
{
    my ($leader, $underbar);

    print "\n";
    $leader = "$progname $version Usage Information";
    $underbar = $leader;
    $underbar =~ s/./-/g;
    print "$leader\n$underbar\n";
    print "\n";
    print "  Syntax:   perlpkg [ options ]\n";
    print "\n";
    print "    -h --help                        Show this usage information\n";
    print "    -d --debug                       Turn on debugging\n";
    print "    -v --version                     Show version and copyright\n";
    print "    -s --search                      Search only; don't build anything\n";
    print "    -t --template <path>             Use specified template file/directory\n";
    print "    -p --pkgonly                     Package only; do not attempt to build\n";
    print "    -n --nodeps                      Do not handle build dependencies\n";
    print "    -u --update                      Check for updates\n";
    print "    -L --local                       Local mode; do not contact CPAN\n";
    print "\n";
    exit(MEZZANINE_SUCCESS);
}

# WAY TOO SLOW
#sub
#create_cpan_dist_list()
#{
#    foreach my $dist (CPAN::Shell->expand("Distribution", "/./")) {
#        my @tmp = split(/\s+/, $dist->as_glimpse());
#        my $file = $tmp[1];
#
#        print $SAVE_STDERR "Got distribution:  $file\n";
#        @{$distributions{$file}{"MODLIST"}} = $dist->containsmods();
#    }
#}

sub
create_cpan_list()
{
    foreach my $mod (CPAN::Shell->expand("Module", "/./")) {
        my @tmp = split(/\s+/, $mod->as_glimpse());
        my $name = $tmp[1];
        my $file = $mod->cpan_file();
        my $installed = $mod->inst_version() || "";
        my $uptodate = $mod->uptodate();

        #print $SAVE_STDERR "Got module:  $name ($file)\n";
        push @{$distributions{$file}{"MODLIST"}}, $name;
        push @{$distributions{$file}{"MODOBJLIST"}}, $mod;
        next;
        if (defined($distributions{$file}{"INSTALLED"})) {
            if ($distributions{$file}{"INSTALLED"} && !($installed)) {
                $distributions{$file}{"INSTALLED"} = 0;
            }
        } else {
            $distributions{$file}{"INSTALLED"} = (($installed) ? (1) : (0));
        }
        if (defined($distributions{$file}{"UPTODATE"})) {
            if ($distributions{$file}{"UPTODATE"} && !($uptodate)) {
                $distributions{$file}{"UPTODATE"} = 0;
            }
        } else {
            $distributions{$file}{"UPTODATE"} = (($uptodate) ? (1) : (0));
        }
    }
}

sub
get_install_info(@)
{
    my @distributions = @_;

    foreach my $file (@distributions) {
        if (!defined($distributions{$file}{"UPTODATE"})) {
            my $dist_obj = CPAN::Shell->expand("Distribution", $file);
            my @modobj_list;
            my $installed = 1;

            if (!defined($dist_obj)) {
                dprint "Unable to resolve distribution name $file.\n";
                next;
            } elsif (!ref($distributions{$file}{"MODOBJLIST"}) eq "ARRAY") {
                next;
            }
            @modobj_list = @{$distributions{$file}{"MODOBJLIST"}};
            $distributions{$file}{"UPTODATE"} = $dist_obj->uptodate();
            if (&debug_get()) {
                print $SAVE_STDOUT "Up-to-date status for $file:  $distributions{$file}{UPTODATE}\n";
            }
            foreach my $modobj (@modobj_list) {
                my $inst_version = $modobj->inst_version();

                if (! $inst_version) {
                    $installed = 0;
                    if (&debug_get()) {
                        printf $SAVE_STDOUT ("Missing module from %s:  %s.\n",
                                             $modobj->cpan_file(),
                                             $modobj->as_glimpse());
                    }
                    last;
                }
            }
            $distributions{$file}{"INSTALLED"} = $installed;
            if (&debug_get()) {
                print $SAVE_STDOUT "Installation status for $file:  $distributions{$file}{INSTALLED}\n";
            }
        }
    }
}

sub
build(@)
{
    my $depth = shift @_;
    my @distributions = @_;
    my $depth_str = "";

    if ($depth) {
        $depth_str = "[$depth] ";
    }
    &get_install_info(@distributions);
    foreach my $file (@distributions) {
        my $dist_obj = CPAN::Shell->expand("Distribution", $file);
        my $href;

        if (!defined($dist_obj)) {
            dprint "Unable to resolve distribution name $file.\n";
            if (-s $file) {
                push @built, $file;
            }
            next;
        }
        if (scalar(grep($_ eq $file, @tried))) {
            #print $SAVE_STDOUT "${depth_str}Skipping $file; already tried.\n";
            next;
        } elsif (&basename($file) =~ /^perl-[\d\.]+\.(t|tar\.)(gz|bz2?)$/) {
            print $SAVE_STDOUT "${depth_str}Something requires newer Perl (", &basename($file), "); aborting!\n";
            next;
        } elsif (&basename($file) =~ /^Meta-[\d\.]+\.(t|tar\.)(gz|bz2?)$/) {
            print $SAVE_STDOUT "${depth_str}Something requires the evil Meta package (", &basename($file), "); aborting!\n";
            next;
        } elsif (!($update) && $distributions{$file}{"INSTALLED"}) {
            print $SAVE_STDOUT "${depth_str}Skipping installed package $file\n";
            next;
        } elsif ($update && $distributions{$file}{"UPTODATE"}) {
            print $SAVE_STDOUT "${depth_str}Skipping up-to-date package $file\n";
            next;
        } elsif (&debug_get()) {
            print $SAVE_STDOUT "${depth_str}Need to build $file.\n";
        }
        print $SAVE_STDOUT "${depth_str}Building $file:  ";
        print $SAVE_STDOUT "downloading...";
        $dist_obj->get();

        if (! $pkgonly) {
            print $SAVE_STDOUT "building...";
        }
        $dist_obj->make();
        $href = $dist_obj->prereq_pm();
        push @tried, $file;
        if ($href && ref($href) eq "HASH" && scalar(keys(%{$href})) > 0) {
            if ($handle_build_deps) {
                my @deps;

                foreach my $dep (keys(%{$href})) {
                    foreach my $distfile (grep { grep { $_ =~ $dep } @{$distributions{$_}{"MODLIST"}} } keys(%distributions)) {
                        if (!scalar(grep { $distfile eq $_ } @tried)) {
                            push @deps, $distfile;
                        }
                    }
                }
                if (scalar(@deps)) {
                    if ($depth) {
                        print $SAVE_STDOUT "deps found.\n";
                    } else {
                        print $SAVE_STDOUT "deps found:  ", join(", ", map { &basename($_) } @deps), "\n";
                    }
                    &build($depth + 1, @deps);
                    print $SAVE_STDOUT "${depth_str}Resuming $file...building...";
                    $dist_obj->make();
                }
            } else {
                print $SAVE_STDOUT "Not handling dependencies:  ", join(", ", map { &basename($_) } keys(%{$href})), "\n";
            }
        }
        if (! $pkgonly) {
            print $SAVE_STDOUT "testing...";
            $dist_obj->test();
            print $SAVE_STDOUT "cleaning...";
            $dist_obj->clean();
        }
        push @built, $file;
        print $SAVE_STDOUT "done.\n";
    }
}

sub
package_perl_dist(@)
{
    my @distributions = @_;
    my $ret;

    if (! $template->verify()) {
        printf $SAVE_STDERR ("Error:  Cannot package; template %s/%s not found.\n",
                             $template->directory(), $template->file());
        return;
    }

    foreach my $file (@distributions) {
        my $filepath;
        my ($pkgname, $distname, $version, $specfile, $modname);
        my %vars;
        my @tmp;
        local *SPECFILE;

        if (defined($CPAN::Config->{"keep_source_where"})) {
            $filepath = "$CPAN::Config->{keep_source_where}/authors/id/$file";
        } else {
            $filepath = $file;
        }
        if (! -f $filepath) {
            if (-f $file) {
                $filepath = $file;
            } else {
                print $SAVE_STDERR "Error:  $filepath not found.\n";
                next;
            }
        }
        if (&basename($file) !~ /^(.+)-([^-]+)\.((t|tar\.)(gz|bz2?)|zip)$/) {
            print $SAVE_STDERR "Error:  $file unparseable.\n";
            next;
        } else {
            $distname = $1;
            $version = $2;
            $pkgname = "perl-" . $distname;
            ($modname = $distname) =~ s/-/::/g;
        }

        if (! &mkdirhier($pkgname)) {
            print $SAVE_STDERR "Error:  Unable to create $pkgname -- $!\n";
            next;
        }
        if (! &copy_files($filepath, $pkgname)) {
            print $SAVE_STDERR "Error:  Unable to copy $filepath to $pkgname -- $!\n";
            next;
        }

        # Assign variables.
        $template->vars("DISTNAME", $distname);
        $template->vars("MODULE", $pkgname);
        $template->vars("VERSION", $version);
        $template->vars("VENDORSUFFIX", "%{?_vendorsuffix:%{_vendorsuffix}}%{!?_vendorsuffix:%{_vendor}}");
        $template->vars("PACKAGER", "%{?_packager:%{_packager}}%{!?_packager:%{_vendor}}");
        $template->vars("VENDOR", "%{?_vendorinfo:%{_vendorinfo}}%{!?_vendorinfo:%{_vendor}}");
        $template->vars("DISTRIBUTION", "%{?_distribution:%{_distribution}}%{!?_distribution:%{_vendor}}");
        $template->vars("MODULENAME", $modname);
        $template->vars("DISTFILE", &basename($file));
        $template->vars("BUILDARCH", "noarch");
        $template->vars("CHANGELOG", sprintf("* %s Mezzanine <mezzanine\@kainx.org>\n- %s\n",
                                             POSIX::strftime("%a %b %d %Y", localtime()),
                                             "PDR auto-generated from CPAN by $progname"));
        $template->delimiter('@');

        # Generate the spec file
        $specfile = $template->subst($template->file());
        $ret = $template->generate("$pkgname/$specfile");
        if (!defined($ret)) {
            print $SAVE_STDERR "Error:  Unable to open template file -- $!\n";
        } elsif (! $ret) {
            print $SAVE_STDERR "Error:  Unable to create spec file $pkgname/$specfile -- $!\n";
        } else {
            print $SAVE_STDOUT "Package $pkgname created.\n";
        }
    }
}

# main() here is basically the same as main() in C
sub
main
{
    my @requests;
    my @valid_opts;
    my @distributions;
    local (*SAVE_STDIN, *SAVE_STDOUT, *SAVE_STDERR);

    # Save file descriptors
    open(SAVE_STDIN, "<&STDIN");
    open(SAVE_STDOUT, ">&STDOUT");
    open(SAVE_STDERR, ">&STDERR");
    $SAVE_STDIN = \*SAVE_STDIN;
    $SAVE_STDOUT = \*SAVE_STDOUT;
    $SAVE_STDERR = \*SAVE_STDERR;

    # Signal handling
    $SIG{"HUP"} = 'IGNORE';
    $SIG{"INT"} = \&handle_signal;
    $SIG{"TERM"} = \&handle_signal;
    $SIG{"QUIT"} = \&handle_fatal_signal;
    $SIG{"ILL"} = \&handle_fatal_signal;
    $SIG{"ABRT"} = \&handle_fatal_signal;
    $SIG{"FPE"} = \&handle_fatal_signal;
    $SIG{"SEGV"} = \&handle_fatal_signal;
    $SIG{"BUS"} = \&handle_fatal_signal;
    $SIG{"TSTP"} = \&handle_fatal_signal;
    $SIG{"TTIN"} = \&handle_fatal_signal;
    $SIG{"TTOU"} = \&handle_fatal_signal;

    # Set up the basic variables
    $progname = "perlpkg";
    $version = "0.2";
    #&print_usage_info() if (!scalar(@ARGV));
    umask 022;

    # See the Getopt::Long man page for details on the syntax of this line
    @valid_opts = ("h|help", "v|version", "d|debug", "s|search", "L|local",
                   "t|template=s", "p|pkgonly", "n|nodeps", "u|update");
    Getopt::Long::Configure("no_getopt_compat", "bundling", "no_ignore_case");
    Getopt::Long::GetOptions(@valid_opts);

    # Post-parse the options stuff
    select STDOUT; $| = 1;
    if ($opt_v) {
        # Do not edit this variable.  It is updated automatically by CVS when you commit
        my $rcs_info = 'CVS Revision $Revision: 1.5 $ created on $Date: 2005/05/07 05:26:19 $ by $Author: mej $ ';

        $rcs_info =~ s/\$\s*Revision: (\S+) \$/$1/;
        $rcs_info =~ s/\$\s*Date: (\S+) (\S+) \$/$1 at $2/;
        $rcs_info =~ s/\$\s*Author: (\S+) \$ /$1/;
        print "\n";
	print "$progname $version by Michael Jennings <mej\@eterm.org>\n";
        print "Copyright (c) 2001, Michael Jennings\n";
        print "  ($rcs_info)\n";
        print "\n";
	return MEZZANINE_SUCCESS;
    } elsif ($opt_h) {
	&print_usage_info();   # Never returns
    }
    &debug_set($opt_d);
    open(STDIN, "</dev/null");
    if (!&debug_get()) {
        open(STDOUT, ">/dev/null");
        open(STDERR, ">/dev/null");
    }
    $pkgonly = (($opt_p) ? (1) : (0));
    $handle_build_deps = (($opt_n) ? (0) : (1));
    $update = (($opt_u) ? (1) : (0));
    $local_mode = (($opt_L) ? (1) : (0));
    $save_pwd = &getcwd();

    # Create template object for new spec file.
    $template = new Mezzanine::Template;
    if ($opt_t) {
        if (-d $opt_t) {
            $template->directory($opt_t);
        } elsif (-f $opt_t) {
            $template->file(&basename($opt_t));
            $template->directory(&dirname($opt_t));
        }
    }
    if (! $template->file()) {
        $template->file('perl-@DISTNAME@.spec');
    }
    $template->find($template->directory());

    # Search CPAN for packages.
    if (! $local_mode) {
        print $SAVE_STDOUT "Searching CPAN, please wait....\n";
        &create_cpan_list();
    }

    if ($update && !scalar(@ARGV)) {
        local *RPMQA;

        $handle_build_deps = 0;
        if (open(RPMQA, "rpm -qa |")) {
            my $line;

            while ($line = <RPMQA>) {
                my @tmp;

                chomp($line);
                next if ($line !~ /^perl-\D+/);
                $line =~ s/^perl-(.+)-\d+[^-]+-[^-]+$/$1/;
                #print $SAVE_STDOUT "xxx$line\n";
                @tmp = grep { &basename($_) =~ /^\Q$line\E-\d+/ } keys(%distributions);
                if (scalar(@tmp) > 1) {
                    my $latest = shift @tmp;

                    foreach my $f (@tmp) {
                        if (&rpm_compare_versions($latest, $f) < 0) {
                            $latest = $f;
                        }
                    }
                    push @requests, $latest;
                } else {
                    push @requests, @tmp;
                }
            }
            if (&debug_get()) {
                printf $SAVE_STDOUT ("Got packages:  %s.\n",
                                     join(", ", @requests));
            }
        }
    } else {
        @requests = @ARGV;
    }
    foreach my $req (@requests) {
        if (-s $req) {
            @distributions = ($req);
        } elsif (($req =~ /\//) || ($req =~ /-/)) {
            @distributions = grep { $_ =~ $req } keys(%distributions);
        } else {
            @distributions = grep { grep { $_ =~ $req } @{$distributions{$_}{"MODLIST"}} } keys(%distributions);
        }

        if ($opt_s || scalar(@distributions) != 1) {
            if (scalar(@distributions) > 1) {
                print $SAVE_STDOUT "Distributions which contain $req:\n";
                foreach my $dist (sort(@distributions)) {
                    my @mods = grep { $_ =~ $req } @{$distributions{$dist}{"MODLIST"}};

                    printf $SAVE_STDOUT "%-40s (%s)\n", &basename($dist),
                        ((!scalar(@mods))
                         ? ("none")
                         : ((scalar(@mods) > 3)
                            ? ("$mods[0], $mods[1], $mods[2], ...")
                            : (join(", ", @mods))
                           )
                        );
                }
            } elsif (scalar(@distributions)) {
                my $dist = $distributions[0];

                print $SAVE_STDOUT "Distribution $dist contains:\n";
                foreach my $mod (@{$distributions{$dist}{"MODLIST"}}) {
                    print $SAVE_STDOUT "     $mod\n";
                }
            } else {
                print $SAVE_STDOUT "Nothing found for $req.\n";
            }
            next;
        }

        if (! $local_mode) {
            &build(0, @distributions);
        } else {
            push @built, @distributions;
        }
        chdir($save_pwd);
    }

    if (scalar(@tried)) {
        print $SAVE_STDOUT "Downloaded the following:\n";
        foreach my $file (sort { &basename($a) cmp &basename($b) } @tried) {
            printf $SAVE_STDOUT "     %s\n", &basename($file);
        }
    }
    &package_perl_dist(@built);

    return MEZZANINE_SUCCESS;
}

exit &main();
