File Coverage

bin/tprove

Criterion	Covered	Total	%
statement	54	154	35.0
branch	1	32	3.1
condition	1	22	4.5
subroutine	17	29	58.6
pod			n/a
total	73	237	30.8

#! /usr/bin/perl
# PODNAME: tprove
# ABSTRACT: Tapper - alternative 'prove' which uploads results to a Tapper server

# -----------------------------------------------------------
# Keep this a single file with no external libs and only core
# dependencies, so we can use that script in any restricted
# environment. Similar spirit as bash-test-utils.
# -----------------------------------------------------------

use strict;
use warnings;

use Archive::Tar;
use IO::Socket::INET;
use Sys::Hostname "hostname";
use File::Temp "tempfile", "tempdir";
use File::Basename "basename", "dirname";
use File::Copy;
use File::Find;
use YAML::XS "LoadFile", "DumpFile";
use Cwd;

use Data::Dumper;

my $tap_archive_support;
my $tmp_archive;
my $tmp_dir;

sub slurp {
    my ($file) = @_;

    my $FILE;
    open $FILE, "<", $file and do {
        local $/;
        return <$FILE>;
    };
}

sub get_tmp_dir {
    $tmp_dir ||= tempdir(CLEANUP => 1);
    return $tmp_dir;
}

sub get_prove {
    my $prove = $^X;
    $prove = dirname($^X)."/prove";
    return $prove;
}

