view release on metacpan or  search on metacpan

perl5/Pugs-Compiler-Rule/t/04-rule.t  view on Meta::CPAN

    $match = $rule->match( "xy12" );
    is( "$match", "x", 'escaped char \\N #2' );
}

{
    # ambiguous rule /a?bg?/
    # XXX - is this /a? [bg]?/ or /a? b g?/
    # --- It should the same as /a? b g?/
    # 1) spaces should not make difference
    # 2) the other way, it should be as /[a?[bg]]?/
    my $rule = Pugs::Compiler::Regex->compile( 'a?bg?');
    my $match = $rule->match("cdtbprw");
    is("$match","b",'"a?bg?" equals "a? b g?".');
}

{
    # capture
    my $rule = Pugs::Compiler::Regex->compile('some (text) { return { a => $_[0][0]() ,} } ');
    my $match = $rule->match("sometext");
    my $capture = $match->();
    is(ref($capture),'HASH','Capture is a hashref');
    is($capture->{a},'text','$capture->{a}');
}

{
    # XXX - is $() working? -- now it's called '$$match'
    # capture
    my $rule = Pugs::Compiler::Regex->compile('
        some (text) 
        { 
            #print $_[0]->perl; 
            return { a => $() ,} 
        } ');
    #print "rule: ", $rule->perl;
    my $match = $rule->match("sometext");
    #print Dumper($match);
    my $capture = $match->();
    is($capture->{a},'sometext','simple capture');
}

{
    # calling unnamed subrules
    $test2::rule2 = Pugs::Compiler::Regex->compile( '.' );
    #print "Source [1]: ", $test2::rule2->perl;
    *test::rule_method2 = Pugs::Compiler::Regex->compile( '<$test2::rule2>' )->code;
    #print "Source 'test::rule_method2': ", Pugs::Compiler::Regex->compile( '<$test2::rule2>' )->perl;
    my $match = test->rule_method2( "xyzw" );
    #print "Source: ", $test2::rule2->perl;
    #print "Match: ", $match->perl;
    is( "$match", "x", 'a named subrule calls a global unnamed subrule' );
}

{
    # calling unnamed subrules
    my $match;
    eval {
    my $rule2 = Pugs::Compiler::Regex->compile( '.' );
    *test::rule_method6 = Pugs::Compiler::Regex->compile( '<$rule2>' )->code;
    $match = test->rule_method6( "xyzw" );
    };
    warn "# *** Please check if CPAN module 'PadWalker' is properly installed\n",
         "# *** This is the resulting error: $@"
        if $@;
    is( "$match", "x", 'a named subrule calls a lexical unnamed subrule' );
}

{
    my $rule = Pugs::Compiler::Regex->compile( '^x' );
    my $match = $rule->match( "\nx\n" );
    #print "Source: ", do{use Data::Dumper; Dumper($rule->{perl5})};
    #print "Match: ", $match->perl;
    is( "$match", "", 'at-start - not' );

    $match = $rule->match( "x\n" );
    #print "Source: ", do{use Data::Dumper; Dumper($rule->{perl5})};
    #print "Match: ", $match->perl;
    is( "$match", "x", 'at-start' );
}

{
    my $rule = Pugs::Compiler::Regex->compile( 'x$' );
    my $match = $rule->match( "\nx\n" );
    #print "Source: ", do{use Data::Dumper; Dumper($rule->{perl5})};
    #print "Match: ", $match->perl;
    is( "$match", "", 'at-end - not' );

    $match = $rule->match( "\nx" );
    #print "Source: ", do{use Data::Dumper; Dumper($rule->{perl5})};
    #print "Match: ", $match->perl;
    is( "$match", "x", 'at-end' );
}

{
    my $rule = Pugs::Compiler::Regex->compile( '^^x' );
    my $match = $rule->match( "\nyx\n" );
    #print "Source: ", do{use Data::Dumper; Dumper($rule->{perl5})};
    #print "Match: ", $match->perl;
    is( "$match", "", 'at-line-start - not' );

    $match = $rule->match( "\nxy\n" );
    #print "Source: ", do{use Data::Dumper; Dumper($rule->{perl5})};
    #print "Match: ", $match->perl;
    is( "$match", "x", 'at-line-start' );
    
    $match = $rule->match( "xy\n" );
    #print "Source: ", do{use Data::Dumper; Dumper($rule->{perl5})};
    #print "Match: ", $match->perl;
    is( "$match", "x", 'at-line-start, pos==0' );
}

{
    my $rule = Pugs::Compiler::Regex->compile( 'x$$' );
    my $match = $rule->match( "\nyxz\n" );
    #print "Source: ", do{use Data::Dumper; Dumper($rule->{perl5})};
    #print "Match: ", $match->perl;
    is( "$match", "", 'at-line-end - not' );

    $match = $rule->match( "\nyx\n" );
    #print "Source: ", do{use Data::Dumper; Dumper($rule->{perl5})};
    #print "Match: ", $match->perl;
    is( "$match", "x", 'at-line-end' );