pkgsort

#!/usr/bin/perl -w
#
# pkgsort -- Tool for sorting packages
# 
# Copyright (C) 2001-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: pkgsort,v 1.27 2007/02/27 21:29:36 mej Exp $
#

# Include the Perl Modules we need
require POSIX;
require Getopt::Long;
use Mezzanine::Util;

# Print usage information
sub
print_usage_info
{
    print "\n";
    $leader = "$progname $version Usage Information";
    $underbar = $leader;
    $underbar =~ s/./-/g;
    print "$leader\n$underbar\n";
    print "\n";
    print "  Syntax:   pkgsort [ 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 --sort <flag(s)>              Specify which criterion to sort on\n";
    print "    -f --format <type>               Specify the output format (names, files, prod)\n";
    print "    -F --force                       Ignore missing dependencies and file conflicts\n";
    print "    -D --dir <directory>             Specify one or more directories from which to take packages\n";
    print "    -l --list <file>                 Take the input package list from \"file\" instead of the command line\n";
    print "    -o --outfile <file>              Output the resulting package list to \"file\" instead of stdout\n";
    print "    -m --mode <mode>                 Specify either \"source\" or \"binary\" package resolution\n";
    print "\n";
    print "Valid sort flags are:  a for alphabetical by binary package\n";
    print "                       d for dependency\n";
    print "                       p for provisions\n";
    print "                       s for alphabetical by source package\n";
    print "                       r to reverse the sort order (in addition to one of the above flags)\n";
    print "                       n for no sorting\n";
    print "\n";
    exit(MEZZANINE_SUCCESS);
}

