Gecko [ www.blackthorn-inc.com ]

Name	Size	Permission	Date
compat	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
data	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
lib	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
proverc	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
sample-tests	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
source_tests	[ DIR ]	drwxr-xr-x	2016-10-10 18:24
subclass_tests	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
aggregator.t	9.35 KB	-r--r--r--	2014-12-27 11:48
bailout.t	3.12 KB	-r--r--r--	2014-12-27 11:48
base.t	4.68 KB	-r--r--r--	2014-12-27 11:48
callbacks.t	2.57 KB	-r--r--r--	2014-12-27 11:48
console.t	1.06 KB	-r--r--r--	2014-12-27 11:48
errors.t	4.64 KB	-r--r--r--	2014-12-27 11:48
file.t	13.61 KB	-r--r--r--	2014-12-27 11:48
glob-to-regexp.t	988 B	-r--r--r--	2014-12-27 11:48
grammar.t	11.55 KB	-r--r--r--	2014-12-27 11:48
harness-bailout.t	1.19 KB	-r--r--r--	2014-12-27 11:48
harness-subclass.t	1.58 KB	-r--r--r--	2014-12-27 11:48
harness.t	28.38 KB	-r--r--r--	2014-12-27 11:48
iterator_factory.t	4.8 KB	-r--r--r--	2014-12-27 11:48
iterators.t	5.68 KB	-r--r--r--	2014-12-27 11:48
multiplexer.t	4.53 KB	-r--r--r--	2014-12-27 11:48
nested.t	860 B	-r--r--r--	2014-12-27 11:48
nofork-mux.t	119 B	-r--r--r--	2014-12-27 11:48
nofork.t	1.55 KB	-r--r--r--	2014-12-27 11:48
object.t	772 B	-r--r--r--	2014-12-27 11:48
parse.t	30.97 KB	-r--r--r--	2014-12-27 11:48
parser-config.t	731 B	-r--r--r--	2014-12-27 11:48
parser-subclass.t	2.2 KB	-r--r--r--	2014-12-27 11:48
perl5lib.t	1.13 KB	-r--r--r--	2014-12-27 11:48
premature-bailout.t	2.32 KB	-r--r--r--	2014-12-27 11:48
process.t	1015 B	-r--r--r--	2014-12-27 11:48
prove.t	47.6 KB	-r--r--r--	2014-12-27 11:49
proveenv.t	338 B	-r--r--r--	2014-12-27 11:49
proverc.t	472 B	-r--r--r--	2014-12-27 11:48
proverun.t	4.14 KB	-r--r--r--	2014-12-27 11:48
proveversion.t	763 B	-r--r--r--	2014-12-27 11:48
regression.t	111.62 KB	-r--r--r--	2014-12-27 11:48
results.t	7.68 KB	-r--r--r--	2014-12-27 11:48
scheduler.t	5.33 KB	-r--r--r--	2014-12-27 11:48
source.t	8.21 KB	-r--r--r--	2014-12-27 11:48
source_handler.t	12.32 KB	-r--r--r--	2014-12-27 11:48
spool.t	3.12 KB	-r--r--r--	2014-12-27 11:48
state.t	7.7 KB	-r--r--r--	2014-12-27 11:48
state_results.t	4.95 KB	-r--r--r--	2014-12-27 11:48
streams.t	6.33 KB	-r--r--r--	2014-12-27 11:48
taint.t	1.3 KB	-r--r--r--	2014-12-27 11:49
testargs.t	4.95 KB	-r--r--r--	2014-12-27 11:48
unicode.t	3.73 KB	-r--r--r--	2014-12-27 11:48
yamlish-output.t	2.44 KB	-r--r--r--	2014-12-27 11:48
yamlish-writer.t	7.17 KB	-r--r--r--	2014-12-27 11:48
yamlish.t	15.01 KB	-r--r--r--	2014-12-27 11:48

Rename

#!/usr/bin/perl -w

BEGIN {
    unshift @INC, 't/lib';
}

use strict;
use warnings;
use Test::More;
use File::Spec;
use App::Prove;
use Text::ParseWords qw(shellwords);

