The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl -w

eval 'exec /usr/bin/perl -w -S $0 ${1+"$@"}'
  if 0;    # not running under some shell

use strict;
use Pod::Usage 1.12;
use TAP::Harness;
use File::Find;
use File::Spec;
use Getopt::Long;

my $DEFAULT_FORMATTER = 'TAP::Harness::Formatter::Basic';

# Allow cuddling the paths with the -I
@ARGV = map { /^(-I)(.+)/ ? ( $1, $2 ) : $_ } @ARGV;
my $color_default = -t STDOUT && !( $^O =~ /MSWin32/ );
my $COLOR;

Getopt::Long::Configure( 'no_ignore_case', 'bundling' );
GetOptions(
    'v|verbose'   => \my $VERBOSE,
    'f|failures'  => \my $FAILURES,
    'l|lib'       => \my $LIB,
    'b|blib'      => \my $BLIB,
    's|shuffle'   => \my $SHUFFLE,
    'color!'      => \$COLOR,
    'c'           => \$COLOR,
    'harness=s'   => \my $HARNESS,
    'formatter=s' => \my $FORMATTER,
    'r|recurse'   => \my $RECURSE,
    'reverse'     => \my $REVERSE,
    'p|parse'     => \my $PARSE,
    'q|quiet'     => \my $QUIET,
    'Q|QUIET'     => \my $REALLY_QUIET,
    'e|exec=s'    => \my $EXEC,
    'm|merge'     => \my $MERGE,
    'I=s@'        => \my @INCLUDES,
    'directives'  => \my $DIRECTIVES,
    'h|help|?'    => sub { pod2usage( { -verbose => 1 } ); exit },
    'H|man'       => sub { pod2usage( { -verbose => 2 } ); exit },
    'V|version'   => sub { print_version(); exit },
    'a|archive=s' => \my $ARCHIVE,

    #'x|xtension=s' => \my $EXTENSION,
    'T' => \my $TAINT_FAIL,
    't' => \my $TAINT_WARN,
    'W' => \my $WARNINGS_FAIL,
    'w' => \my $WARNINGS_WARN,
);

if ( !defined $COLOR ) {
    $COLOR = $color_default;
}

# XXX otherwise, diagnostics and failure messages are out of sequence
# or we can't suppress STDERR on quiet
#$MERGE = 1 if $FAILURES || $QUIET || $REALLY_QUIET;

my $harness_class = 'TAP::Harness';
my %args;

if ($COLOR) {
    require TAP::Harness::Color;
    $harness_class = 'TAP::Harness::Color';
}

if ($ARCHIVE) {
    eval { require TAP::Harness::Archive };
    die "TAP::Harness::Archive is required to use the --archive feature: $@" if $@;
    $harness_class = 'TAP::Harness::Archive';
    $args{archive} = $ARCHIVE;
}

if ($HARNESS) {
    eval "use $HARNESS";
    die "Cannot use harness ($HARNESS): $@" if $@;
    $harness_class = $HARNESS;
}

my $formatter_class;
if ($FORMATTER) {
    eval "use $FORMATTER";
    die "Cannot use formatter ($FORMATTER): $@" if $@;
    $formatter_class = $FORMATTER;
}

unless ($formatter_class) {
    eval "use $DEFAULT_FORMATTER";
    $formatter_class = $DEFAULT_FORMATTER unless $@;
}

my @tests = get_tests(@ARGV);

shuffle(@tests) if $SHUFFLE;
@tests = reverse @tests if $REVERSE;

if ( $TAINT_FAIL && $TAINT_WARN ) {
    die "-t and -T are mutually exclusive";
}
if ( $WARNINGS_FAIL && $WARNINGS_WARN ) {
    die "-w and -W are mutually exclusive";
}

$args{lib}          = get_libs();
$args{switches}     = get_switches();
$args{merge}        = $MERGE if $MERGE;
$args{verbose}      = $VERBOSE if $VERBOSE;
$args{failures}     = $FAILURES if $FAILURES;
$args{quiet}        = 1 if $QUIET;
$args{really_quiet} = 1 if $REALLY_QUIET;
$args{errors}       = 1 if $PARSE;
$args{exec}         = length($EXEC) ? [ split( / /, $EXEC ) ] : []
  if ( defined($EXEC) );
$args{directives} = 1 if $DIRECTIVES;

if ($formatter_class) {
    $args{formatter} = $formatter_class->new;
}

my $harness    = $harness_class->new( \%args );
my $aggregator = $harness->runtests(@tests);

exit $aggregator->has_problems ? 1 : 0;

sub get_switches {
    my @switches;

    # notes that -T or -t must be at the front of the switches!
    if ($TAINT_FAIL) {
        push @switches, 'T';
    }
    elsif ($TAINT_WARN) {
        push @switches, 't';
    }
    if ($WARNINGS_FAIL) {
        push @switches, 'W';
    }
    elsif ($WARNINGS_WARN) {
        push @switches, 'w';
    }

    return @switches ? \@switches : ();
}

sub get_libs {
    my @libs;
    if ($LIB) {
        push @libs, 'lib';
    }
    if ($BLIB) {
        push @libs, 'blib/lib';
    }
    if (@INCLUDES) {
        push @libs, @INCLUDES;
    }
    return @libs ? \@libs : ();
}

