Pugs::Compiler::RegexPerl5 - Compiler for Perl 6 style "Perl5" regex

    :Perl5 /.*/

    :P5 /.*/

package Pugs::Compiler::RegexPerl5;

# Version in Pugs::Compiler::Rule
# Documentation in the __END__
use 5.006;
use strict;
use warnings;

#use base 'Pugs::Compiler::Regex';

#use Pugs::Compiler::Regex;
#sub code { (+shift)->Pugs::Compiler::Regex::code( @_ ) }

# http://www.foo.be/docs/tpj/issues/vol2_3/tpj0203-0002.html
# is a good reference on the use of pos()

sub _quote_rule {
    my $rule_source = shift;
    return 'm/' . $rule_source . '/' unless $rule_source =~ m{/};
    return 'm{' . $rule_source . '}' unless $rule_source =~ m/{/ || $rule_source =~ m/}/;
    return 'm!' . $rule_source . '!' unless $rule_source =~ m/!/;
    return 'm[' . $rule_source . ']' unless $rule_source =~ m/\[/ || $rule_source =~ m/\]/;
    return 'm^' . $rule_source . '^' unless $rule_source =~ m/^/;
}

sub compile {
    my ( $class, $rule_source, $param ) = @_;
    my $self = { source => $rule_source };
    $param = ref $param ? { %$param } : {}; 
    delete $param->{P5};
    delete $param->{Perl5};
    $self->{continue} = delete $param->{continue} ||
                        delete $param->{c}        || 
                        0;
    my $compile_only = delete $param->{compile_only};
    warn "Error in rule: unknown parameter '$_'" 
        for keys %$param;
        
    # TODO - set "prior"
        
    my $captures = q'
            for ( 1 .. $#+ ) {
                push @match, Pugs::Runtime::Match->new({
                    str => $_[1], from => \\(0+$-[$_]), to => \\(0+$+[$_]),
                    bool => \\1, match => [], named => {}, capture => undef,
                });
            }
            ' . 
      #print "POS $bool ",(0+$-[0]),"-",(0+$+[0]),"\n";select(undef, undef, undef, 0.1);
      'return Pugs::Runtime::Match->new({
                str => $_[1], from => \\(0+$-[0]), to => \\(0+$+[0]),
                bool => \\$bool, match => \\@match, named => {}, capture => undef,
            });
            ';
    $self->{perl5} = 
q!do {
    my $rule; 
    $rule = sub { # grammar, string, state, args
    no warnings 'uninitialized';
    my $bool;
    my @match;
    
    return $rule->($_[0], \\$_[1], $_[2], $_[3])
        unless ref( $_[1] );  # backwards compatibility
    
    #print "POS ${$_[1]} ",pos(${$_[1]}),"\n";
    #print "p5 $_[3]{p} \n";
    
    if( $_[3]{continue} ) {
        pos(${$_[1]}) = $_[3]{p}
            if defined $_[3]{p};
        $bool = ( ${$_[1]} =~ !
        . _quote_rule( $rule_source ) 
        . q(g \) ? 1 : 0; ) 
        . $captures 
        . q!
    }
    
    if ( defined $_[3]{p} ) {
            pos(${$_[1]}) = $_[3]{p};
            $bool = ( ${$_[1]} =~ ! 
        . _quote_rule( 
                q(\\G\(?:) . $rule_source . ')' 
          ) 
        . ' ) ? 1 : 0; ' 
        . $captures 
        . q!
    }
    else {
            $bool = ( ${$_[1]} =~ !
      . _quote_rule( $rule_source ) 
      . q( \) ? 1 : 0; ) 
      . $captures . q(
    }
};
}
);
    # print 'rule perl5: ', do{use Data::Dumper; Dumper($self->{perl5})};

    unless ( $compile_only ) {
        local $@;
        $self->{code} = eval 
            $self->{perl5};
        die "Error in evaluation: $@\nSource:\n$self->{perl5}\n" if $@;
    }
    
    bless $self, 'Pugs::Compiler::Regex';
}

1;

__END__