perlpkg

#!/usr/bin/perl -w
#
# perlpkg -- Tool for packaging perl modules.
# 
# Copyright (C) 2004-2007, 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.9 2011/09/30 23:35:07 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', '$opt_x',
    '$opt_f';
use CPAN;
use POSIX;
use Getopt::Long;
use Mezzanine::Util;
use Mezzanine::Template;
use Mezzanine::RPM '&rpm_compare_versions';
use Mezzanine::Tar '&tar_show_contents';

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, $exact, $force);

# 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 "    -x --exact              Match exact distribution/module name only\n";
    print "    -f --force              Attempt to force CPAN to perform requested action\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 $name;
        my $file = $mod->cpan_file() || $mod->inst_file();
        my $installed = $mod->inst_version() || "";
        my $uptodate = $mod->uptodate();
        my $noarch = undef;

        if (substr($file, 0, 14) eq "Contact Author") {
            # Skip stuff we can't actually download.
            next;
        }
        if ($mod->as_glimpse() =~ /^\s*Module\s+[<= ]\s+(\S+)\s+.*$/) {
            $name = $1;
        } else {
            printf $SAVE_STDERR "Unparseable package metadata obtained from CPAN:  %s\n", $mod->as_glimpse();
            next;
        }
        #dprint "Got module:  $name ($file)\n";
        push @{$distributions{$file}{"MODLIST"}}, $name;
        push @{$distributions{$file}{"MODOBJLIST"}}, $mod;
        #next;
        if ($mod->can("dslip_status")) {
            my $dslip = $mod->dslip_status();

            if ($dslip && ref($dslip) && $dslip->{"L"}) {
                $noarch = (($dslip->{"L"} eq 'p' || $dslip->{"L"} eq 'h') ? (1) : (0));
            }
        }
        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));
        }
        if (defined($noarch)) {
            if (defined($distributions{$file}{"NOARCH"})) {
                if ($distributions{$file}{"NOARCH"} && !($noarch)) {
                    $distributions{$file}{"NOARCH"} = 0;
                    #print $SAVE_STDERR "Noarch for $file turned off by $name ($dslip->{L}).\n";
                }
            } else {
                $distributions{$file}{"NOARCH"} = $noarch;
                #print $SAVE_STDERR "Noarch for $file set to $noarch by $name ($dslip->{L}).\n";
            }
        }
    }
}

