package Test::Many;

use strict;
use warnings;
use Test::More;

use lib (-d 't' ? File::Spec->catdir(qw(t lib)) : 'lib');

# Private test utilities
use PrimitiveCapture;

# DIY Exporter
{
    my $callpkg = caller(0);
    for (qw(test_many NOT ERR TODO)) {
        no strict 'refs';
        *{"$callpkg\::$_"} = \&{__PACKAGE__ . "\::$_"};
    }
}

{
    # Minimal tie package to capture output to a filehandle
    package Capture;
    sub TIEHANDLE { bless {} }
    sub PRINT { shift->{buf} .= join '', @_ }
    sub PRINTF    { my $obj = shift; my $fmt = shift;
                    $obj->{buf} .= sprintf $fmt, @_ }
    sub content { shift->{buf} }
}


#########################################################################

# test_many(): a framework for running XS parser tests.
#
# It runs a series of pattern tests on the C output generated by one or
# more XS code snippets which share a common preamble. The input XS and
# output C are stored in strings rather than accessing physical *.xs and
# .c files.
#
# Its arguments are:
#
#    $preamble       A multi-line string which is prepended to each XS test
#                    item before being parsed. It typically has MODULE and
#                    PROTOTYPES lines and sometimes a TYPEMAP block.
#
#    $extract_prefix Specify a prefix of the name of the C XSUB to be
#                    extracted out and used in subsequent pattern matches
#                    and in "got vs expected" diagnostics. For example a
#                    foo XSUB in package Foo::Bar will have the C name
#                    XS_Foo__Bar_foo, so a prefix of 'XS_Foo__Bar_' will
#                    extract any XSUB declared in the Foo::Bar package.
#                    Similarly, boot_Foo__Bar will extract the boot XSUB
#                    for that package. If undef, the whole C file will be
#                    used for matching and in error messages.
#
#    $test_fns       An array ref of tests to run; see below.
#
#    $options        An optional array ref of option key/value pairs
#                    to be passed as extra parameters to the
#                    process_file() method call, e.g. [ inout => 1 ]
#
# Each element in the $test_fns array ref is an array ref containing
# some XS code and a series of pattern match tests to run against the
# result:
#  
# [
#     "common prefix for test descriptions",
#     "lines to be used\n as the XS test code\n",
#
#     [ flags, qr/expected/, "test description" (, "TODO text")],
#
#     [ ... and more tests ..],
#
#     ....
# ]
#
#  where flags is zero or more of:
#
#    NOT:  invert: pass if the regex *doesn't* match
#    ERR:  test regex against STDERR and $@ rather than STDOUT
#    TODO: mark the test as TODO.  If set, an optional extra field
#         may be included, which is the TODO description.


# (avoid 'use constant' as an extra build-time dependency)
sub NOT()  { 1; }
sub ERR()  { 2; }
sub TODO() { 4; }

sub test_many {
    my ($preamble, $extract_prefix, $test_fns, $options) = @_;
    $options = [] unless $options;

    for my $test_fn (@$test_fns) {
        my ($desc_prefix, $xsub_lines, @tests) = @$test_fn;

        my $text = $preamble . $xsub_lines;

        tie *FH, 'Capture';
        my $pxs = ExtUtils::ParseXS->new;
        my $err;
        my $stderr = PrimitiveCapture::capture_stderr(sub {
            eval {
                $pxs->process_file( filename => \$text, output => \*FH,
                                    @$options);
            };
            $err = $@;
        });
        if (defined $err and length $err) {
            $stderr = "" unless defined $stderr;
            $stderr = $err . $stderr;
        }

        my $out = tied(*FH)->content;
        untie *FH;

        # trim the output to just the function in question to make
        # test diagnostics smaller.
        if (defined($extract_prefix) and !length($err) and $out =~ /\S/) {
            $out =~ s/\A.*? (^\w+\(${extract_prefix} .*? ^}).*\z/$1/xms
                or do {
                    # print STDERR $out;
                    die "$desc_prefix: couldn't trim output to only function starting '$extract_prefix'\n";
                }
        }

        my $err_tested;
        for my $test (@tests) {
            my ($flags, $qr, $desc, $todo) = @$test;
            $desc = "$desc_prefix: $desc" if length $desc_prefix;
            my $str;

            if ($flags & TODO) {
                $todo = '' unless defined $todo;
            }
            elsif (defined $todo) {
                die   "$desc_prefix: Internal error:"
                    . " todo text present but not TODO flag\n";
            }

            if ($flags & ERR) {
                $err_tested = 1;
                $str = $stderr;
            }
            else {
                $str = $out;
            }
            $str = ''
                if !defined $str;
            local $TODO = $todo if $flags & TODO;

            if ($flags & NOT) {
                unlike $str, $qr, $desc;
            }
            else {
                like $str, $qr, $desc;
            }

        }
        # if there were no tests that expect an error, test that there
        # were no errors
        if (!$err_tested) {
            is $stderr, undef, "$desc_prefix: no errors expected";
        }
    }
}



1;
