view release on metacpan or  search on metacpan

t/04-rule.t  view on Meta::CPAN

    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");
    #warn Dumper($match);
    my $capture = $match->();
    #warn Dumper($capture);
    is($capture->{a},'sometext','simple capture');
}

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

{
    # 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' );
    ok( !$match->bool );

    $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' );
    ok( !$match->bool );

    $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' );
    ok( !$match->bool );

    $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" );