my @SCHEDULE;

BEGIN {
    my $t_dir = File::Spec->catdir('t');

# to add a new test to proverun, just list the name of the file in
    # t/sample-tests and a name for the test.  The rest is handled
    # automatically.
    my @tests = (
        {   file => 'simple',
            name => 'Create empty',
        },
        {   file => 'todo_inline',
            name => 'Passing TODO',
        },
    );

# TODO: refactor this and add in a test for:
    # prove --source 'File: {extensions: [.1]}' t/source_tests/source.1

for my $test (@tests) {

# let's fully expand that filename
        $test->{file}
          = File::Spec->catfile( $t_dir, 'sample-tests', $test->{file} );
    }
    @SCHEDULE = (
        map {
            {   name   => $_->{name},
                args   => [ $_->{file} ],
                expect => [
                    [   'new',
                        'TAP::Parser::Iterator::Process',
                        {   merge   => undef,
                            command => [
                                'PERL',
                                $ENV{HARNESS_PERL_SWITCHES}
                                ? shellwords( $ENV{HARNESS_PERL_SWITCHES} )
                                : (),
                                $_->{file},
                            ],
                            setup    => \'CODE',
                            teardown => \'CODE',

}
                    ]
                ]
            }
          } @tests,
    );

plan tests => @SCHEDULE * 3;
}

# Waaaaay too much boilerplate

package FakeProve;

use base qw( App::Prove );

sub new {
    my $class = shift;
    my $self  = $class->SUPER::new(@_);
    $self->{_log} = [];
    return $self;
}

sub get_log {
    my $self = shift;
    my @log  = @{ $self->{_log} };
    $self->{_log} = [];
    return @log;
}

package main;

{
    use TAP::Parser::Iterator::Process;
    use TAP::Formatter::Console;

# Patch TAP::Parser::Iterator::Process
    my @call_log = ();

no warnings qw(redefine once);

my $orig_new = TAP::Parser::Iterator::Process->can('new');

*TAP::Parser::Iterator::Process::new = sub {
        push @call_log, [ 'new', @_ ];

# And then new turns round and tramples on our args...
        $_[1] = { %{ $_[1] } };
        $orig_new->(@_);
      };

# Patch TAP::Formatter::Console;
    my $orig_output = \&TAP::Formatter::Console::_output;
    *TAP::Formatter::Console::_output = sub {

# push @call_log, [ '_output', @_ ];
    };

sub get_log {
        my @log = @call_log;
        @call_log = ();
        return @log;
    }
}

sub _slacken {
    my $obj = shift;
    if ( my $ref = ref $obj ) {
        if ( 'HASH' eq ref $obj ) {
            return { map { $_ => _slacken( $obj->{$_} ) } keys %$obj };
        }
        elsif ( 'ARRAY' eq ref $obj ) {
            return [ map { _slacken($_) } @$obj ];
        }
        elsif ( 'SCALAR' eq ref $obj ) {
            return $obj;
        }
        else {
            return \$ref;
        }
    }
    else {
        return $obj;
    }
}

sub is_slackly($$$) {
    my ( $got, $want, $msg ) = @_;
    return is_deeply _slacken($got), _slacken($want), $msg;
}

# ACTUAL TEST
for my $test (@SCHEDULE) {
    my $name = $test->{name};

my $app = FakeProve->new;
    $app->process_args( '--norc', @{ $test->{args} } );

# Why does this make the output from the test spew out of
    # our STDOUT?
    ok eval { $app->run }, 'run returned true';
    ok !$@, 'no errors' or diag $@;

my @log = get_log();

# Bodge: we don't know what pathname will be used for the exe so we
    # obliterate it here. Need to test that it's sane.
    for my $call (@log) {
        if ( 'HASH' eq ref $call->[2] && exists $call->[2]->{command} ) {
            $call->[2]->{command}->[0] = 'PERL';
        }
    }

is_slackly \@log, $test->{expect}, "$name: command args OK";

# use Data::Dumper;
    # diag Dumper(
    #     {   got    => \@log,
    #         expect => $test->{expect}
    #     }
    # );
}