#!/usr/bin/perl -w
#
# uptool -- Tool for automating updates from an FTP site
# 
# 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: uptool,v 1.18 2004/06/04 17:16:40 mej Exp $
#

# Include the Perl Modules we need
use POSIX;
use Getopt::Long;
use Net::FTP;
use Mezzanine::Util;
use Mezzanine::Pkg;
use Mezzanine::RPM;

# 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:   uptool [ 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 "    -D --dir <arch>:<directory>      Map an arch (SRPMS, i386, etc.) to a download path\n";
    print "    -m --match --regexp <regexp>     Only pay attention to files that match this regexp\n";
    print "    -H --hash [ <bytes> ]            Print hash marks every <bytes> bytes during download\n";
    print "\n";
    exit(MEZZANINE_SUCCESS);
}

sub
get_remote_listing($$)
{
    my ($session, $path) = @_;
    my (@flist, @tmp);

    print "Getting directory listing for $path...\n";
    if (! $session->cwd($path)) {
        eprint "Path $path does not exist on remote host.\n";
        return @flist;
    }
    @tmp = $session->dir();
    foreach my $line (@tmp) {
        my @fields;

        next if ($line !~ /^[-dl]/);
        @fields = split(/\s+/, $line);
        if ($fields[8] =~ $match) {
            my $fname = $fields[8];
            my $pkg;
            my @parts;

            push @flist, $fname;
            @parts = &parse_rpm_name($fname);
            $pkg = $parts[0];
            push @{$rpkgs->{$pkg}{VER}}, $parts[1];
            push @{$rpkgs->{$pkg}{REL}}, $parts[2];
            push @{$rpkgs->{$pkg}{ARCH}}, $parts[3];
            push @{$rpkgs->{$pkg}{FILES}}, $fname;
            #dprint "Adding remote package $pkg:  $fname\n";
        }
    }
    return @flist;
}

sub
get_local_listing($)
{
    my $path = $_[0];
    my @flist;

    if ($path !~ /^\//) {
        $path = &getcwd() . $path;
    }
    #dprint "Looking for files matching $match in $path\n";
    @flist = &grepdir(sub { /$match/ }, $path);
    foreach my $fname (@flist) {
        my $pkg;
        my @parts;

        $fname = &basename($fname);
        @parts = &parse_rpm_name($fname);
        $pkg = $parts[0];
        push @{$lpkgs->{$pkg}{VER}}, $parts[1];
        push @{$lpkgs->{$pkg}{REL}}, $parts[2];
        push @{$lpkgs->{$pkg}{ARCH}}, $parts[3];
        push @{$lpkgs->{$pkg}{FILES}}, $fname;
        #dprint "Adding local package $pkg:  $fname\n";
    }
    return @flist;
}

sub
compare_packages()
{
    my ($p1, $p2) = @_;
    my $ans;
    my $cache_file = "$ENV{HOME}/.mezz/uptool/cache";
    local *CACHE;

    # FIXME:  Use new Config.pm if this thing ever gets used again.
    if (-s $cache_file) {
        if (open(CACHE, $cache_file)) {
            my @tmp;

            @tmp = <CACHE>;
            close(CACHE);
            if (scalar(@tmp = grep(/$p1/ && /$p2/, @tmp))) {
                my $line = $tmp[0];
                my ($n1, $n2, $sign);

                dprint "Found cache line $line";  # $line already has a newline
                ($n1, $sign, $n2) = split(" ", $line);
                return (($n1 eq $p1) ? ($sign eq '<') : ($sign eq '>'));
            } else {
                dprint "$p1 and $p2 not found in cache.\n";
            }
        }
    }

    print "Is $p2 more recent than $p1 [y/n]? ";
    chomp($ans = <STDIN>);
    if ($ans =~ /^\s*y(es)?\s*$/i) {
        &mkdirhier(&dirname($cache_file));
        open(CACHE, ">>$cache_file");
        print CACHE "$p1 < $p2\n";
        close(CACHE);
        return 1;
    } else {
        &mkdirhier(&dirname($cache_file));
        open(CACHE, ">>$cache_file");
        print CACHE "$p1 > $p2\n";
        close(CACHE);
        return 0;
    }
}

