Harness.pm 2.53 KB
Newer Older
Mike Hibler's avatar
Mike Hibler committed
1 2 3 4 5
#
# EMULAB-COPYRIGHT
# Copyright (c) 2009 University of Utah and the Flux Group.
# All rights reserved.
#
Kevin Tew's avatar
Kevin Tew committed
6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27
package TAP::Parser::Iterator::StdOutErr;
use strict;
use warnings;
use vars qw($VERSION @ISA);

use TAP::Parser::Iterator::Process ();
use IO::Select;

@ISA = 'TAP::Parser::Iterator::Process';

sub _initialize {
    my $self = shift;
    $self->{out}        = shift || die "Need out";
    $self->{err}        = shift || die "Need err";
    $self->{sel}        = IO::Select->new( $self->{out}, $self->{err} );
    $self->{pid}        = shift || die "Need pid";
    $self->{exit}       = undef;
    $self->{chunk_size} = 65536;
    return $self;
}

package TestBed::Harness;
28 29 30 31 32 33
use SemiModern::Perl;
use TAP::Harness;
require Exporter;
our @ISA = qw(Exporter TAP::Harness);
our @EXPORT = qw(runharness);
use TestBed::TestSuite;
Kevin Tew's avatar
Kevin Tew committed
34 35 36 37 38
use TestBed::ForkFramework;
use TestBed::ParallelRunner;

sub build_TAP_stream {
  use TestBed::TestSuite;
Kevin Tew's avatar
fixes  
Kevin Tew committed
39
  my ($in, $out, $err, $pid) = TestBed::ForkFramework::fork_child_redir(sub { $TestBed::ParallelRunner::GlobalRunner->runtests; });
Kevin Tew's avatar
Kevin Tew committed
40 41
  return TAP::Parser::Iterator::StdOutErr->new($out, $err, $pid);
}
42 43 44 45 46 47 48

sub parser_args_callback {
  my $args = shift;
  my $ref = $args->{source};
  
  if (ref $ref and $ref->isa('TestBed::ParallelRunner')) {
    delete $args->{source};
Kevin Tew's avatar
Kevin Tew committed
49
    $args->{'stream'} = build_TAP_stream;
50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65
  }
  $args;
}

sub split_t_pm {
  my @t;
  my @pm;
  map {
    if (/\.pm$/) { push @pm, glob($_); }
    elsif (/\.t$/) { push @t, glob($_); }
  } @_;
  (\@t, \@pm);
}

sub runharness {
  my @parts = my ($ts, $pms) = split_t_pm(@_);
66 67 68 69
  for (@$pms) { 
    eval "require \'$_\';"; 
    die $@ if $@;
  }
70 71 72 73 74 75 76 77

  my %harness_args = (
      verbosity => 1,
      lib     => [ '.', 'lib', 'blib/lib' ],
      );

  my $harness = TAP::Harness->new( \%harness_args );
  $harness->callback('parser_args', \&parser_args_callback);
78
  push @$ts, [TestBed::ParallelRunner->new(), 'Parallel Tests'] if @$pms;
79 80 81
  $harness->runtests(@$ts);
}

Kevin Tew's avatar
Kevin Tew committed
82

83 84 85 86 87 88
=head1 NAME

TestBed::Harness

=over 4

Kevin Tew's avatar
Kevin Tew committed
89 90 91 92
=item C<< build_TAP_stream >>

given a TestBed::ParallelRunner returns a TAP stream

93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111
=item C<< runharness(@test_file_names) >>

ex. runharness( 't/lib/*.t', 't/xmlrpc/*.t' 'test/BasicTopologies.pm' ) 

runs the specified test in a TAP::harness
pushes a ParallelRunner on if .pm parallel test modules are specified

=item C<< split_t_pm(@test_file_names) >>

splits test filenames into to lists based on .t and .pm extensions

=item C<< parser_args_callback >>

TAP::Harness parser_args callback that allow for special processing (pre_running) of parallel tests

=back

=cut

112
1;