sub get_tests {
    my @argv = @_;
    my ( @tests, %tests );
    @argv = 't' unless @argv;
    foreach my $arg (@argv) {
        if ( '-' eq $arg ) {
            push @argv => <STDIN>;
            chomp(@argv);
            next;
        }

        if ( -d $arg ) {
            my @files = _get_tests($arg);
            foreach my $file (@files) {
                push @tests => $file unless exists $tests{$file};
            }
            @tests{@files} = (1) x @files;
        }
        else {
            push @tests => $arg unless exists $tests{$arg};
            $tests{$arg} = 1;
        }
    }
    return @tests;
}

sub _get_tests {
    my $dir = shift;
    my @tests;
    if ($RECURSE) {
        find(
            sub { -f && /\.t$/ && push @tests => $File::Find::name },
            $dir
        );
    }
    else {
        @tests = glob( File::Spec->catfile( $dir, '*.t' ) );
    }
    return @tests;
}

sub shuffle {
    my $self = shift;

    # Fisher-Yates shuffle
    my $i = @_;
    while ($i) {
        my $j = rand $i--;
        @_[ $i, $j ] = @_[ $j, $i ];
    }
}

sub print_version {
    printf( "TAP::Harness v%s and Perl v%vd\n", $TAP::Harness::VERSION, $^V );
}
__END__

=head1 NAME

runtests - Run tests through a TAP harness.

=head1 USAGE

 runtests [options] [files or directories]

=head1 OPTIONS

Boolean options

 -v,  --verbose     Print all test lines.
 -l,  --lib         Add 'lib' to the path for your tests (-Ilib).
 -b,  --blib        Add 'blib/lib' to the path for your tests (-Iblib/lib).
 -s,  --shuffle     Run the tests in random order.
 -c,  --color       Colored test output (default).  See TAP::Harness::Color.
      --nocolor     Do not color test output.
 -f,  --failures    Only show failed tests.
 -m,  --merge       Merge test scripts' STDERR with their STDOUT.
 -r,  --recurse     Recursively descend into directories.
      --reverse     Run the tests in reverse order.
 -q,  --quiet       Suppress some test output while running tests.
 -Q,  --QUIET       Only print summary results.
 -p,  --parse       Show full list of TAP parse errors, if any.
      --directives  Only show results with TODO or SKIP directives.
 -T                 Enable tainting checks.
 -t                 Enable tainting warnings.
 -W                 Enable fatal warnings.
 -w                 Enable warnings.
 -h,  --help        Display this help
 -?,                Display this help
 -H,  --man         Longer manpage for prove

Options which take arguments

 -I                 Library paths to include.
 -e,  --exec        Interpreter to run the tests ('' for compiled tests.)
      --harness     Define test harness to use.  See TAP::Harness.
      --formatter   Result formatter to use. See TAP::Harness.

=head2 Reading from C<STDIN>

If you have a list of tests (or URLs, or anything else you want to test) in a
file, you can add them to your tests by using a '-':

 runtests - < my_list_of_things_to_test.txt

See the C<README> in the C<examples> directory of this distribution.

=head1 NOTES

=head2 Default Test Directory

If no files or directories are supplied, C<runtests> looks for all files
matching the pattern C<t/*.t>.

=head2 Colored Test Output

Specifying the C<--color> or C<-c> switch is the same as:

 runtests --harness TAP::Harness::Color

Colored test output is the default, but if output is not to a terminal, color
is disabled.  You can override this by adding the C<--color> switch.

=head2 C<--exec>

Normally you can just pass a list of Perl tests and the harness will know how
to execute them.  However, if your tests are not written in Perl or if you
want all tests invoked exactly the same way, use the C<-e>, or C<--exec>
switch:

 runtests --exec '/usr/bin/ruby -w' t/
 runtests --exec '/usr/bin/perl -Tw -mstrict -Ilib' t/
 runtests --exec '/path/to/my/customer/exec'

=head2 C<--merge>

If you need to make sure your diagnostics are displayed in the correct
order relative to test results you can use the C<--merge> option to
merge the test scripts' STDERR into their STDOUT. 

This guarantees that STDOUT (where the test results appear) and STDOUT
(where the diagnostics appear) will stay in sync. The harness will
display any diagnostics your tests emit on STDERR.

Caveat: this is a bit of a kludge. In particular note that if anything
that appears on STDERR looks like a test result the test harness will
get confused. Use this option only if you understand the consequences
and can live with the risk.

=head1 PERFORMANCE

Because of its design, C<TAP::Parser> collects more information than
C<Test::Harness>.  However, the trade-off is sometimes slightly slower
performance than when using the C<prove> utility which is bundled with
L<Test::Harness>.  For small tests suites, this is usually not a problem.
However, enabling the C<--quiet> or C<--QUIET> options can sometimes speed up
the test suite, sometimes running faster than C<prove>.

=head1 SEE ALSO

C<prove>, which comes with L<Test::Harness> and whose code I've nicked in a
few places (thanks Andy!).

=head1 CAVEATS

This is alpha code.  You've been warned.

=cut