X-Git-Url: http://git.maemo.org/git/?p=dh-make-perl;a=blobdiff_plain;f=dev%2Farm%2Flibtest-harness-perl%2Flibtest-harness-perl-3.12%2Ft%2Fproverun.t;fp=dev%2Farm%2Flibtest-harness-perl%2Flibtest-harness-perl-3.12%2Ft%2Fproverun.t;h=b40d56362dbb20484b0265fa02fd538d25769518;hp=0000000000000000000000000000000000000000;hb=f477fa73365d491991707e7ed9217b48d6994551;hpb=da95c414033799c3a62606f299c3c00b5c77ca11

diff --git a/dev/arm/libtest-harness-perl/libtest-harness-perl-3.12/t/proverun.t b/dev/arm/libtest-harness-perl/libtest-harness-perl-3.12/t/proverun.t
new file mode 100644
index 0000000..b40d563
--- /dev/null
+++ b/dev/arm/libtest-harness-perl/libtest-harness-perl-3.12/t/proverun.t
@@ -0,0 +1,165 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+    if ( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ( '../lib', 'lib' );
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
+}
+
+use strict;
+use Test::More;
+use File::Spec;
+use App::Prove;
+
+my @SCHEDULE;
+
+BEGIN {
+
+    my $sample_test = File::Spec->catfile(
+        split /\//,
+        ( $ENV{PERL_CORE} ? 'lib' : 't' ) . '/sample-tests/simple'
+    );
+
+    @SCHEDULE = (
+        {   name   => 'Create empty',
+            args   => [$sample_test],
+            expect => [
+                [   'new',
+                    'TAP::Parser::Iterator::Process',
+                    {   merge   => undef,
+                        command => [
+                            'PERL',
+                            $sample_test
+                        ],
+                        setup    => \'CODE',
+                        teardown => \'CODE',
+
+                    }
+                ]
+            ]
+        },
+    );
+
+    plan tests => @SCHEDULE * 3;
+}
+
+# Waaaaay too much boilerplate
+
+package FakeProve;
+use vars qw( @ISA );
+
+@ISA = 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 = ();
+
+    local $^W;    # no warnings
+
+    my $orig_new = TAP::Parser::Iterator::Process->can('new');
+
+    # Avoid "used only once" warning
+    *TAP::Parser::Iterator::Process::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';
+
+    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}
+    #     }
+    # );
+}
+