sub
get_package_list
{
    my $filename = $_[0];
    my $line;
    my @pkgs;
    local *LISTFILE;

    open(LISTFILE, $filename) || return @pkgs;
    dprint "Reading package list from $filename\n";
    while (<LISTFILE>) {
        chomp($line = $_);
        # Skip comments and empty lines
        next if ($line =~ /^\#/ || $line =~ /^\s*$/);

        # These lines strip leading and trailing whitespace, then grab the contents of
        # the line before any intervening spaces but after any slashes.
        $line =~ s/^\s+//;
        $line =~ s/\s+$//;
        $line =~ s/^.*\///g;
#        if ($line =~ /^\S+\s+(-\S+.*)$/) {
#            $flags = $1;
#        }
        $line =~ s/^(\S+)\s+.*$/$1/;

        # Skip lines with colons (product variables from product files)
        next if ($line =~ /:/);

        # If we get here, what remains is a package
        push @pkgs, $line;
#        if ($flags) {
#            $flags{$line} = $flags;
#            dprint "Set flags for $line to $flags{$line}\n";
#        }
    }
    close(LISTFILE);
    dprint "Got package list:  ", join(" ", @pkgs), "\n";
    return @pkgs;
}

sub
get_srpm_for_rpm
{
    my $rpm = shift;
    my ($line, $cmd, $srpm);
    local *CMD;

    $cmd = "pkgtool -qs -p $rpm";
    open(CMD, "$cmd 2>&1 |") || &fatal_error("Unable to execute pkgtool -- $!\n");
    while (<CMD>) {
        chomp($line = $_);
        if ($line =~ /^Source:  (.*)$/) {
            $srpm = $1;
            last;
        } else {
            eprint "$line\n";
        }
    }
    close(CMD);
    if ($? != MEZZANINE_SUCCESS) {
        &fatal_error("Query of $rpm failed (error $?).\n");
    }
    return $srpm;
}

sub
find_packages
{
    my @pkgs = @_;
    my (@contents, @rpms, @new_pkgs);
    my $i;
    local *DIR;

    foreach my $dir (@pkgdirs) {
        my @tmp;

        @tmp = &grepdir(sub {/(?<!src)\.rpm$/}, $dir);
        push @contents, @tmp;
    }

    foreach my $rpm (@contents) {
        my ($srpm, $spkg, $pkg, $ver, $rel);

        ($pkg, undef, undef, undef) = &parse_rpm_name($rpm);
        dprint "Checking $pkg ($rpm)...\n";
        if ($have_cache{$rpm}) {
            if (grep($_ eq $pkg || ($mode eq "src" && $_ eq $src_rpm{$src_package{$pkg}}) || $_ eq $rpm, @pkgs)) {
                xpush @new_pkgs, $pkg;
            }
            next;
        }
        if ($mode eq "src") {
            $srpm = &get_srpm_for_rpm($rpm);
            $srpm =~ m/^([^\/]+)-([^-\/]+)-([^-\/]+)\.\w+\.rpm$/;
            ($spkg, $ver, $rel) = ($1, $2, $3);
            dprint "Package $pkg from $spkg $ver-$rel ($srpm)\n";
            next if (scalar(@pkgs) && !grep($_ eq $pkg || $_ eq $spkg || $_ eq $rpm, @pkgs));
            xpush @{$bin_packages{$spkg}}, $pkg;
            if (defined($src_version{$spkg})) {
                if ($src_version{$spkg} ne $ver || $src_release{$spkg} ne $rel) {
                    eprint "Multiple versions of $spkg found:  $spkg-$ver-$rel (new) vs. $spkg-$src_version{$spkg}-$src_release{$spkg} (old)\n";
                    if (-t) {
                        my $ans;

                        print "Shall I replace the old one with the new one?\n";
                        chomp($ans = <STDIN>);
                        if ($ans =~ /^\s*y(es)?\s*$/i) {
                            print "Using $rpm for $pkg\n";
                            undef @{$rpm_list{$pkg}};
                            push @{$rpm_list{$pkg}}, $rpm;
                        } else {
                            print "Ignoring $rpm\n";
                            next;
                        }
                    } else {
                        print "I will ignore $rpm\n";
                        next;
                    }
                }
            }
            $src_version{$pkg} = $ver;
            $src_release{$pkg} = $rel;
            $src_package{$pkg} = $spkg;
            $src_rpm{$spkg} = $srpm;
        } else {
            next if (scalar(@pkgs) && !grep($_ eq $pkg || $_ eq $rpm, @pkgs));
        }
        xpush @new_pkgs, $pkg;
        xpush @{$rpm_list{$pkg}}, $rpm;
    }
    if ($sort_method eq "n") {
        my @tmp;

        foreach my $pkg (@pkgs) {
            if (grep($_ eq $pkg, @new_pkgs)) {
                push @tmp, $pkg;
            }
        }
        @new_pkgs = @tmp;
    }
    foreach my $pkg (@pkgs) {
        if (!grep($_ eq $pkg, @new_pkgs)) {
            eprint "No package files found for $pkg\n";
        }
    }
    if (!scalar(@new_pkgs)) {
        &fatal_error("No packages found.\n");
    }
    return @new_pkgs;
}

# Returns 1 or 0 based on whether or not the package named in the
# first parameter depends on the package named in the second parameter.
# If the third parameter is non-zero, *all* requirements of the first
# package are compared with each of the provisions of the second; if the
# third parameter is non-existent or 0, only the package name is checked.
# If the second package is not supplied, return a list of the requirements
# of the first package.
sub
pkg_depends_on
{
    if (!defined($requires{$_[0]})) {
        return 0;
    } elsif ($_[1]) {
        # Check for exact matches first.
        if (grep($_ eq $_[1], @{$requires{$_[0]}})) {
            return 1;
        }
        # If they passed a non-zero 3rd parameter, only check exact matches
        if ($_[2] || !defined($provides{$_[1]})) {
            return 0;
        }
        # Next, check all of what $_[1] provides to see if $_[0] requires any of it
        foreach my $prov (@{$provides{$_[1]}}) {
            if (grep($_ eq $prov, @{$requires{$_[0]}})) {
                return 1;
            }
        }
        # No matches, return false
        return 0;
    } else {
        return @{$requires{$_[0]}};
    }
}

# Adds a dependency on the second parameter for the package listed in the
# first parameter, but only if the two parameters are not the same and
# the dependency doesn't already exist.
sub
pkg_add_dep
{
    return if ($_[0] eq $_[1]);
    xpush @{$requires{$_[0]}}, $_[1];
    xpush @{$what_requires{$_[1]}}, $_[0];
}

# Return 1 or 0 based on whether or not the package listed in the first
# parameter provides the capability given as the second parameter, or
# the list of provisions of the first parameter if the second is missing.
sub
pkg_provides
{
    if (!defined($provides{$_[0]})) {
        return 0;
    } elsif ($_[1]) {
        return scalar(grep($_ eq $_[1], @{$provides{$_[0]}}));
    } else {
        return @{$provides{$_[0]}};
    }
}

# Adds a capability of the second parameter to the package in the first.
sub
pkg_add_cap
{
    xpush @{$provides{$_[0]}}, $_[1];
    xpush @{$what_provides{$_[1]}}, $_[0];
}

# For each of the third, fourth, fifth, etc. parameters, add an implicit
# (forced) dependency on the second parameter if they depend on the first.
# This can be used, for example, to add a dependency on "fileutils" for any
# package that depends on "/bin/sh" since a dependency on /bin/sh generally
# signals a shell script, and shell scripts tend to need the programs which
# are supplied by the "fileutils" package.
sub
add_implicit_dependency
{
    my $old_dep = shift;
    my $new_dep = shift;
    my @pkgs = @_;
    my @tmp;

    # For each package in $_[2..] ...
    foreach my $pkg (@pkgs) {
        # ... if it depends on $_[0], and it's not $_[1], and $_[1] doesn't depend on it...
        if (&pkg_depends_on($pkg, $old_dep) && ($pkg ne $new_dep) && ! &pkg_depends_on($new_dep, $pkg)) {
            # ... make it depend on $_[1] too.
            &pkg_add_dep($pkg, $new_dep);
        }
    }
}

# Check for unresolved dependencies and conflicting files/capabilities
sub
consistency_check
{
    my @pkgs = @_;
    my $oops = 0;

    # Look for unresolved dependencies
    foreach my $pkg (keys %requires) {
        dprint "Checking dependencies for $pkg...";
        foreach my $dep (@{$requires{$pkg}}) {
            if (defined($what_provides{$dep})) {
                print STDERR "$dep ($what_provides{$dep}[0])..." if (&debug_get());
            } else {
                print STDERR "$dep (NONE)..." if (&debug_get());
                xpush @{$unresolved_deps{$dep}}, $pkg;
                $oops = 1;
            }
        }
        print STDERR "done.\n" if (&debug_get());
    }

    # Make sure no two packages provide the same thing
    foreach my $cap (keys %what_provides) {
        if (scalar(@{$what_provides{$cap}}) > 1) {
            @{$conflicts{$cap}} = @{$what_provides{$cap}};
            foreach my $pkg (@{$conflicts{$cap}}) {
                $force{$pkg} = 1;
            }
            $oops = 1;
        }
    }

    if ($oops) {
        if (scalar(%unresolved_deps)) {
            eprint "The following dependencies are unresolved:\n";
            foreach my $dep (keys %unresolved_deps) {
                my $pkg;

                chomp($pkg = `/bin/rpm -q --whatprovides $dep`);
                $pkg =~ s/-[^-]+-[^-]+$//;
                xpush @needed_pkgs, $pkg;
                eprint "    $dep is required by ", join(", ", @{$unresolved_deps{$dep}}), " [$pkg]\n";
            }
        }
        if (scalar(%conflicts)) {
            eprint "The following file/provision conflicts were found:\n";
            foreach my $cap (keys %conflicts) {
                eprint "    $cap is provided by ", join(", ", @{$conflicts{$cap}}), "\n";
                xpush @conflict_pkgs, join(" & ", @{$conflicts{$cap}});
            }
        }
        if (! $force) {
            eprint "Additional packages needed:  ", join(" ", @needed_pkgs), "\n";
            eprint "Conflicting packages:  ", join(", ", @conflict_pkgs), "\n\n";
            &fatal_error("Consistency check failed.  Aborting.\n");
        } else {
            print "Consistency check failed.  Resulting package set may not function properly.\n";
        }
    }

    # Go through the provides info and throw out any files/capabilities not required by other packages
    foreach my $pkg (keys %provides) {
        dprint "Checking provides for $pkg\n";
        for ($i = 0; $i < scalar(@{$provides{$pkg}}); ) {
            my $file = $provides{$pkg}[$i];
            my $found = 0;

            if (defined($what_requires{$file})) {
                dprint "Found package $what_requires{$file}[0] which requires $file\n";
                $i++;  # Keep this one and go on to the next one.
            } else {
                # Nothing requires this.  Junk it.
                splice(@{$provides{$pkg}}, $i, 1);
                delete $what_provides{$file};
            }
        }
        if (!scalar(@{$provides{$pkg}})) {
            # Package contains no files/capabilities needed by other packages.
            delete $provides{$pkg};
        }
    }
}

sub
query_packages
{
    my @pkgs = @_;
    my ($line, $cmd, $rpm, $prog);
    local *CMD;

    print "Gathering dependency information....\n";
    foreach my $pkg (@pkgs) {
        if (!defined($rpm_list{$pkg})) {
            eprint "No package found for $pkg!\n";
            next;
        }
        if ($debug) {
            dprint "Package $pkg:  ", join(", ", @{$rpm_list{$pkg}}), "\n";
        } else {
            print "$pkg  ";
        }
        @{$provides{$pkg}} = ($pkg);
        @{$what_provides{$pkg}} = ($pkg);
        # FIXME:  Should this stay enabled for "src" mode?  I'm not sure, but it breaks "bin" mode.
        #if ($pkg ne $src_package{$pkg}) {
        #    &pkg_add_dep($pkg, $src_package{$pkg});
        #}
        foreach my $rpm (@{$rpm_list{$pkg}}) {
            $cmd = "pkgtool -qd -p $rpm";

            next if ($have_cache{$rpm});
            open(CMD, "$cmd 2>&1 |") || &fatal_error("Unable to execute pkgtool -- $!\n");
            while (<CMD>) {
                chomp($line = $_);
                next if ($line =~ /^\s*$/);
                if ($line =~ /^Provides/ || $line =~ /^Contains/) {
                    $line =~ s/^\w+:  \s*(\S.+)\s*$/$1/;
                    $line =~ s/^\s+//;  $line =~ s/\s+$//;
                    next if ($pkg eq $line);
                    next if ($line =~ /^\// && -d $line);
                    &pkg_add_cap($pkg, $line);
                } elsif ($line =~ /^Requires/) {
                    $line =~ s/^\w+:  \s*//;
                    $line =~ s/\s+[-=<>lteqng]+\s+\S+$//;
                    $line =~ s/^\s+//;  $line =~ s/\s+$//;
                    next if ($line =~ /rpmlib\(\w+\)/);
                    &pkg_add_dep($pkg, $line);
                } else {
                    eprint "$line\n";
                }
            }
            close(CMD);
            if ($? != MEZZANINE_SUCCESS) {
                &fatal_error("Query of $rpm failed (error $?).\n");
            }
        }
    }
    print "\nQuery complete.\n";
}

# FIXME:  Move to Config.pm if this thing is needed again.
sub
write_cache
{
    my @pkgs = @_;
    local *CACHE;

    &mkdirhier("$ENV{HOME}/.mezz/pkgsort");
    open(CACHE, ">$ENV{HOME}/.mezz/pkgsort/cache") || return;
    foreach my $pkg (@pkgs) {
        print CACHE "S:$pkg|$src_package{$pkg}|$src_rpm{$src_package{$pkg}}|$src_version{$pkg}|$src_release{$pkg}\n" if ($mode eq "src");
        foreach my $rpm (@{$rpm_list{$pkg}}) {
            @s = stat($rpm);

            print CACHE "F:$pkg:$rpm:$s[9]\n";
        }
        print CACHE "P:$pkg|", join("|", @{$provides{$pkg}}), "\n" if (defined($provides{$pkg}));
        print CACHE "R:$pkg|", join("|", @{$requires{$pkg}}), "\n" if (defined($requires{$pkg}));
    }
    close(CACHE);
}

sub
read_cache
{
    my ($line, $pkg, $skip, $dep);
    my (@inp, @fstat);
    local *CACHE;

    open(CACHE, "<$ENV{HOME}/.mezz/pkgsort/cache") || return;
    while (<CACHE>) {
        chomp($line = $_);
        next if ($skip && $line !~ /^S/);
        if ($line =~ /^S:([^\|]+)\|/) {
            $pkg = $1;
            @inp = split("\Q|", $line);
            dprint "Found cache data for $pkg\n";
            $src_package{$pkg} = $inp[1];
            $src_rpm{$inp[1]} = $inp[2];
            $src_version{$pkg} = $inp[3];
            $src_release{$pkg} = $inp[4];
            xpush @{$bin_packages{$inp[1]}}, $pkg;
        } elsif ($line =~ /^F:/) {
            my $path;

            @inp = split(":", $line);
            $pkg = $inp[1];
            if (!(@fstat = stat($inp[2])) || ($fstat[9] > $inp[3])) {
                dprint "Cache data for $inp[2] ($pkg) is outdated.\n";
                next;
            } else {
                $have_cache{$inp[2]} = 1;
            }
            xpush @{$rpm_list{$pkg}}, $inp[2];
        } elsif ($line =~ /^P:([^\|]+)\|/) {
            $pkg = $1;
            @inp = split("\Q|", $line);
            shift @inp;
            dprint "Package $pkg provides:  ", join(", ", @inp), "\n";
            foreach my $dep (@inp) {
                &pkg_add_cap($pkg, $dep);
            }
        } elsif ($line =~ /^R:([^\|]+)\|/) {
            $pkg = $1;
            @inp = split("\Q|", $line);
            shift @inp;
            dprint "Package $pkg requires:  ", join(", ", @inp), "\n";
            foreach my $dep (@inp) {
                &pkg_add_dep($pkg, $dep);
            }
        }
    }
    close(CACHE);
}

sub
cmp_packages_by_dep_count
{
    my ($pkg1, $pkg2) = @_;
    my ($r1, $r2, $p1, $p2, $c1, $c2) = (0, 0, 0, 0, 0, 0);

    if (scalar(@_) != 2) {
        # If we were called by the sort() function, use $a and $b
        ($pkg1, $pkg2) = ($a, $b);
    }
    dprint "Comparing $pkg1 and $pkg2\n";
    $r1 = scalar(@{$requires{$pkg1}}) if (defined($requires{$pkg1}));
    $r2 = scalar(@{$requires{$pkg2}}) if (defined($requires{$pkg2}));
    $p1 = scalar(@{$provides{$pkg1}}) if (defined($provides{$pkg1}));
    $p2 = scalar(@{$provides{$pkg2}}) if (defined($provides{$pkg2}));

    # First compare by the number of dependencies.  If they're equal, compare by
    # the number of things provided.  If they're still equal, compare by the number
    # of files provided.
    if ($r1 != $r2) {
        # Whoever has less dependencies is less in the sort order
        return ($r1 <=> $r2);
    } elsif ($p1 != $p2) {
        # Whoever provides more is less in the sort order
        return ($p2 <=> $p1);  # Notice these are reversed
    } elsif ($c1 != $c2) {
        return ($c2 <=> $c1);  # These too
    }
    return ($pkg1 cmp $pkg2);
}

sub
cmp_packages_by_relation
{
    my ($pkg1, $pkg2) = @_;
    my (@requires, @provides, @tmp);
    my ($dep1, $dep2);

    $dep1 = &pkg_depends_on($pkg1, $pkg2);
    $dep2 = &pkg_depends_on($pkg2, $pkg1);

    dprint "Comparing $pkg1 and $pkg2:  dep1 $dep1, dep2 $dep2\n";
    if (! $dep1) {
        # Package 1 does not depend on package 2
        return ($dep2 ? -1 : 0);
    } else {
        # Package 1 depends on package 2
        if (! $dep2) {
            # Package 2 doesn't depend on package 1, so package 1 > package 2
            return 1;
        } else {
            my ($n, $lib_cnt1, $lib_cnt2);

            # Doh!  We have a circular dependency.
            dprint "Circular dependency detected between $pkg1 and $pkg2.\n";

            # Now here's the hard part.  What to do about circular dependencies.  First,
            # let's see if one supplies libs and the other doesn't or supplies less.
            # If so, more libs should come first.
            $lib_cnt1 = grep($_ =~ /^lib/, @{$provides{$pkg1}});
            $lib_cnt2 = grep($_ =~ /^lib/, @{$provides{$pkg2}});
            if ($lib_cnt1 != $lib_cnt2) {
                $n = $lib_cnt2 <=> $lib_cnt1;
            } else {
                # Doh!  They both provide the same number of libs, probably none.  What next?
                $n = &cmp_packages_by_dep_count($pkg1, $pkg2);
            }
            if ($n <= 0) {
                $nodeps{$pkg1} = 1;
            }
            if ($n >= 0) {
                $nodeps{$pkg2} = 1;
            }
        }
    }
    return 0;
}

# The dependency sorter works kind of like an insertion sort.  It plucks packages off
# the list one at a time and places them in a new list in sorted order.  By sorted order,
# I mean that it searches through the new list until it finds the first package which
# depends on it.  This location is stored while the rest of the list is searched for any
# packages the current package requires.  If there are none, it inserts itself into the
# list just before the package that requires it.  If one or more dependencies occur later
# in the list, it will insert itself immediately after the last one.
sub
dep_sort
{
    my @pkgs = @_;
    my @old_pkgs = @pkgs;
    my ($i, $ftr, $last_dep, $deps, $loc, $new_loc, $pkg, $cnt);  # $ftr stands for "first that requires"

    $cnt = scalar(@old_pkgs);

    foreach my $pkg (@old_pkgs) {
        $ftr = $last_dep = $loc = -1;
        if (defined($requires{$pkg})) {
            $deps = scalar(@{$requires{$pkg}});
        } else {
            $deps = 0;
        }

        for ($i = 0; $i < $cnt; $i++) {
            if ($pkgs[$i] eq $pkg) {
                $loc = $i;
                next;
            }
            if ($deps && &pkg_depends_on($pkg, $pkgs[$i])) {
                $last_dep = $i;
                $deps--;
            }
            if ($ftr != -1 && &pkg_depends_on($pkgs[$i], $pkg)) {
                $ftr = $i;
            }
        }

        if ($loc == -1) {
            &fatal_error("$pkg not found in list.  This can't happen!\n");
        }
        if ($ftr == -1) {
            # Nothing requires it, so put it at the end.
            $new_loc = -1;
        } elsif ($last_dep == $ftr) {
            # Circular dependency
            if ((&cmp_packages_by_relation($pkg, $pkgs[$ftr])) <= 0) {
                $new_loc = $ftr;
            } else {
                $new_loc = $ftr + 1;
            }
        } elsif ($last_dep > $ftr) {
            # Something that requires it appears before its own dependencies are satisfied.
            dprint "Sequence error, $last_dep > $ftr.\n";
            $new_loc = $last_dep + 1;
        } else {
            # This is how we like things to go.
            $new_loc = $ftr;
        }
        dprint "Sorting on $pkg:  loc $loc, ftr $ftr, last_dep $last_dep, new_loc $new_loc\n";
        next if ($new_loc == $loc);
        if ($new_loc > $loc) {
            $new_loc--;
        }
        # Remove it from where it is.
        splice(@pkgs, $loc, 1);
        # And put it where it goes.
        if ($new_loc == -1) {
            push @pkgs, $pkg;
        } else {
            splice(@pkgs, $new_loc, 0, $pkg);
        }
    }
    return @pkgs;
}

sub
sort_packages
{
    my @pkgs = @_;
    my $cnt = scalar(@pkgs);
    my ($changes, $func_start, $loop_start, $loop_end, $func_end, $n);
    local *OUTFILE;

    $func_start = (times)[0];
    $n = 0;
    return if ($cnt == 1);

    # Work around RedHat's incomplete dependency info by
    # making kernel-headers and procps depend on fileutils
    &add_implicit_dependency("/bin/sh", "fileutils", "kernel-headers", "procps");

    # First sort packages by the number of dependencies they have/fulfill
    if ($sort_method eq "p" || $sort_method eq "d") {
        @pkgs = sort cmp_packages_by_dep_count @pkgs;

        # Then brute-force check and fix the list until no changes are made
        if ($sort_method eq "d") {
#            do {
#                $loop_start = (times)[0];
#                ($changes, @pkgs) = &verify_list(@pkgs);
#                $loop_end = (times)[0];
#                $n++;
#                dprint "Verify pass \#$n took ", $loop_end - $loop_start, " seconds.\n";
#            } while ($changes);
            @pkgs = &dep_sort(@pkgs);
            &mark_list(@pkgs);
        }
    } elsif ($sort_method eq "a") {
        @pkgs = sort {$a cmp $b} @pkgs;
    } elsif ($sort_method eq "s") {
        @pkgs = sort {$src_package{$a} cmp $src_package{$b}} @pkgs;
    }
    if ($reverse_sort) {
        @pkgs = reverse @pkgs;
    }

    $func_end = (times)[0];
    dprint "Complete sort operation took ", $func_end - $func_start, " seconds and $n passes.\n";

    return @pkgs;
}

sub
mark_list
{
    my @pkgs = @_;
    my ($i, $j);

    for ($i = 0; $i <= $#pkgs; $i++) {
        for ($j = $i + 1; $j <= $#pkgs; $j++) {
            if (&cmp_packages_by_relation($pkgs[$i], $pkgs[$j]) > 0) {
                dprint "Dependency order error:  $pkgs[$i] ($i) depends on $pkgs[$j] ($j)\n";
                $nodeps{$pkgs[$i]} = 1;
            }
        }
    }
}

sub
verify_list
{
    my @pkgs = @_;
    my ($i, $j, $changes);

    for ($i = 0, $changes = 0; $i <= $#pkgs; $i++) {
        for ($j = $i + 1; $j <= $#pkgs; $j++) {
            if (&cmp_packages_by_relation($pkgs[$i], $pkgs[$j]) > 0) {
                my $tmp;

                dprint "Dependency order error:  $pkgs[$i] ($i) depends on $pkgs[$j] ($j)\n";
                if ((++$dep_error{"$pkgs[$i]/$pkgs[$j]"}) >= 10) {
                    eprint "Multi-level circular dependency detected.  Crap.\n";
                    return (0, @pkgs);
                }
                $changes++;
                $tmp = splice(@pkgs, $j, 1);
                splice(@pkgs, $i, 0, $tmp);
                dprint "Moved $tmp to position $i.  New order is $pkgs[$i], $pkgs[$i+1]\n";
            }
        }
    }
    return ($changes, @pkgs);
}

sub
sort_source_packages
{
    my @pkgs = @_;
    my @src_pkgs;

    foreach my $pkg (@pkgs) {
        xpush @src_pkgs, $src_package{$pkg};
    }
    return @src_pkgs;
}

sub
show_packages
{
    my @pkgs = @_;
    my @src_pkgs;

    if (($outfile eq "-") || !open(OUTFILE, ">$outfile")) {
        open(OUTFILE, ">&STDOUT");
    }

    if (substr($output_format, 0, 4) eq "prod") {
        my @pkg_list;

        if ($mode eq "src") {
            @pkg_list = &sort_source_packages(@pkgs);
        } else {
            @pkg_list = @pkgs;
        }
        foreach my $pkg (@pkg_list) {
            if ($mode eq "src") {
                print OUTFILE "# $pkg\n";
                print OUTFILE "contrib-rh/$src_rpm{$pkg}";
                if (scalar(@{$bin_packages{$pkg}})) {
                    my @tmp;

                    foreach my $bpkg (sort @{$bin_packages{$pkg}}) {
                        foreach my $rpm (sort @{$rpm_list{$bpkg}}) {
                            if ($rpm =~ /^(.+)-\Q$src_version{$bpkg}\E-\Q$src_release{$bpkg}.i386.rpm\E$/) {
                                push @tmp, "bin-rh/$1";
                            } else {
                                push @tmp, "bin-rh/$rpm";
                            }
                        }
                    }
                    print OUTFILE " bins=", join(',', @tmp);
                }
                print OUTFILE "\n\n";
            } else {
                my @tmp;

                foreach my $bpkg (@{$rpm_list{$pkg}}) {
                    push @tmp, &basename($bpkg);
                }
                print OUTFILE "bin-rh/", join(",bin-rh/", @tmp), "\n";
            }
        }
    } else {
        foreach my $pkg (@pkgs) {
            my $flag = "";

            if ($force{$pkg}) {
                $flag .= " --force";
            }
            if ($nodeps{$pkg}) {
                $flag .= " --nodeps";
            }
            if ($output_format eq "names") {
                print OUTFILE "$pkg$flag\n";
            } elsif ($output_format eq "files") {
                foreach my $rpm (sort @{$rpm_list{$pkg}}) {
                    print OUTFILE "$rpm$flag\n";
                }
            }
        }
    }
    close(OUTFILE);
}

# main() here is basically the same as main() in C
sub
main
{
    # Set up the basic variables
    $progname = "pkgsort";
    $version = "1.0";
    &print_usage_info() if (!scalar(@ARGV));
    undef %dep_error;
    umask 022;

    # See the Getopt::Long man page for details on the syntax of this line
    @valid_opts = ("h|help", "v|version", "d|debug", "D|dir=s", "l|list=s",
                   "o|outfile=s", "f|format=s", "s|sort=s", "F|force", "m|mode=s");
    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.27 $ created on $Date: 2007/02/27 21:29:36 $ 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-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);
    $outfile = ($opt_o ? $opt_o : "-");
    $force = $opt_F;
    if ($opt_m =~ /^b(in)?(ary)?$/i) {
        $mode = "bin";
    } elsif ($opt_m =~ /^s(rc|ource)?$/i) {
        $mode = "src";
    } else {
        $mode = "";
    }
    if ($opt_f) {
        if ($opt_f eq substr("names", 0, length($opt_f))) {
            $output_format = "names";
        } elsif ($opt_f eq substr("files", 0, length($opt_f))) {
            $output_format = "files";
        } elsif ($opt_f eq substr("prodfile", 0, length($opt_f))) {
            $output_format = "prodfile";
        } elsif ($opt_f eq substr("products", 0, length($opt_f))) {
            $output_format = "products";
        } else {
            eprint "Unrecognized output format:  $opt_f\n";
            eprint "Valid formats:  names, files, prodfile\n";
            $output_format = "files";
        }
    } else {
        $opt_f = "files";
    }
    $sort_method = ($opt_s ? $opt_s : "d");
    if ($sort_method =~ /r/) {
        $reverse_sort = 1;
        $sort_method =~ s/r//;
    } else {
        $reverse_sort = 0;
    }
    if ($sort_method !~ /^[adpsn]$/i) {
        eprint "Invalid sort flags:  $sort_method\n";
        eprint "Must be exactly one of a, d, p, s, or n, with an optional r\n";
        $sort_method = "d";
    }
    if ($opt_D) {
        @pkgdirs = split(/[:\s]/, $opt_D);
    } else {
        @pkgdirs = glob('$ENV{MEZZANINE_BUILDDIR}/RPMS/???*');
    }
    if ($opt_l) {
        @pkgs = &get_package_list($opt_l);
    } else {
        if (scalar(@ARGV)) {
            @pkgs = @ARGV;
        } else {
            @pkgs = ();
        }
    }

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

    &read_cache();
    @pkgs = &find_packages(@pkgs);
    if ($sort_method eq "p" || $sort_method eq "d") {
        &query_packages(@pkgs);
        &consistency_check(@pkgs);
    }
    @pkgs = &sort_packages(@pkgs);
    &write_cache(@pkgs);
    &show_packages(@pkgs);
    return MEZZANINE_SUCCESS;
}

exit &main();