# Sort distributions in a sane fashion
sub
sort_distributions($@)
{
    my $req = shift;

    #print $SAVE_STDERR "Sorting distributions based on $req\n";
    return sort {
            my ($a_mod_list, $b_mod_list);
            my ($a_exact_matches, $b_exact_matches);
            my ($a_start_matches, $b_start_matches);
            my ($a_matches, $b_matches);

            if (defined($distributions{$a}{"MODLIST"})) {
                $a_mod_list = $distributions{$a}{"MODLIST"};
            } else {
                $a_mod_list = [];
            }
            if (defined($distributions{$b}{"MODLIST"})) {
                $b_mod_list = $distributions{$b}{"MODLIST"};
            } else {
                $b_mod_list = [];
            }

            # Sort method:  Distributions that contain the exact request come first,
            # then any distributions where the request matches the beginning of a module,
            # then any distributions that contain a partial match (on word boundaries).
            # After that, sort lexically.
            $a_exact_matches = scalar(grep { $_ eq $req } @{$a_mod_list});
            $b_exact_matches = scalar(grep { $_ eq $req } @{$b_mod_list});
            if ($a_exact_matches != $b_exact_matches) {
                return ($b_exact_matches <=> $a_exact_matches);
            }
            $a_start_matches = scalar(grep { $_ =~ /^\Q$req\E\b/ } @{$a_mod_list});
            $b_start_matches = scalar(grep { $_ =~ /^\Q$req\E\b/ } @{$b_mod_list});
            if ($a_start_matches != $b_start_matches) {
                return ($b_start_matches <=> $a_start_matches);
            }
            $a_matches = scalar(grep { $_ =~ /\b\Q$req\E\b/ } @{$a_mod_list});
            $b_matches = scalar(grep { $_ =~ /\b\Q$req\E\b/ } @{$b_mod_list});
            if ($a_matches != $b_matches) {
                return ($b_matches <=> $a_matches);
            }
            return (&basename($a) cmp &basename($b));
        } @_;
}

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 (!($force) && !($update) && $distributions{$file}{"INSTALLED"}) {
            print $SAVE_STDOUT "${depth_str}Skipping installed package $file\n";
            next;
        } elsif (!($force) && $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...";
        }
        if ($force) {
            $dist_obj->force("make");
        } else {
            $dist_obj->make();
        }
        $href = $dist_obj->prereq_pm();
        #printf $SAVE_STDOUT "Buildreqs:  %s\n\n", &examine_object($href);
        push @tried, $file;
        if ($href && ref($href) eq "HASH" && exists($href->{"build_requires"})) {
            $href = $href->{"build_requires"};
        }
        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...";
                    if ($force) {
                        $dist_obj->force("make");
                    } else {
                        $dist_obj->make();
                    }
                }
            } else {
                print $SAVE_STDOUT "Not handling dependencies:  ", join(", ", map { &basename($_) } keys(%{$href})), "\n";
            }
        }
        if (! $pkgonly) {
            print $SAVE_STDOUT "testing...";
            if ($force) {
                $dist_obj->force("test");
            } else {
                $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;
        }

        if (!defined($distributions{$file}{"NOARCH"})) {
            # FIXME:  Do test build?  For now, default to "noarch"
            print $SAVE_STDERR "Warning:  No architecture information for $file.  Assuming \"noarch.\"\n";
            $distributions{$file}{"NOARCH"} = 1;
        }

        # Assign variables.
        $template->vars("DISTNAME", $distname);
        $template->vars("MODULE", $pkgname);
        $template->vars("VERSION", $version);
        $template->vars("VENDORSUFFIX", "%{?_vendorsuffix}%{!?_vendorsuffix:mz}%{?dist}");
        $template->vars("PACKAGER", "%{?_packager}%{!?_packager:Mezzanine <mezzanine\@kainx.org>}");
        $template->vars("VENDOR", "%{?_vendorinfo}%{!?_vendorinfo:https://github.com/kainx/mezzanine/}");
        $template->vars("DISTRIBUTION", "%{?_distribution}%{!?_distribution:%{_vendor}}");
        $template->vars("MODULENAME", $modname);
        $template->vars("DISTFILE", &basename($file));
        $template->vars("BUILDARCH", (($distributions{$file}{"NOARCH"}) ? ("\nBuildArch: 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.3";
    #&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", "x|exact",
                   "f|force");
    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.9 $ created on $Date: 2011/09/30 23:35:07 $ 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) 2004-2007, 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));
    $exact = (($opt_x) ? (1) : (0));
    $force = (($opt_f) ? (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 --qf \"\%{name}-\%{version}-\%{release}\\n\" \"name=perl*\" |")) {
            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 { (($exact) ? ($_ eq $req) : ($_ =~ $req)) } keys(%distributions);
        } else {
            @distributions = grep {
                                 grep { (($exact) ? ($_ eq $req) : ($_ =~ $req)) } @{$distributions{$_}{"MODLIST"}}
                             } keys(%distributions);
        }
        @distributions = &sort_distributions($req, @distributions);

        if ($opt_s || scalar(@distributions) != 1) {
            if (scalar(@distributions) > 1) {
                print $SAVE_STDOUT "Distributions which contain $req:\n";
                foreach my $dist (@distributions) {
                    my @mods = grep { (($exact) ? ($_ eq $req) : ($_ =~ $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 {
                if ($exact) {
                    print $SAVE_STDOUT "No exact matches found for $req.  Try without -x.\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();