#!/usr/bin/perl

use strict;
use warnings;
use Net::FTP;
use Net::Telnet;

$| = 1;

# Seems that the only working Perl is on...
use constant TELNETHOST => 'td184.testdrive.hp.com';

# ...and FTP only works on...
use constant FTPHOST => 'td183.testdrive.hp.com';

use constant TESTDRIVERC => glob('~/.testdriverc');
use constant CLEANUP     => qr{^TEST-HARNESS-[^;]+;\d+\s*$}i;
use constant LOG         => 'misc/vms/tp_vms-maketest';

my %cfg = ();
open my $rc, '<', TESTDRIVERC or die "Can't open ", TESTDRIVERC, " ($!)\n";
while (<$rc>) {
    chomp;
    next unless /^(\w+)\s*:\s*(.+)$/;
    $cfg{$1} = $2;
}
close $rc;

my $tarball = shift;

my @logs = test_it(
    {   telnethost => TELNETHOST,
        ftphost    => FTPHOST,
        tarball    => $tarball,
        cleanup    => CLEANUP,

        # From .testdriverc
        user => (
            $cfg{user}
              or die "No user in .testdriverc\n"
        ),
        pass => (
            $cfg{pass}
              or die "No pass in .testdriverc\n"
        ),
    }
);

my @results = ();
for ( map {@$_} @logs ) {
    push @results, $1 if /^Result:\s+(\w+)$/;
}

my $sep = '=' x 72;
print join "$sep\n", "Generated by smoke/testdrive.pl\n",
  map { join '', @$_ } @logs;
die "No results!\n" unless @results;
exit scalar grep { $_ ne 'PASS' } @results;

sub test_it {
    my ($args) = @_;

    # Need huge timeout until we can figure out how to respond to
    # VMS's terminal type probe.
    my $t = Net::Telnet->new( Timeout => 1000 );

    # $t->input_log( \*STDOUT );

    print "open $args->{telnethost}\n";
    $t->open( $args->{telnethost} );

    print "login as $args->{user}\n";
    $t->login( $args->{user}, $args->{pass} );

    print "deleting old files\n";
    delete_like( $t, $args->{cleanup} );

    print "uploading $args->{tarball}\n";
    my $dest = vmsify(
        upload(
            $args->{ftphost}, $args->{user}, $args->{pass}, $args->{tarball}
        )
    );

    print "unpacking $args->{tarball}\n";
    $t->cmd("gunzip -d $dest");

    ( my $tar = $dest ) =~ s/[.].*//;
    $t->cmd("tar xf $tar");

    ( my $dir = $tar ) =~ s/_TAR$//;
    print "cd to project dir\n";
    $t->cmd("set def [.$dir]");

    print "set parse option\n";
    $t->cmd("set process/parse=extended");

    print "execute Makefile.PL\n";
    $t->cmd("perl Makefile.PL");

    print "mms\n";
    $t->cmd("mms");

    print "mms test\n";
    my @test_result = $t->cmd("mms test");

    print "self test\n";
    my @self_result
      = $t->cmd( qq{perl "-I[.blib.lib]" "-I[.blib.arch]"}
          . qq{ "-MExtUtils::Command::MM" "-e" }
          . qq{"test_harness(0, '[.blib.lib]', '[.blib.arch]')" t/*.t t/compat/*.t}
      );

    $t->close;

    return ( \@test_result, \@self_result );
}

sub vmsify {
    my $name = shift;
    my @bits = split /[.]/, $name;
    return $name unless @bits > 2;
    my $ext = pop @bits;
    return uc( join( '.', join( '_', @bits ), $ext ) );
}

sub delete_like {
    my ( $t, $pattern ) = @_;
    for my $line ( $t->cmd("dir/brief/columns=1") ) {
        chomp $line;
        next unless $line =~ $pattern;
        print "deleting $line\n";
        delete_any( $t, $line );
    }
}

sub delete_any {
    my ( $t, $file ) = @_;
    if ( $file =~ /^(.*?)[.]dir;/i ) {
        $t->cmd(qq{perl -e "use File::Path; rmtree(['$1'],1,0);"});
    }
    else {
        $t->cmd("delete $file");
    }
}

sub upload {
    my ( $host, $user, $pass, $file ) = @_;

    my $ftp = Net::FTP->new( $host, Passive => 1 )
      or die "FTP connect to $host failed";

    $ftp->login( $user, $pass ) or die "FTP login failed";
    $ftp->binary;
    my $dest = $ftp->put($file) or die "FTP upload failed";
    $ftp->quit;
    return $dest;
}