view release on metacpan or  search on metacpan

bin/tprove  view on Meta::CPAN

#! /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(), @_;
}

bin/tprove  view on Meta::CPAN

    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__

=pod

=encoding utf-8

=head1 NAME

tprove - Tapper - alternative 'prove' which uploads results to a Tapper server

=head1 SYNOPSIS

 $ prove  -vl t/        # normal prove until satisfied
 $ tprove -vl t/        # nearly the same, just a little "t" in front

=head1 ABOUT

This is a drop-in replacement for C<prove> to run TAP-based test suites.

It executes the normal C<prove> but injects additional parameters to
generate C<prove>'s results into a so called I<TAP-Archive>, then
injects some meta information into this archive, and finally uploads
the generated archive to your personal B<Tapper> instance, based on
the environment variable C<TAPPER_REPORT_SERVER> (and optionally
C<TAPPER_REPORT_PORT>).

Learn more about Tapper on L<tapper-testing.org|http://tapper-testing.org>.

=head1 AUTHOR

Steffen Schwigon <ss5@renormalist.net>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2013 by Steffen Schwigon.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut