The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use Test::More tests => 30;
use Data::Dumper;
$Data::Dumper::Indent = 1;
use strict;
use warnings;
no warnings 'once';

use_ok( 'Pugs::Compiler::Regex' );

{
    my $rule = Pugs::Compiler::Regex->compile('\w');
    my $rule2 = eval $rule->perl5;
    warn $@ if $@;
    is( ref($rule2), 'Pugs::Compiler::Regex', "a Regex object");
    my $match = $rule2->match("abc");
    is( "$match",'a',"perl5 returns eval'able code");
}

{
    local *Test123::rule1 = Pugs::Compiler::Regex->compile('\w')->code();
    local *Test123::rule2 = Pugs::Compiler::Regex->compile('(<rule1>)*')->code();
    my $match = Test123->rule2("abc");
    #print Dumper( $$match );
    is($match,'abc',"Matched...");
    is( $match->[0][0],"a","Capture 1...");
    is( $match->[0][1],"b","Capture 2...");
    is( $match->[0][2],"c","Capture 3...");
    is( $match->[0][3],undef,"No more captures");
    is( $match->[1],undef,"No more captures");
}

{
    local *Test123::rule1 = Pugs::Compiler::Regex->compile('\w')->code();
    local *Test123::rule2 = Pugs::Compiler::Regex->compile('<rule1>*')->code();
    my $match = Test123->rule2("abc");
    is($match,'abc',"Matched...");
    is(ref($match->{rule1}),"ARRAY",'$<rule1> is an array...');
    is( $match->{rule1}[0],"a","Capture 1...");
    is( $match->{rule1}[1],"b","Capture 2...");
    is( $match->{rule1}[2],"c","Capture 3...");
    is( $match->{rule1}[3],undef,"No more captures");
}

{
    local *Test123::rule1 = Pugs::Compiler::Regex->compile('\w')->code();
    local *Test123::rule2 = Pugs::Compiler::Regex->compile('<rule1><rule1>')->code();
    my $match = Test123->rule2("abc");
    is($match,'ab',"Matched...");
    is(ref($match->{rule1}),"ARRAY",'$<rule1> is an array...');
    is( $match->{rule1}[0],"a","Capture 1...");
    is( $match->{rule1}[1],"b","Capture 2...");
    is( $match->{rule1}[3],undef,"No more captures");
}

{
    # backtracking into subrules
    my $rule1 = Pugs::Compiler::Regex->compile('(\w)+');
    my $rule2 = Pugs::Compiler::Regex->compile('a<$rule1>z');

    #print $rule1->perl5;
    #print $rule2->perl5;

    my $match = $rule2->match("abcz");
    is( "$match",'abcz',"backtracking subrule matched");

    #print Dumper($match[0]);
    is(ref($match->[0]),"ARRAY",'array...');
    is( $match->[0][0],"b","Capture 1...");
    is( $match->[0][1],"c","Capture 2...");
    is( $match->{rule1}[0][3],undef,"No more captures");
}

{
    # before
    my $rule = Pugs::Compiler::Regex->compile('(a)<before z>');
    #print $rule->perl5;
    
    my $match = $rule->match("az");
    is( "$match",'a',"before matched");

    no warnings qw( uninitialized );
    
    $match = $rule->match("a");
    is( "$match",'',"before didn't match");
    
    $match = $rule->match("ab");
    is( "$match",'',"before didn't match");
}

SKIP:
{
    skip "named parameters don't parse correctly", 1;
    my $subrule = Pugs::Compiler::Regex->compile(' .* $^a{to} ');
    #print $subrule->perl5;

    {
        package Test;
        use base 'Pugs::Grammar::Base';
        *subrule = $subrule->code;
    }
    
    my $rule = Pugs::Compiler::Regex->compile(' \[ <Test.subrule(to=>"]")> ');
    my $match = $rule->match("[abc]");
    #print Dumper $match;
    #print $match->(), "\n";
    is( "$match",'[abc]',"subrule+param matched");
}

SKIP: {
    skip "failing optional quantifier - subrule + param\n", 1;

    my $subrule = Pugs::Compiler::Regex->compile(' .*? $^a ');
    #print $subrule->perl5;

    {
        package Test;
        use base 'Pugs::Grammar::Base';
        *subrule2 = $subrule->code;
    }
    
    my $rule = Pugs::Compiler::Regex->compile(' \[ <Test.subrule2("]")> ');
    my $match = $rule->match("[abc]");
    #print Dumper $match;
    #print $match->(), "\n";
    is( "$match",'[abc]',"subrule+param matched");
}