# New Ticket Created by Dino Morelli
# Please include the string: [perl #35971]
# in the subject line of all future correspondence about this issue.
# <URL: https://rt.perl.org/rt3/Ticket/Display.html?id=35971 >
I implemented unit testing for subrules. I added new code to
Parrot::Test::PGE which accepts a ref to an array of arrays containing
named rules, generating the PIR to compile and store the rules in a
loop. Documentation changes to the POD are also included.
Also included is a new t/p6rules script to exercise it.
There are potentially lots of ways to go about this, this is just a
first crack at it. It's sort of a big change, let me know what I'm
missing. :)
files:
M MANIFEST
M lib/Parrot/Test/PGE.pm
A t/p6rules/subrules.t
-Dino
--
.~. Dino Morelli
/V\ email: [EMAIL PROTECTED]
/( )\ weblog: http://categorically.net/d/blog/
^^-^^ preferred distro: Debian GNU/Linux http://www.debian.org
Index: MANIFEST
===================================================================
--- MANIFEST (revision 8164)
+++ MANIFEST (working copy)
@@ -1740,6 +1740,7 @@
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]
Index: lib/Parrot/Test/PGE.pm
===================================================================
--- lib/Parrot/Test/PGE.pm (revision 8164)
+++ lib/Parrot/Test/PGE.pm (working copy)
@@ -10,6 +10,13 @@
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 @@
=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 @@
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
--- /dev/null 2005-05-25 09:27:40.465681720 -0400
+++ t/p6rules/subrules.t 2005-05-25 11:10:10.687678360 -0400
@@ -0,0 +1,39 @@
+use strict;
+use warnings;
+use Parrot::Test tests => 4;
+use Parrot::Test::PGE;
+
+
+p6rule_is (" int argc ",
+ [
+ [ type => 'int | double | float | char' ],
+ [ ident => '\w+' ],
+ [ _MASTER => ':w<type> <ident>' ],
+ ],
+ "simple subrules");
+
+p6rule_isnt("doggy",
+ [
+ [ type => 'int | double | float | char' ],
+ [ ident => '\w+' ],
+ [ _MASTER => ':w<type> <ident>' ],
+ ],
+ "simple subrules");
+
+p6rule_is ("(565) 325-2935",
+ [
+ [ digits => '\d+' ],
+ [ exch => '\(<digits>\)' ],
+ [ _MASTER => ':w<exch> <digits>-<digits>' ],
+ ],
+ "nested subrules");
+
+p6rule_isnt("0-900-04-41-59",
+ [
+ [ digits => '\d+' ],
+ [ exch => '\(<digits>\)' ],
+ [ _MASTER => ':w<exch> <digits>-<digits>' ],
+ ],
+ "nested subrules");
+
+# Don't forget to change the number of tests :-)
