cpan/Test-Harness/t/proverun.t

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