Author: pmichaud
Date: Thu Nov 3 09:34:37 2005
New Revision: 9751
Modified:
trunk/lib/Parrot/Test/PGE.pm
trunk/t/library/pge.t
Log:
* Added support for globbing tests, via pgeglob_is, pgeglob_isnt, pgeglob_like.
* Converted t/library/pge.t to use globbing tests.
Modified: trunk/lib/Parrot/Test/PGE.pm
==============================================================================
--- trunk/lib/Parrot/Test/PGE.pm (original)
+++ trunk/lib/Parrot/Test/PGE.pm Thu Nov 3 09:34:37 2005
@@ -120,6 +120,62 @@ sub p6rule_like {
@todo);
}
+=item C<pgeglob_is($target, $pattern, $description)>
+
+Runs the target string against the Perl 6 pattern, passing the test
+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.)
+
+=cut
+
+sub pgeglob_is {
+ my ($target, $pattern, $description, @todo) = @_;
+
+ Parrot::Test::pir_output_is(
+ Parrot::Test::PGE::_generate_glob_for($target, $pattern),
+ 'matched',
+ $description,
+ @todo);
+}
+
+=item C<pgeglob_isnt($target, $pattern, $description)>
+
+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 pgeglob_isnt {
+ my ($target, $pattern, $description, @todo) = @_;
+
+ Parrot::Test::pir_output_is(
+ Parrot::Test::PGE::_generate_glob_for($target, $pattern),
+ 'failed',
+ $description,
+ @todo);
+}
+
+=item C<pgeglob_like($target, $pattern, $expected, $description)>
+
+Runs the target string against the Perl 6 pattern, passing the test
+if the output produced by the test code matches the C<$expected>
+parameter. Note that C<$expected> is a I<Perl 5> pattern.
+
+=cut
+
+sub pgeglob_like {
+ my ($target, $pattern, $expected, $description, @todo) = @_;
+ Parrot::Test::pir_output_like(
+ Parrot::Test::PGE::_generate_glob_for($target, $pattern, 1),
+ $expected,
+ $description,
+ @todo);
+}
+
+
package Parrot::Test::PGE;
sub _parrot_stringify {
@@ -223,6 +279,38 @@ sub _generate_subrule_pir {
return $pirCode;
}
+sub _generate_glob_for {
+ my($target, $pattern, $captures) = @_;
+ $target = _parrot_stringify($target);
+ $pattern = _parrot_stringify($pattern);
+ return qq(
+ .sub _PGE_Test
+ .local pmc glob_compile
+ load_bytecode "PGE.pbc"
+ load_bytecode "PGE/Glob.pir"
+ load_bytecode "PGE/Dumper.pir"
+ load_bytecode "PGE/Text.pir"
+ find_global glob_compile, "PGE", "glob"
+
+ .local string target
+ .local string pattern
+ .local pmc rulesub
+ .local pmc match
+ .local pmc code
+ .local pmc exp
+ target = unicode:"$target"
+ pattern = "$pattern"
+ (rulesub, code, exp) = glob_compile(pattern)
+ match = rulesub(target)
+ unless match goto match_fail
+ match_success:
+ print "matched"
+ goto match_end
+ match_fail:
+ print "failed"
+ match_end:
+ .end\n);
+}
=back
=head1 AUTHOR
Modified: trunk/t/library/pge.t
==============================================================================
--- trunk/t/library/pge.t (original)
+++ trunk/t/library/pge.t Thu Nov 3 09:34:37 2005
@@ -14,76 +14,18 @@ t/library/pge.t - Grammar Engine tests
use strict;
-use Parrot::Test tests => 4;
+use Parrot::Test tests => 9;
+use Parrot::Test::PGE;
-# 1
-pir_output_is(<<'CODE', <<'OUT', "Glob, wildcards");
+# 1-6
+pgeglob_is ('bznza', 'b?n*a', "glob wildcards");
+pgeglob_is ('bana', 'b?n*a', "glob wildcards");
+pgeglob_isnt('bnana', 'b?n*a', "glob wildcards");
+pgeglob_is ('bnan', '?n?*', "glob wildcards");
+pgeglob_is ('ana', '?n?*', "glob wildcards");
+pgeglob_isnt('an', '?n?*', "glob wildcards");
-.sub _main
- load_bytecode "library/PGE.pbc"
- load_bytecode "library/PGE/Glob.pir"
-
- .local pmc rule
- $P0 = find_global "PGE", "glob"
- (rule, $P1, $P2) = $P0("b?n*a")
-
- $P1 = rule("banana")
- if $P1 goto ok1
- print "not "
-ok1:
- print "ok1\n"
-
- $P1 = rule("bznza")
- if $P1 goto ok2
- print "not "
-ok2:
- print "ok2\n"
-
- $P1 = rule("bana")
- if $P1 goto ok3
- print "not "
-ok3:
- print "ok3\n"
-
- $P1 = rule("bnana")
- unless $P1 goto ok4
- print "not "
-ok4:
- print "ok4\n"
-
-
- (rule, $P1, $P2) = $P0("?n?*")
-
- $P1 = rule("bnan")
- if $P1 goto ok5
- print "not "
-ok5:
- print "ok5\n"
-
- $P1 = rule("ana")
- if $P1 goto ok6
- print "not "
-ok6:
- print "ok6\n"
-
- $P1 = rule("an")
- unless $P1 goto ok7
- print "not "
-ok7:
- print "ok7\n"
-
-.end
-CODE
-ok1
-ok2
-ok3
-ok4
-ok5
-ok6
-ok7
-OUT
-
-# 2
+# 7
pir_output_is(<<'CODE', <<'OUT', "Glob, character classes");
.sub _main
@@ -177,7 +119,7 @@ ok10
ok11
OUT
-# 3
+# 8
pir_output_is(<<'CODE', <<'OUT', "Glob, alternate");
.sub _main
@@ -271,7 +213,7 @@ ok10
ok11
OUT
-# 4
+# 9
pir_output_is(<<'CODE', <<'OUT', "This made Parrot m4 fail");
.sub 'test' :main
