ext/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     # to add a new test to proverun, just list the name of the file in
  23     # t/sample-tests and a name for the test.  The rest is handled
  24     # automatically.
  25     my @tests = (
  26         {   file => 'simple',
  27             name => 'Create empty',
  28         },
  29         {   file => 'todo_inline',
  30             name => 'Passing TODO',
  31         },
  32     );
  33     foreach my $test (@tests) {
  34
  35         # let's fully expand that filename
  36         $test->{file} = File::Spec->catfile(
  37             (   $ENV{PERL_CORE}
  38                 ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' )
  39                 : ()
  40             ),
  41             't',
  42             'sample-tests',
  43             $test->{file}
  44         );
  45     }
  46     @SCHEDULE = (
  47         map {
  48             {   name   => $_->{name},
  49                 args   => [ $_->{file} ],
  50                 expect => [
  51                     [   'new',
  52                         'TAP::Parser::Iterator::Process',
  53                         {   merge   => undef,
  54                             command => [
  55                                 'PERL',
  56                                 $_->{file},
  57                             ],
  58                             setup    => \'CODE',
  59                             teardown => \'CODE',
  60
  61                         }
  62                     ]
  63                 ]
  64             }
  65           } @tests
  66     );
  67
  68     plan tests => @SCHEDULE * 3;
  69 }
  70
  71 # Waaaaay too much boilerplate
  72
  73 package FakeProve;
  74 use vars qw( @ISA );
  75
  76 @ISA = qw( App::Prove );
  77
  78 sub new {
  79     my $class = shift;
  80     my $self  = $class->SUPER::new(@_);
  81     $self->{_log} = [];
  82     return $self;
  83 }
  84
  85 sub get_log {
  86     my $self = shift;
  87     my @log  = @{ $self->{_log} };
  88     $self->{_log} = [];
  89     return @log;
  90 }
  91
  92 package main;
  93
  94 {
  95     use TAP::Parser::Iterator::Process;
  96     use TAP::Formatter::Console;
  97
  98     # Patch TAP::Parser::Iterator::Process
  99     my @call_log = ();
 100
 101     local $^W;    # no warnings
 102
 103     my $orig_new = TAP::Parser::Iterator::Process->can('new');
 104
 105     # Avoid "used only once" warning
 106     *TAP::Parser::Iterator::Process::new
 107       = *TAP::Parser::Iterator::Process::new = sub {
 108         push @call_log, [ 'new', @_ ];
 109
 110         # And then new turns round and tramples on our args...
 111         $_[1] = { %{ $_[1] } };
 112         $orig_new->(@_);
 113       };
 114
 115     # Patch TAP::Formatter::Console;
 116     my $orig_output = \&TAP::Formatter::Console::_output;
 117     *TAP::Formatter::Console::_output = sub {
 118
 119         # push @call_log, [ '_output', @_ ];
 120     };
 121
 122     sub get_log {
 123         my @log = @call_log;
 124         @call_log = ();
 125         return @log;
 126     }
 127 }
 128
 129 sub _slacken {
 130     my $obj = shift;
 131     if ( my $ref = ref $obj ) {
 132         if ( 'HASH' eq ref $obj ) {
 133             return { map { $_ => _slacken( $obj->{$_} ) } keys %$obj };
 134         }
 135         elsif ( 'ARRAY' eq ref $obj ) {
 136             return [ map { _slacken($_) } @$obj ];
 137         }
 138         elsif ( 'SCALAR' eq ref $obj ) {
 139             return $obj;
 140         }
 141         else {
 142             return \$ref;
 143         }
 144     }
 145     else {
 146         return $obj;
 147     }
 148 }
 149
 150 sub is_slackly($$$) {
 151     my ( $got, $want, $msg ) = @_;
 152     return is_deeply _slacken($got), _slacken($want), $msg;
 153 }
 154
 155 # ACTUAL TEST
 156 for my $test (@SCHEDULE) {
 157     my $name = $test->{name};
 158
 159     my $app = FakeProve->new;
 160     $app->process_args( '--norc', @{ $test->{args} } );
 161
 162     # Why does this make the output from the test spew out of
 163     # our STDOUT?
 164     ok eval { $app->run }, 'run returned true';
 165     ok !$@, 'no errors' or diag $@;
 166
 167     my @log = get_log();
 168
 169     # Bodge: we don't know what pathname will be used for the exe so we
 170     # obliterate it here. Need to test that it's sane.
 171     for my $call (@log) {
 172         if ( 'HASH' eq ref $call->[2] && exists $call->[2]->{command} ) {
 173             $call->[2]->{command}->[0] = 'PERL';
 174         }
 175     }
 176
 177     is_slackly \@log, $test->{expect}, "$name: command args OK";
 178
 179     # use Data::Dumper;
 180     # diag Dumper(
 181     #     {   got    => \@log,
 182     #         expect => $test->{expect}
 183     #     }
 184     # );
 185 }
 186