sub patch_args {
    my @args = @_;

    # skip potential archive options
    @args = grep { ! ( /^-a$/ ... // ) } @args;
    unshift @args, "-a", get_tmp_dir();
    return @args
}

sub run_prove {
    system get_prove(), @_;
}

# a Tapper::Archive is a .tgz containing: tests.(tap|tgz) and optional files.tgz
sub pack_tapper_archive {
    my $name = "tapper-archive.tgz";
    my $full_name = get_tmp_dir."/$name";
    system ("tar", "-C", get_tmp_dir, "-czf", $full_name, "tests.tgz");
    return $full_name;
}

sub report_tapper_archive {
    my ($archive) = @_;

    my $report_server   = $ENV{TAPPER_REPORT_SERVER};
    my $report_api_port = $ENV{TAPPER_REPORT_API_PORT} || '7358';
    my $report_port     = $ENV{TAPPER_REPORT_PORT}     || '7357';

    if (not $report_server) {
        print "Generated TAP-Archive: $archive";
        return;
    }

    my $gzipped_content = slurp($archive);

    my $sock = IO::Socket::INET->new(PeerAddr => $report_server,
                                     PeerPort => $report_port,
                                     Proto    => 'tcp');
    print STDERR "Report to Tapper at ".($report_server || "report_server=UNDEF").":".($report_port || "report_port=UNDEF");
    unless ($sock) {
        print STDERR "\nResult TAP in $archive can not be sent to Tapper server.\n";
        die "\nCan't open connection to ", ($report_server || "report_server=UNDEF"), ":", ($report_port || "report_port=UNDEF"), ":$!"
    }

    my $report_id = <$sock>;
    ($report_id) = $report_id =~ /(\d+)$/;
    $sock->print($gzipped_content);
    $sock->close();
    print STDERR ", id=$report_id, url=http://$report_server".($report_server =~ /^(localhost|0)$/ ? ":3000" : "")."/tapper/reports/id/$report_id\n";
    return $report_id;
}

# Return hostname for metainfo in typical Tapper notation, i.e., just
# the hostname (without FQDN) in host context or C (colon
# separated) in guest context.
sub get_machine_name
{
        my $etc_tapper = "/etc/tapper";

        my $hostname = hostname();
        $hostname =~ s/\..*$//; # no FQDN
        # combined machine name in Tapper automation guest environment
        if ($ENV{TAPPER_HOSTNAME}) {
                $hostname = "$ENV{TAPPER_HOSTNAME}:$hostname"
        } elsif ( -r $etc_tapper ) {
                my @tapper_config = ();
                my $TAPPERCFG;
                open $TAPPERCFG, "<", $etc_tapper and do {
                        local $/;
                        @tapper_config = <$TAPPERCFG>;
                        close $TAPPERCFG;
                };
                my ($machinename) =
                 map {
                      my $m = $_ ; $m =~ s/^[^:]*:// ; $m
                     }
                  grep {
                          /hostname:/
                  } @tapper_config;
                $hostname = "${machinename}:$hostname";
        }
        return $hostname;
}

sub relative_file_list {
    my ($dir) = @_;

    my @files;

    my $olddir = cwd;
    chdir $dir;
    find({ wanted => sub { $_ =~ s/^\.\///; push @files, $_ if -f $_ and $_ !~ /\b(tests\.tgz|tapper-archive.tgz)$/ }, no_chdir => 1 }, ".");
    chdir $olddir;

    return sort @files;
}

sub report_meta {
    my $hostname        = get_machine_name;
    my $testrun_id      = $ENV{TAPPER_TESTRUN}         || '',
    my $report_group    = $ENV{TAPPER_REPORT_GROUP}    || '',

    my $suite_name = basename(cwd);
    $suite_name = "unknown" if $suite_name eq "/";
    my $suite_version = "";
    ($suite_name, $suite_version) = $suite_name =~ m/^(\D*)-([\d.]+)/ if $suite_name =~ /-\d/;

    my $report_meta = "Version 13\n1..1\n# Tapper-Suite-Name: $suite_name\n";
    $report_meta   .= "# Tapper-Machine-Name: $hostname\n";
    $report_meta   .= $suite_version ? "# Tapper-Suite-Version: $suite_version\n"        : "";
    $report_meta   .= $testrun_id    ? "# Tapper-Reportgroup-Testrun: $testrun_id\n"     : "";
    $report_meta   .= $report_group  ? "# Tapper-Reportgroup-Arbitrary: $report_group\n" : "";
    $report_meta   .= "ok 1 - Tapper metainfo\n";
    return $report_meta;
}

sub patch_archive_meta_file {
    my ($meta_file) = @_;

    my $succ = 1;
    my $meta = {};
    eval { $meta = LoadFile($meta_file) };
    $succ = 0 if $@;
    push @{$meta->{file_order}}, 'tapper-meta';
    DumpFile($meta_file, $meta);

    return $succ;
}

sub create_archive_file {
    my ($dir, $report_meta, $files) = @_;

    my $archive = "$dir/tests.tgz";

    my $olddir = cwd;
    chdir $dir;

    my $tar = Archive::Tar->new;
    $tar->add_data('tapper-meta', $report_meta);
    $tar->add_files(@$files);
    $tar->write($archive, COMPRESS_GZIP);

    chdir $olddir;

    return $archive;
}

sub patch_archive
{
    my $report;

    my $report_meta = report_meta;
    my @files = relative_file_list(get_tmp_dir);

    unless (patch_archive_meta_file (get_tmp_dir."/meta.yml")) {
        $report_meta .= "# Error loading meta.yml from archive: $@\n";
        $report_meta .= "# Files in archive:\n";
        $report_meta .= $_ foreach map { "#   $_\n" } @files;
    }

    return create_archive_file(get_tmp_dir, $report_meta, \@files);
}

sub check_tap_archive_support {
    eval { require TAP::Harness::Archive };
    die "No TAP-Archive support. Install TAP::Harness::Archive.\n"
        if $@;
}

sub main {
    check_tap_archive_support;
    run_prove (patch_args(@ARGV));
    my $tap_archive = patch_archive;
    my $tapper_archive = pack_tapper_archive($tap_archive);
    report_tapper_archive($tap_archive);
    # TODO: send $tapper_archive, not $tap_archive (needs receiver support)
}

# are we a lib or a program, e.g., require'd during testing?
{
    no warnings 'uninitialized';
    ((caller 0)[3] eq "(eval)") ? 1 : main;
}

__END__