File Coverage

blib/lib/Pugs/Grammar/Base.pm

Criterion	Covered	Total	%
statement	18	56	32.1
branch	0	10	0.0
condition	0	6	0.0
subroutine	6	12	50.0
pod	0	4	0.0
total	24	88	27.2

package Pugs::Grammar::Base;
use Pugs::Runtime::Match;
use Pugs::Compiler::RegexPerl5;
use Pugs::Compiler::Regex;
use Data::Dumper;
use Carp;

use charnames ":full";   # support \c[DIGIT SIX]

# This class defines , unicode character classes, etc

# internal methods - not in spec

sub no_match {
    my $grammar = shift;
    my $pos = $_[1]{p} || 0;
    return Pugs::Runtime::Match->new( {
        bool    => \0,
        str     => \$_[0],
        match   => [],
        from    => \$pos,
        to      => \$pos,
        capture => undef,
    } );
}

*fail = \&no_match;

*any = Pugs::Compiler::RegexPerl5->compile(
    '\X'
)->code;

# <
*_wb_left = Pugs::Compiler::RegexPerl5->compile(
    '\b(?=\w)'
)->code;

# word>>
*_wb_right = Pugs::Compiler::RegexPerl5->compile(
    '(?<=\w)\b'
)->code;

=for later - unused
# \h
*_horizontal_ws = Pugs::Compiler::RegexPerl5->compile(
    #'XXX - Infinite loop in pugs stdrules.t' .
    '\x20|\t'

    #'\x0a|\x0b|\x0c|\x0d|\x85'
    # from regex_tests, plus \t and ' '
)->code;

# \v
*_vertical_ws = Pugs::Compiler::RegexPerl5->compile(
    #'XXX - Infinite loop in pugs stdrules.t' .
    '[\n\r]'

    #'\x{1680}|\x{180e}|\x{2000}|\x{2001}|\x{2002}|\x{2003}|\x{2004}|\x{2005}|\x{2006}|\x{2007}|\x{2008}|\x{2008}|\x{2009}|\x{200a}|\x{202f}|\x{205f}|\x{3000}'
    # from regex_tests
)->code;
=cut

# specced methods

sub before {
    #print "Base->before: ", Dumper(\@_);
    my $grammar = shift;
    my $pos = $_[1]{p} || 0;
    my $arg = $_[1]{positionals}[0];

    # XXX - token or regex?
    my $rule = Pugs::Compiler::Regex->compile( $arg );
    my $match = $rule->match( $_[0], { pos => $pos } );

    return Pugs::Runtime::Match->new( {
        bool    => \( $match ? 1 : 0 ),
        str     => \$_[0],
        match   => [],
        from    => \$pos,
        to      => \$pos,
        capture => undef,
    } );
}

sub at {
    #print "Base->at: ", Dumper(\@_);
    my $grammar = shift;
    my $pos = $_[1]{p} || 0;
    my $arg = $_[1]{positionals}[0];
    # print "at: ",Dumper( @_ );
    return Pugs::Runtime::Match->new( {
        bool    => \( $pos == $arg ),
        str     => \$_[0],
        match   => [],
        from    => \$pos,
        to      => \$pos,
        capture => undef,
    } );
}

sub prior {
    die "Error:  is undefined"
        unless defined $main::_V6_PRIOR_;

    my $prior = $main::_V6_PRIOR_;
    ## local $main::_V6_PRIOR_;
    $prior->(@_[0, 1, 2, 2]);  # XXX fix parameter list
}

*null = Pugs::Compiler::RegexPerl5->compile(
    ''
)->code;

*ws = Pugs::Compiler::RegexPerl5->compile(
    '(?:(?
)->code;

#  = word boundary - from regex_tests
*wb = Pugs::Compiler::RegexPerl5->compile(
    '\b'
)->code;

*ident = Pugs::Compiler::RegexPerl5->compile(
    '[[:alpha:]_][[:alnum:]_]*'
)->code;

*name = Pugs::Compiler::RegexPerl5->compile(
    # from pugs tests
    '(?:[[:alpha:]_][[:alnum:]_]*::)*[[:alpha:]_][[:alnum:]_]*'
)->code;

*sp = Pugs::Compiler::RegexPerl5->compile(
    '\x20'
)->code;

*dot = Pugs::Compiler::RegexPerl5->compile(
    '\.'
)->code;

*gt = Pugs::Compiler::RegexPerl5->compile(
    '>'
)->code;

*lt = Pugs::Compiler::RegexPerl5->compile(
    '<'
)->code;

#BEGIN {
#    # this list was extracted from 'perlre'
#    for ( qw(
#        alpha alnum ascii blank
#        cntrl digit graph lower
#        print punct space upper
#        word  xdigit
#    ) ) {
#        *{$_} = Pugs::Compiler::RegexPerl5->compile(
#            "[[:$_:]]"
#        )->code;
#    }
#}

sub DESTROY { }  # avoid autoloading this

    sub AUTOLOAD {
        #my $self = shift;
        my $meth = $AUTOLOAD;
        $meth =~ s/.*:://;   # strip fully-qualified portion

        # is it a Unicode property? "isL"
        {
            local $@;
            my $p5;
            if ( exists $Pugs::Emitter::Rule::Perl5::CharClass::extra_unicode{$meth} ) {
                $p5 = $Pugs::Emitter::Rule::Perl5::CharClass::extra_unicode{$meth};
            }
            else {
                $p5 = '\p{' . $meth . '}';
                eval ' my $s="a"; $s =~ /' . $p5 . '/ ';
            }
            unless ( $@ ) {
                *{$meth} = Pugs::Compiler::RegexPerl5->compile($p5)->code;
                return $meth->( @_ );
            }
        }

        # is it a char class? "digit"
        {
          local $@;
          eval ' my $s="a"; $s =~ /[[:' . $meth . ':]]/ ';
          unless ( $@ ) {
            *{$meth} = Pugs::Compiler::RegexPerl5->compile(
              '[[:' . $meth . ':]]'
            )->code;
            return $meth->( @_ );
          }
        }

        carp "unknown rule: <$meth>";
    }

1;