Additional tests for PGE.

Courtesy of Dino Morelli <dmorelli@reactorweb.net>.


git-svn-id: https://svn.parrot.org/parrot/trunk@8241 d31e2699-5ff4-0310-a27c-f18f2fbe73fe

MANIFEST

@@ -1745,6 +1745,7 @@ t/p6rules/backtrack.t                             []
 t/p6rules/capture.t                               []
 t/p6rules/cclass.t                                []
 t/p6rules/escape.t                                []
+t/p6rules/subrules.t                              []
 t/p6rules/ws.t                                    []
 t/perl/Parrot_Distribution.t                      [devel]
 t/perl/Parrot_Docs.t                              [devel]

lib/Parrot/Test/PGE.pm

@@ -10,6 +10,13 @@ In a .t file:
   use Parrot::Test::PGE;
 
   p6rule_is('abc', '^abc', 'BOS abc');
+  p6rule_is("   int argc ",
+    [
+        [ type    => 'int | double | float | char' ],
+        [ ident   => '\w+' ],
+        [ _MASTER => ':w<type> <ident>' ],
+    ],
+    "simple subrules test");
   p6rule_isnt('abc', '^bc', 'BOS bc');
   p6rule_like('abcdef', 'bcd', qr/0: <bcd @ 1>/, '$0 capture');
 
@@ -31,33 +38,63 @@ require Parrot::Test;
 =item C<p6rule_is($target, $pattern, $description)>
 
 Runs the target string against the Perl 6 pattern, passing the test
