lib/Test/Harness/t/proverun.t

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