vcs.maemo.org Git - dh-make-perl/blob - dev/i386/libtest-harness-perl/libtest-harness-perl-3.12/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 * 3;
  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 get_log {
  65     my $self = shift;
  66     my @log  = @{ $self->{_log} };
  67     $self->{_log} = [];
  68     return @log;
  69 }
  70
  71 package main;
  72
  73 {
  74     use TAP::Parser::Iterator::Process;
  75     use TAP::Formatter::Console;
  76
  77     # Patch TAP::Parser::Iterator::Process
  78     my @call_log = ();
  79
  80     local $^W;    # no warnings
  81
  82     my $orig_new = TAP::Parser::Iterator::Process->can('new');
  83
  84     # Avoid "used only once" warning
  85     *TAP::Parser::Iterator::Process::new
  86       = *TAP::Parser::Iterator::Process::new = sub {
  87         push @call_log, [ 'new', @_ ];
  88
  89         # And then new turns round and tramples on our args...
  90         $_[1] = { %{ $_[1] } };
  91         $orig_new->(@_);
  92       };
  93
  94     # Patch TAP::Formatter::Console;
  95     my $orig_output = \&TAP::Formatter::Console::_output;
  96     *TAP::Formatter::Console::_output = sub {
  97
  98         # push @call_log, [ '_output', @_ ];
  99     };
 100
 101     sub get_log {
 102         my @log = @call_log;
 103         @call_log = ();
 104         return @log;
 105     }
 106 }
 107
 108 sub _slacken {
 109     my $obj = shift;
 110     if ( my $ref = ref $obj ) {
 111         if ( 'HASH' eq ref $obj ) {
 112             return { map { $_ => _slacken( $obj->{$_} ) } keys %$obj };
 113         }
 114         elsif ( 'ARRAY' eq ref $obj ) {
 115             return [ map { _slacken($_) } @$obj ];
 116         }
 117         elsif ( 'SCALAR' eq ref $obj ) {
 118             return $obj;
 119         }
 120         else {
 121             return \$ref;
 122         }
 123     }
 124     else {
 125         return $obj;
 126     }
 127 }
 128
 129 sub is_slackly($$$) {
 130     my ( $got, $want, $msg ) = @_;
 131     return is_deeply _slacken($got), _slacken($want), $msg;
 132 }
 133
 134 # ACTUAL TEST
 135 for my $test (@SCHEDULE) {
 136     my $name = $test->{name};
 137
 138     my $app = FakeProve->new;
 139     $app->process_args( '--norc', @{ $test->{args} } );
 140
 141     # Why does this make the output from the test spew out of
 142     # our STDOUT?
 143     ok eval { $app->run }, 'run returned true';
 144     ok !$@, 'no errors';
 145
 146     my @log = get_log();
 147
 148     # Bodge: we don't know what pathname will be used for the exe so we
 149     # obliterate it here. Need to test that it's sane.
 150     for my $call (@log) {
 151         if ( 'HASH' eq ref $call->[2] && exists $call->[2]->{command} ) {
 152             $call->[2]->{command}->[0] = 'PERL';
 153         }
 154     }
 155
 156     is_slackly \@log, $test->{expect}, "$name: command args OK";
 157
 158     # use Data::Dumper;
 159     # diag Dumper(
 160     #     {   got    => \@log,
 161     #         expect => $test->{expect}
 162     #     }
 163     # );
 164 }
 165