-if they match.  Note that the pattern should be specified as a string
-and without leading/trailing pattern delimiters.  (Hint: if you try
-using qr// for the $pattern then you're misreading what this does.)
+if they match.  Note that patterns should be specified as strings
+and without leading/trailing pattern delimiters.
+
+(Hint: if you try using qr// for the $pattern then you're misreading
+what this does.)
+
+subrules: In addition to a simple scalar string, the pattern can be a
+reference to an array of arrays. Containing subrules that refer to each
+other. In this form:
+
+    [
+        [ name1 => 'pattern 1' ],
+        [ name2 => 'pattern 2' ],
+        [ name3 => '<name1> pattern 3' ],
+        [ _MASTER => '<name1> <name2> <name3>' ],
+    ],
+
+The last rule, labelled with _MASTER, is the rule that your target string
+will be matched against. The 'outer rule' if you will.
 
 =cut
 
 sub p6rule_is {
     my ($target, $pattern, $description) = @_;
-    Parrot::Test::pir_output_is(
+    if (ref $pattern) {
+        Parrot::Test::pir_output_is(
+            Parrot::Test::PGE::_generate_subrule_pir($target, $pattern),
+            'matched',
+            $description);
+    } else {
+        Parrot::Test::pir_output_is(
             Parrot::Test::PGE::_generate_pir_for($target, $pattern),
             'matched',
             $description);
+    }
 }
 
 =item C<p6rule_isnt($target, $pattern, $description)>
 
-Runs the target string against the Perl 6 pattern, passing the test
-if they do not match.
+Runs the target string against the Perl 6 pattern, passing the test if
+they do not match. The same pattern argument syntax above applies here.
 
 =cut
 
 sub p6rule_isnt {
     my ($target, $pattern, $description) = @_;
-    Parrot::Test::pir_output_is(
+    if (ref $pattern) {
+        Parrot::Test::pir_output_is(
+            Parrot::Test::PGE::_generate_subrule_pir($target, $pattern),
+            'failed',
+            $description);
+    } else {
+        Parrot::Test::pir_output_is(
             Parrot::Test::PGE::_generate_pir_for($target, $pattern),
             'failed',
             $description);
+    }
 }
 
 =item C<p6rule_like($target, $pattern, $expected, $description)>
@@ -125,7 +162,58 @@ sub _generate_pir_for {
           match_end:
         .end\n);
 }
-
+
+sub _generate_subrule_pir {
+    my($target, $pattern) = @_;
+    $target = _parrot_stringify($target);
+
+    # Beginning of the pir code
+    my $pirCode = qq(
+        .sub _PGE_Test
+            .local pmc p6rule_compile
+            load_bytecode "PGE.pbc"
+            find_global p6rule_compile, "PGE", "p6rule"
+
+            .local string target
+            .local pmc rulesub
+            .local pmc match
+            .local string name
+            .local string subpat
+
+            target = "$target"\n\n);
+
+    # Loop to create the subrules pir code 
+    for my $ruleRow (@$pattern) {
+        my ($name, $subpat) = @$ruleRow;
+        $subpat = _parrot_stringify($subpat);
+
+        $pirCode .= qq(
+            name = "$name"
+            subpat = "$subpat"
+            rulesub = p6rule_compile(subpat)\n);
+
+        last if $name eq '_MASTER';
+
+        $pirCode .= qq(
+            store_global name, rulesub\n\n);
+    }
+
+    # End of the pir code
+    $pirCode .= qq(
+            match = rulesub(target)
+
+            unless match goto match_fail
+          match_success:
+            print "matched"
+            goto match_end
+          match_fail:
+            print "failed"
+          match_end:
+        .end\n);
+
+    return $pirCode;
+}
+
 =back
 
 =head1 AUTHOR

t/p6rules/capture.t

@@ -1,6 +1,9 @@
-use Parrot::Test tests => 34;
+use strict;
+use warnings;
+use Parrot::Test tests => 38;
 use Parrot::Test::PGE;
 
+
 p6rule_is  ('zzzabcdefzzz', '(a.)..(..)', 'basic match');
 p6rule_like('zzzabcdefzzz', '(a.)..(..)', qr/mob: <abcdef @ 3>/, 'basic $0');
 p6rule_like('zzzabcdefzzz', '(a.)..(..)', qr/mob 0: <ab @ 3>/, 'basic $1');
@@ -56,6 +59,15 @@ p6rule_like('abcdefg', '$1:=[ (.) (.) (.) ] (.)', qr/mob 4: <c @ 2>/,
 p6rule_like('abcdefg', '$1:=[ (.) (.) (.) ] (.)', qr/mob 5: <d @ 3>/,
             'perl5 numbered captures $1');
 
+p6rule_like('   abc = 123', ':w $<key>:=[\w+] = $<val>:=[\S+]',
+            qr/mob<key>: <abc @ 3>/, 'named capture');
+p6rule_like('   abc = 123', ':w $<key>:=[\w+] = $<val>:=[\S+]',
+            qr/mob<val>: <123 @ 9>/, 'named capture');
+p6rule_like('   abc def ghi', ':w (\w+) $<foo>:=(\w+) (\w+)',
+            qr/mob<foo>: <def @ 7>/, 'mixing named and unnamed capture');
+p6rule_like('   abc def ghi', ':w (\w+) $<foo>:=(\w+) (\w+)',
+            qr/mob 1: <ghi @ 11>/, 'mixing named and unnamed capture');
+
 p6rule_is  ('bookkeeper', '[(.)$0]+', 'backreference');
 p6rule_like('bookkeeper', '[(.)$0]+', 
             qr/mob 0 0: <o @ 1>/, 'backref $1');
@@ -65,8 +77,7 @@ p6rule_like('bookkeeper', '[(.)$0]+',
             qr/mob 0 2: <e @ 5>/, 'backref $1');
 
 p6rule_like('123x', '(.)*x',
-            qr/mob: <123x @ 0>/, 'repeated dot capture')
-
+            qr/mob: <123x @ 0>/, 'repeated dot capture');
 
 
-# dont forget to change the number of test :-)
+# Don't forget to change the number of test :-)

t/p6rules/ws.t

@@ -1,6 +1,6 @@
 use strict;
 use warnings;
-use Parrot::Test tests => 17;
+use Parrot::Test tests => 19;
 use Parrot::Test::PGE;
 
 
@@ -32,6 +32,11 @@ p6rule_is  ('foo - bar', ':w\bfoo -? bar',
 p6rule_is  ('foo - bar', ':w::foo -? bar',
     'basic ws match with backtrack no-op modifier separation');
 
+p6rule_like('dog := spot', ':w(\w+) \:= (\S+)', qr/mob 0: <dog @ 0>/,
+    'words and capture together');
+p6rule_like('dog := spot', ':w(\w+) \:= (\S+)', qr/mob 1: <spot @ 7>/,
+    'words and capture together');
+
 # XXX: When available, add tests for full form :words modifier
 
 # Don't forget to change the number of tests :-)