sub
compare_lists($$)
{
    my ($session, $dest) = @_;

    foreach my $pkg (sort keys %{$rpkgs}) {
        my @remote_list = @{$rpkgs->{$pkg}{FILES}};
        my @tmp;
        my ($rpm, $i);

        # @remote_list contains an array of all RPM files for that particular
        # package name.  It is *not* a complete list of all remote RPM files.
        print "Checking $pkg...\n";

        # Find the most recent version of that package on the remote site.
        for ($rpm = 0, $i = 0; $i < scalar(@remote_list); $i++) {
            my ($v1, $v2, $x);

            $v1 = "$rpkgs->{$pkg}{VER}[$rpm]-$rpkgs->{$pkg}{REL}[$rpm]";
            $v2 = "$rpkgs->{$pkg}{VER}[$i]-$rpkgs->{$pkg}{REL}[$i]";
            dprint "Comparing $v1 and $v2.\n";
            $x = &rpm_compare_versions($v1, $v2);
            if ($x) {
                dprintf("\&rpm_compare_versions():  $v1 %s $v2\n",
                        (($x > 0) ? ('>') : ('<')));
                $rpm = $i;
#            } elsif (&compare_packages($rpm, $remote_list[$i])) {
#                dprint "\&rpm_compare_versions():  $v1 == $v2\n";
#                $rpm = $i;
            } else {
                dprint "\&rpm_compare_versions():  $v1 == $v2\n";
            }
        }

        dprint "Chose $remote_list[$rpm].\n";
        for ($i = 0; $i < scalar(@remote_list); $i++) {
            if (($rpkgs->{$pkg}{VER}[$i] eq $rpkgs->{$pkg}{VER}[$rpm])
                && ($rpkgs->{$pkg}{REL}[$i] eq $rpkgs->{$pkg}{REL}[$rpm])) {
                xpush @tmp, $rpkgs->{$pkg}{FILES}[$i];
            }
        }

        # Now, download all the matching files.
        dprint "File list for $pkg:  ", join(", ", @tmp), "\n";
        foreach my $rpm (@tmp) {
            # If we have it, continue.
            if (defined($lpkgs->{$pkg}) && grep(/^\Q$rpm\E$/, @{$lpkgs->{$pkg}{FILES}})) {
                dprint "Not downloading $rpm (", join(", ", @{$lpkgs->{$pkg}{FILES}}), ").  Next!\n";
                next;
            }

            # We don't have it, so get it.
            print "Downloading $rpm...\n";
            if (! $session->get($rpm, "$dest/$rpm")) {
                eprint "Unable to download $rpm\n";
            } else {
                my $arch;

                $rpm =~ m/\.([^\.]+)\.rpm$/;
                $arch = $1;
                push @{$adds{$dest}}, $rpm;
                if (defined($lpkgs->{$pkg})) {
                    push @{$removes{$dest}}, grep(/\.$arch\.rpm/, @{$lpkgs->{$pkg}{FILES}});
                }
            }
        }
    }
}

sub
show_cmds($)
{
    my $dir = $_[0];

    return if (!scalar(@{$adds{$dir}}));
    print "(cd $dir";
    if (scalar(@{$removes{$dir}})) {
        print " && revtool -r ", join(" ", @{$removes{$dir}});
    }
    print " && revtool -a ", join(" ", @{$adds{$dir}}), ")";
}

