# Copyright (C) 2008, The Perl Foundation.
# $Id: /mirror/trunk/lib/Parrot/Test/Util/Runloop.pm 34254 2008-12-22T03:24:34.847717Z petdance  $

=head1 NAME

Parrot::Test::Util::Runloop - consolidated test for lots of files

=head1 SYNOPSIS

    use Parrot::Test::Util::Runloop;

    Parrot::Test::Util::Runloop->testloop(
        name     => 'No trailing spaces or tabs',
        files    => [ $DIST->get_c_language_files() ],
        skips    => { 'lib/Parrot/Test/Util/Runloop.pm' => 'devel' },
        per_line => sub { !/.?[ \t]+$/ };


=head1 DESCRIPTION

This module provides a basic runloop for test scripts which perform the same
test, over and over, on lots of files.  It is intended to consolidate some code
to handle loops, skips etc, replicated many times in the t/distro/ and
t/codingstd/ test directories.

You can specify a callback routine to get called back once per line (with the
per_line attribute), or once per file (with the per_file attribute).  The
per_line callback gets passed the line as a text string.  The per_file callback
gets passed the whole file as a text string.  If the callback function returns
positive, the test passed, otherwise the test failed.  Failures are tallied,
and later reported to the test harness once, as a single test.  On failure,
some informational diagnostics are also generated, showing the user which
file(s) and which line(s) (if applicable) had the failure.


=head1 AUTHOR

Written by Mark Glines, based on an idea (and lots of enthusiasm) from
Jerry Gay and Will Coleda.


=cut

package Parrot::Test::Util::Runloop;

use strict;
use warnings;

use Carp;
use Test::More;
use IO::File ();

sub testloop {
    my ($self, %args) = @_;
    # sanity
    my $usage = "Usage: Parrot::Test::Util::Runloop->testloop(\n"
               ."    name => 'foo',\n"
               ."    files => [ ... ],\n"
               ."    per_line => sub { ... });\n";
    croak $usage unless exists $args{name};
    croak $usage unless exists $args{files};
    croak "'files' is not an array reference!" unless ref($args{files}) eq 'ARRAY';
    croak "no per_file or per_line test callback was provided!"
        unless exists($args{per_file}) || exists($args{per_line});

    my @failures;
    my $failed_files = 0;

    foreach my $path (sort @{$args{files}}) {
        $path = $path->path if ref $path;
        next if exists($args{skips}) && exists($args{skips}{$path});

        my $file = IO::File->new("<$path")
            or die "Cannot open '$path' for reading: $!\n";

        my @lines = $file->getlines();
        my $error_line = "$path";
        my $have_errors = 0;

        if(exists($args{per_file})) {
            my $cb = $args{per_file};
            my $buf = join('', @lines);
            # do the per-file test
            unless($cb->($buf)) {
                push(@failures, $error_line);
            }
        }

        if(exists($args{per_line})) {
            my $cb = $args{per_line};

            # do the test, once for each line
            foreach my $n (0..@lines-1) {
                my $line = $lines[$n];
                unless($cb->($line)) {
                    $error_line .= "," if $have_errors;
                    $error_line .= " " . ($n+1);
                    $have_errors = 1;
                }
            }

            push(@failures, $error_line) if $have_errors;
            $failed_files++ if $have_errors;
        }
    }
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    ok(!@failures, $args{name});
    if(@failures) {
        diag($args{diag_prefix} . " in the following files:")
            if exists $args{diag_prefix};
        foreach my $failure (@failures) {
            diag($failure);
        }
        my $failures = @failures;
        my $total_files = @{$args{files}};
        diag("That's $failures failed files out of $total_files files total.");
    }
}

1;

# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 100
# End:
# vim: expandtab shiftwidth=4:
