lib/Test/Harness/t/proverun.t

   1 #!/usr/bin/perl -w
   2
   3 BEGIN {
   4     if ($ENV{PERL_CORE}) {
   5         # FIXME
   6         print "1..0 # Skip, needs fixing. Probably an -I issue\n";
   7         exit 0;
   8     }
   9 }
  10
  11 use strict;
  12
  13 use lib 't/lib';
  14
  15 use Test::More;
  16 use File::Spec;
  17 use App::Prove;
  18
  19 my @SCHEDULE;
  20
  21 BEGIN {
  22
  23     my $sample_test
  24       = File::Spec->catfile( split /\//, 't/sample-tests/simple' );
  25
  26     @SCHEDULE = (
  27         {   name   => 'Create empty',
  28             args   => [$sample_test],
  29             expect => [
  30                 [   'new',
  31                     'TAP::Parser::Iterator::Process',
  32                     {   merge   => undef,
  33                         command => [
  34                             'PERL',
  35                             $sample_test
  36                         ],
  37                         setup    => \'CODE',
  38                         teardown => \'CODE',
  39
  40                     }
  41                 ]
  42             ]
  43         },
  44     );
  45
  46     plan tests => @SCHEDULE * 2;
  47 }
  48
  49 # Waaaaay too much boilerplate
  50
  51 package FakeProve;
  52 use vars qw( @ISA );
  53
  54 @ISA = qw( App::Prove );
  55
  56 sub new {
  57     my $class = shift;
  58     my $self  = $class->SUPER::new(@_);
  59     $self->{_log} = [];
  60     return $self;
  61 }
  62
  63 sub _exit {
  64     my $self = shift;
  65     push @{ $self->{_log} }, [ '_exit', @_ ];
  66     die "Exited";
  67 }
  68
  69 sub get_log {
  70     my $self = shift;
  71     my @log  = @{ $self->{_log} };
  72     $self->{_log} = [];
  73     return @log;
  74 }
  75
  76 package main;
  77
  78 {
  79     use TAP::Parser::Iterator::Process;
  80     use TAP::Formatter::Console;
  81
  82     # Patch TAP::Parser::Iterator::Process
  83     my @call_log = ();
  84
  85     local $^W;    # no warnings
  86
  87     my $orig_new = \&TAP::Parser::Iterator::Process::new;
  88     *TAP::Parser::Iterator::Process::new = sub {
  89         push @call_log, [ 'new', @_ ];
  90
  91         # And then new turns round and tramples on our args...
  92         $_[1] = { %{ $_[1] } };
  93         $orig_new->(@_);
  94     };
  95
  96     # Patch TAP::Formatter::Console;
  97     my $orig_output = \&TAP::Formatter::Console::_output;
  98     *TAP::Formatter::Console::_output = sub {
  99
 100         # push @call_log, [ '_output', @_ ];
 101     };
 102
 103     sub get_log {
 104         my @log = @call_log;
 105         @call_log = ();
 106         return @log;
 107     }
 108 }
 109
 110 sub _slacken {
 111     my $obj = shift;
 112     if ( my $ref = ref $obj ) {
 113         if ( 'HASH' eq ref $obj ) {
 114             return { map { $_ => _slacken( $obj->{$_} ) } keys %$obj };
 115         }
 116         elsif ( 'ARRAY' eq ref $obj ) {
 117             return [ map { _slacken($_) } @$obj ];
 118         }
 119         elsif ( 'SCALAR' eq ref $obj ) {
 120             return $obj;
 121         }
 122         else {
 123             return \$ref;
 124         }
 125     }
 126     else {
 127         return $obj;
 128     }
 129 }
 130
 131 sub is_slackly($$$) {
 132     my ( $got, $want, $msg ) = @_;
 133     return is_deeply _slacken($got), _slacken($want), $msg;
 134 }
 135
 136 # ACTUAL TEST
 137 for my $test (@SCHEDULE) {
 138     my $name = $test->{name};
 139
 140     my $app = FakeProve->new;
 141     $app->process_args( '--norc', @{ $test->{args} } );
 142
 143     # Why does this make the output from the test spew out of
 144     # our STDOUT?
 145     eval { $app->run };
 146     like $@, qr{Exited}, "$name: exited via _exit()";
 147
 148     my @log = get_log();
 149
 150     # Bodge: we don't know what pathname will be used for the exe so we
 151     # obliterate it here. Need to test that it's sane.
 152     for my $call (@log) {
 153         if ( 'HASH' eq ref $call->[2] && exists $call->[2]->{command} ) {
 154             $call->[2]->{command}->[0] = 'PERL';
 155         }
 156     }
 157
 158     is_slackly \@log, $test->{expect}, "$name: command args OK";
 159
 160     # use Data::Dumper;
 161     # diag Dumper(
 162     #     {   got    => \@log,
 163     #         expect => $test->{expect}
 164     #     }
 165     # );
 166 }
 167