# $Id$

require Parrot::Test;

package Parrot::Test::Regex;

use strict;

use Data::Dumper;
use File::Basename;
use File::Spec::Functions;


=head1 NAME

Test/Regex.pm - Testing routines specific to 'regex'.

=head1 DESCRIPTION

Does the same a 'languages/regex/test.pl'

=cut

# FIXME: This is still probably unix-only, because the parrot binary
# will have different names
my $PARROT_EXE = catfile(catdir($FindBin::Bin, updir(), updir(), updir(), updir()), "parrot");

sub run_spec {
    my ( $spec_fh ) = @_;

    my $pattern = <$spec_fh>;
    chomp($pattern);

    generate_regular($pattern);

    $_ = <$spec_fh>;
    my @spec;
    while (1) {
         my ($input, $output);

         last if ! defined $_;
         die "INPUT: expected" if ! /^INPUT:/;

         # Gather input, look for OUTPUT:
         $input = '';
         undef $output;
         while (<$spec_fh>) {
             $output = '', last if /^OUTPUT:/;
             $input .= $_;
         }
         chomp($input);
         die "EOF during INPUT section" if ! defined($output);

         # Gather output
         while (<$spec_fh>) {
             last if /^INPUT:/;
             $output .= $_;
         }

         push @spec, { input => $input, output => $output };
    }
    
    Test::More::plan( tests => scalar(@spec) );
    foreach ( @spec ) {
        process($_->{input}, $_->{output});
    }

    return 0;
}

sub generate_regular_imc {
    my ($filename, $pattern) = @_;
    open(PIR, ">$filename") or die "create $filename: $!";

    my $ctx = { };
    my $trees = Regex::expr_to_tree($pattern, $ctx, DEBUG => 0);

    my $driver = Regex::Driver->new('pir', emit_main => 1);

    print PIR <<"END";
# Regular expression test
# Generated by $0
# Pattern >>$pattern<<

END

    $driver->output_header(*PIR);

    for my $tree (@$trees) {
        $driver->output_rule(*PIR, '_regex', $tree, $ctx, DEBUG => 0);
    }

    close PIR;
}

sub generate_pbc {
    my ($imc, $pbc) = @_;
    my $status = system("$PARROT_EXE", "-o", $pbc, $imc);
    if (! defined($status) || $status) {
        die "assemble failed with status " . ($? >> 8);
    }
}

sub generate_regular {
    my $pattern = shift;

    generate_regular_imc("test.imc", $pattern);
    generate_pbc("test.imc", "test.pbc");
}

sub process {
    my ($input, $output) = @_;

    open(TEST, "$PARROT_EXE test.pbc '$input' |");

    local $/;
    my $actual_output = <TEST>;
    Test::More::is($actual_output, $output); 

    return;
}

1;