# Driver function
sub
fetch_updates(@)
{
    my @urls = @_;
    my ($session, $url, $pkgcnt, $tries, $last_login);
    my ($proto, $host, $port, $userid, $passwd, $path);

    undef $session;
    $last_login = "";

    foreach my $url (@urls) {
        # Set defaults for stuff.
        ($port, $userid, $passwd) = ("21", "anonymous", "info\@kainx.org");

        ### Parse the URL into its components.

        # Get rid of the ftp:// part first
        if ($url =~ m!://!) {
            $url =~ s!^([^:]+)://!!;
            $proto = $1;
        }
        # Now get everything up to that first /
        $url =~ s!^([^/]+)/!/!;
        $host = $1;
        # What's left over is the path
        $path = $url;
        # Now split the userid, passwd, and port off of $host if needed.
        if ($host =~ /^([^@]+)@([^@]+)$/) {
            ($userid, $host) = ($1, $2);
        }
        if ($userid =~ /^([^:]+):(.*)$/) {
            ($userid, $passwd) = ($1, $2);
        }
        if ($host =~ /^(.+):(\d+)$/) {
            ($host, $port) = ($1, $2);
        }
        return 0 if (! $host || ! $path);
        $path =~ s/\/$//;

        ### Start the FTP session
        if ($last_login ne "$userid\@$host:$port") {
            if (defined($session)) {
                print "Closing session...\n";
                $session->quit();
            }

            for ($session = undef; 1;) {
                for ($tries = 0; $tries < 5; $tries++) {
                    if (! $session) {
                        print "Opening FTP session to $host:$port...\n";
                        $session = Net::FTP->new($host, Debug => 0, Port => $port, Passive => 1);
                    }
                    print "Trying to login as $userid...";
                    if ($session && $session->login($userid, $passwd)) {
                        print "succeeded.\n";
                        $tries = 0;
                        last;
                    } else {
                        print "failed.  Sleeping...\n";
                        sleep 2;
                    }
                }
                if ($tries) {
                    print "Unable to login after 5 tries.  Closing connection and waiting for retry.\n";
                    $session->quit() if ($session);
                    sleep 8;
                } else {
                    last;
                }
            }
            $session->binary();
            if ($hash) {
                my $bytes;

                if ($hash =~ /^(\d+)m$/i) {
                    $bytes = $1 * 1024 * 1024;
                } elsif ($hash =~ /^(\d+)k$/i) {
                    $bytes = $1 * 1024;
                } else {
                    $bytes = $hash;
                }
                dprint "Printing hash marks every $bytes bytes.\n";
                $session->hash(\*STDOUT, $bytes);
            }
        }
        $last_login = "$userid\@$host:$port";

        foreach my $p (keys %dir) {
            undef %{$rpkgs};
            undef %{$lpkgs};
            @rpkgs = &get_remote_listing($session, "$path/$p");
            if (scalar(@rpkgs)) {
                @lpkgs = &get_local_listing($dir{$p});
                &compare_lists($session, $dir{$p});
            }
        }
    }

    print "Closing session...\n";
    $session->quit();

    $pkgcnt = 0;
    foreach my $dir (keys %adds) {
        $pkgcnt += scalar(@{$adds{$dir}});
        &show_cmds($dir);
        print " ; ";
    }
    if ($pkgcnt > 0) {
        print "true\n";
    }

    print "Update complete.  Found $pkgcnt outdated/missing packages.\n";
    return 1;
}

# main() here is basically the same as main() in C
sub
main
{
    my $ret = MEZZANINE_SUCCESS;

    # Set up the basic variables
    $progname = "uptool";
    $version = "2.0";
    &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", "D|dir=s@", "m|match|regexp=s", "H|hash: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.18 $ created on $Date: 2004/06/04 17:16:40 $ 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);
    $hash = $opt_H;
    if (scalar(@opt_D)) {
        foreach my $tmp (@opt_D) {
            my ($arch, $dir) = split(":", $tmp, 2);

            if ($dir !~ /^\//) {
                $dir = &getcwd() . "/" . $dir;
            }
            dprint "Architecture $arch mapped to $dir\n";
            $dir{$arch} = $dir;
        }
    } else {
        dprint "No architecture mapping requested.\n";
        $dir{"."} = ".";
    }
    if ($opt_m) {
        $match = $opt_m;
    } else {
        $match = "\\.rpm\$";
    }
    dprint "Files must match $match\n";

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

    return (!&fetch_updates(@ARGV));
}

exit &main();
