Skip to content
Browse files

[t] and [t/spec]

 * moved exhaustive.t and hash_cap.t to spec/ (and cleaned up)
 * more tests for ~ in regexes (backtracking)


git-svn-id: http://svn.pugscode.org/pugs@24870 c213334d-75ef-0310-aa23-eaa082d1ae64
  • Loading branch information...
1 parent cd614c7 commit 8105ed26366ca304a2f9aff0010697e09c9272b9 moritz committed
Showing with 330 additions and 1 deletion.
  1. +165 −0 S05-capture/hash.t
  2. +15 −1 S05-metachars/tilde.t
  3. +150 −0 S05-modifier/exhaustive.t
View
165 S05-capture/hash.t
@@ -0,0 +1,165 @@
+use v6;
+use Test;
+
+=begin pod
+
+This file was originally derived from the perl5 CPAN module Perl6::Rules,
+version 0.3 (12 Apr 2004), file t/hash_cap.t.
+
+=end pod
+
+plan 116;
+
+if !eval('("a" ~~ /a/)') {
+ skip_rest "skipped tests - rules support appears to be missing";
+ exit;
+}
+
+#?pugs emit force_todo(1..49,51..99,101..108,111..116);
+
+# L<S05/Hash aliasing/An alias can also be specified using a hash>
+
+ok(" a b\tc" ~~ m/%<chars>=( \s+ \S+ )/, 'Named unrepeated hash capture');
+ok($/<chars>{' a'}:exists, 'One key captured');
+ok(!defined($/<chars>{' a'}), 'One value undefined');
+ok($/<chars>.keys == 1, 'No extra unrepeated captures');
+
+ok(" a b\tc" ~~ m/%<chars>=( \s+ \S+ )+/, 'Named simple hash capture');
+ok($/<chars>{' a'}:exists, 'First simple key captured');
+ok(!defined($/<chars>{' a'}), 'First simple value undefined');
+ok($/<chars>{' b'}:exists, 'Second simple key captured');
+ok(!defined($/<chars>{' b'}), 'Second simple value undefined');
+ok($/<chars>{"\tc"}:exists, 'Third simple key captured');
+ok(!defined($/<chars>{"\tc"}), 'Third simple value undefined');
+ok($/<chars>.keys == 3, 'No extra simple captures');
+
+ok(" a b\tc" ~~ m/%<first>=( \s+ \S+ )+ %<last>=( \s+ \S+)+/, 'Sequential simple hash capture');
+ok($/<first>{' a'}:exists, 'First sequential key captured');
+ok(!defined($/<first>{' a'}), 'First sequential value undefined');
+ok($/<first>{' b'}:exists, 'Second sequential key captured');
+ok(!defined($/<first>{' b'}), 'Second sequential value undefined');
+ok($/<last>{"\tc"}:exists, 'Third sequential key captured');
+ok(!defined($/<last>{"\tc"}), 'Third sequential value undefined');
+ok($/<first>.keys == 2, 'No extra first sequential captures');
+ok($/<last>.keys == 1, 'No extra last sequential captures');
+
+ok("abcxyd" ~~ m/a %<foo>=(.(.))+ d/, 'Repeated nested hash capture');
+ok($/<foo>{'c'}:exists, 'Nested key 1 captured');
+ok(!defined($/<foo><c>), 'No nested value 1 captured');
+ok($/<foo>{'y'}:exists, 'Nested key 2 captured');
+ok(!defined($/<foo><y>), 'No nested value 2 captured');
+ok($/<foo>.keys == 2, 'No extra nested captures');
+
+ok("abcd" ~~ m/a %<foo>=(.(.)) d/, 'Unrepeated nested hash capture');
+ok($/<foo>{'c'}:exists, 'Unrepeated key captured');
+ok(!defined($/<foo><c>), 'Unrepeated value not captured');
+ok($/<foo>.keys == 1, 'No extra unrepeated nested captures');
+
+ok("abcd" ~~ m/a %<foo>=((.)(.)) d/, 'Unrepeated nested hash multicapture');
+ok($/<foo>{'b'}:exists, 'Unrepeated key multicaptured');
+ok(~$/<foo><b>, 'c', 'Unrepeated value not multicaptured');
+ok($/<foo>.keys == 1, 'No extra unrepeated nested multicaptures');
+
+ok("abcxyd" ~~ m/a %<foo>=((.)(.))+ d/, 'Repeated nested hash multicapture');
+ok($/<foo>{'b'}:exists, 'Nested key 1 multicaptured');
+ok($/<foo><b>, 'c', 'Nested value 1 multicaptured');
+ok($/<foo>{'x'}:exists, 'Nested key 2 multicaptured');
+ok($/<foo><x>, 'y', 'Nested value 2 multicaptured');
+ok($/<foo>.keys == 2, 'No extra nested multicaptures');
+
+our %foo;
+ok("abcxyd" ~~ m/a %foo=(.(.))+ d/, 'Package hash capture');
+ok(%foo{'c'}:exists, 'Package hash key 1 captured');
+ok(!defined(%foo<c>), 'Package hash value 1 not captured');
+ok(%foo{'y'}:exists, 'Package hash key 2 captured');
+ok(!defined(%foo<y>), 'Package hash value 2 not captured');
+ok(%foo.keys == 2, 'No extra package hash captures');
+
+regex two {..}
+
+ok("abcd" ~~ m/a %<foo>=[<two>] d/, 'Compound hash capture');
+is($/<two>, "bc", 'Implicit subrule variable captured');
+ok($/<foo>.keys == 0, 'Explicit hash variable not captured');
+
+ok(" a b\tc" ~~ m/%<chars>=( %<spaces>=[\s+] (\S+))+/, 'Nested multihash capture');
+ok($/<chars>{'a'}:exists, 'Outer hash capture key 1');
+ok(!defined($/<chars><a>), 'Outer hash no capture value 1');
+ok($/<chars>{'b'}:exists, 'Outer hash capture key 2');
+ok(!defined($/<chars><b>), 'Outer hash no capture value 2');
+ok($/<chars>{'c'}:exists, 'Outer hash capture key 3');
+ok(!defined($/<chars><c>), 'Outer hash no capture value 3');
+ok($/<chars>.keys == 3, 'Outer hash no extra captures');
+
+ok($/<spaces>{' '}:exists, 'Inner hash capture key 1');
+ok(!defined($/<spaces>{' '}), 'Inner hash no capture value 1');
+ok($/<spaces>{' '}:exists, 'Inner hash capture key 2');
+ok(!defined($/<spaces>{' '}), 'Inner hash no capture value 2');
+ok($/<spaces>{"\t"}:exists, 'Inner hash capture key 3');
+ok(!defined($/<spaces>{"\t"}), 'Inner hash no capture value 3');
+ok($/<spaces>.keys == 3, 'Inner hash no extra captures');
+
+regex spaces { @<spaces>=[\s+] }
+
+ok(" a b\tc" ~~ m/%<chars>=( <spaces> (\S+))+/, 'Subrule hash capture');
+
+ok($/<chars>{'a'}:exists, 'Outer subrule hash capture key 1');
+ok(!defined($/<chars><a>), 'Outer subrule hash no capture value 1');
+ok($/<chars>{'b'}:exists, 'Outer subrule hash capture key 2');
+ok(!defined($/<chars><b>), 'Outer subrule hash no capture value 2');
+ok($/<chars>{'c'}:exists, 'Outer subrule hash capture key 3');
+ok(!defined($/<chars><c>), 'Outer subrule hash no capture value 3');
+ok($/<chars>.keys == 3, 'Outer subrule hash no extra captures');
+is($/<spaces>, "\t", 'Final subrule hash capture');
+
+
+ok(" a b\tc" ~~ m/%<chars>=( %<spaces>=[<?spaces>] (\S+))+/, 'Nested subrule hash multicapture');
+ok($/<chars>{'a'}:exists, 'Outer rule nested hash key multicapture');
+ok(!defined($/<chars><a>), 'Outer rule nested hash value multicapture');
+ok($/<chars>{'b'}:exists, 'Outer rule nested hash key multicapture');
+ok(!defined($/<chars><b>), 'Outer rule nested hash value multicapture');
+ok($/<chars>{'c'}:exists, 'Outer rule nested hash key multicapture');
+ok(!defined($/<chars><c>), 'Outer rule nested hash value multicapture');
+ok($/<chars>.keys == 3, 'Outer subrule hash no extra multicaptures');
+
+ok($/<spaces>{' '}:exists, 'Inner rule nested hash key multicapture');
+ok(!defined($/<spaces>{' '}), 'Inner rule nested hash value multicapture');
+ok($/<spaces>{' '}:exists, 'Inner rule nested hash key multicapture');
+ok(!defined($/<spaces>{' '}), 'Inner rule nested hash value multicapture');
+ok($/<spaces>{"\t"}:exists, 'Inner rule nested hash key multicapture');
+ok(!defined($/<spaces>{"\t"}), 'Inner rule nested hash value multicapture');
+ok($/<spaces>.keys == 3, 'Inner subrule hash no extra multicaptures');
+
+ok(" a b\tc" ~~ m/%<chars>=( (<?spaces>) (\S+))+/, 'Nested multiple hash capture');
+is($/<chars>{' '}, 'a', 'Outer rule nested hash value multicapture');
+is($/<chars>{' '}, 'b', 'Outer rule nested hash value multicapture');
+is($/<chars>{"\t"}, 'c', 'Outer rule nested hash value multicapture');
+ok($/<chars>.keys == 3, 'Outer subrule hash no extra multicaptures');
+
+my %bases = ();
+ok("Gattaca" ~~ m:i/ %bases=(A|C|G|T)+ /, 'All your bases...');
+ok(%bases{'a'}:exists, 'a key');
+ok(!defined(%bases<a>), 'No a value');
+ok(%bases{'c'}:exists, 'c key');
+ok(!defined(%bases<c>), 'No c value');
+ok(!%bases{'g'}:exists, 'No g key');
+ok(%bases{'G'}:exists, 'G key');
+ok(!defined(%bases<G>), 'No G value');
+ok(%bases{'t'}:exists, 't key');
+ok(!defined(%bases<t>), 'No t value');
+ok(%bases.keys == 4, 'No other bases');
+
+%bases = ();
+my %aca = ('aca' => 1);;
+ok("Gattaca" ~~ m:i/ %bases=(A|C|G|T)**{4} (%aca) /, 'Hash interpolation');
+ok(%bases{'a'}:exists, 'a key');
+ok(!defined(%bases<a>), 'No a value');
+ok(!%bases{'c'}:exists, 'No c key');
+ok(!%bases{'g'}:exists, 'No g key');
+ok(%bases{'G'}:exists, 'G key');
+ok(!defined(%bases<G>), 'No G value');
+ok(%bases{'t'}:exists, 't key');
+ok(!defined(%bases<t>), 'No t value');
+ok(%bases.keys == 3, 'No other bases');
+is("$1", "aca", 'Trailing aca');
+
+
View
16 S05-metachars/tilde.t
@@ -1,7 +1,7 @@
use v6;
use Test;
-plan 22;
+plan 26;
# L<S05/New metacharacters/"The ~ operator is a helper for matching
# nested subrules with a specific terminator">
@@ -50,3 +50,17 @@ ok 'x(ab' !~~ m/<t1>/, '~ and constant atoms (missing closing bracket)';
ok '())' !~~ m/^ <m1> $/, '"())" is not matched';
ok 'a()' !~~ m/^ <m1> $/, '"a()" is not matched';
}
+
+#?rakudo skip 'backtracking into ~'
+{
+ regex even_a { ['a' ~ 'a' <even_a> ]? };
+ ok 'aaaa' ~~ m/^ <even_a> $ /, 'backtracking into tilde rule (1)';
+ ok 'aaa' !~~ m/^ <even_a> $ /, 'backtracking into tilde rule (2)';
+}
+
+#?rakudo skip 'backtracking to find ~ goal'
+{
+ regex even_b { 'a' ~ 'a' <even_b>? };
+ ok 'aaaa' ~~ m/^ <even_b> /, 'tilde regex backtracks to find its goal';
+ ok 'aaa' !~~ m/^ <even_b> /, '...and fails for odd numbers';
+}
View
150 S05-modifier/exhaustive.t
@@ -0,0 +1,150 @@
+use v6;
+use Test;
+
+=begin pod
+
+This file was originally derived from the perl5 CPAN module Perl6::Rules,
+version 0.3 (12 Apr 2004), file t/exhaustive.t.
+
+=end pod
+
+plan 44; # Will need to be changed once :exhaustive starts working.
+
+if !eval('("a" ~~ /a/)') {
+ skip_rest "skipped tests - rules support appears to be missing";
+} else {
+
+#?pugs emit force_todo(2,3,5,6,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42);
+
+my $str = "abrAcadAbbra";
+
+my @expected = (
+ [ 0 => 'abrAcadAbbra' ],
+ [ 0 => 'abrAcadA' ],
+ [ 0 => 'abrAca' ],
+ [ 0 => 'abrA' ],
+ [ 3 => 'AcadAbbra' ],
+ [ 3 => 'AcadA' ],
+ [ 3 => 'Aca' ],
+ [ 5 => 'adAbbra' ],
+ [ 5 => 'adA' ],
+ [ 7 => 'Abbra' ],
+);
+
+for (1..2) -> $rep {
+ ok($str ~~ m:i:exhaustive/ a .+ a /, "Repeatable every-way match ($rep)" );
+
+ ok(@$/ == @expected, "Correct number of matches ($rep)" );
+ my %expected; %expected{map {$_[1]}, @expected} = (1) x @expected;
+ my %position; %position{map {$_[1]}, @expected} = map {$_[0]}, @expected;
+ for (@$/) {
+ ok( %expected{$_}, "Matched '$_' ($rep)" );
+ ok( %position{$_} == $_.pos, "At correct position of '$_' ($rep)" );
+ %expected{$_} :delete;
+ }
+ ok(%expected.keys == 0, "No matches missed ($rep)" );
+}
+
+ok(!( "abcdefgh" ~~ m:exhaustive/ a .+ a / ), 'Failed every-way match');
+ok(@$/ == 0, 'No matches');
+
+ok($str ~~ m:ex:i/ a (.+) a /, 'Capturing every-way match');
+
+ok(@$/ == @expected, 'Correct number of capturing matches');
+my %expected; %expected{map {$_[1]}, @expected} = (1) x @expected;
+
+for (@$/) {
+ ok( %expected{$_}, "Capture matched '$_'" );
+ ok( $_[1] = substr($_[0],1,-1), "Captured within '$_'" );
+ %expected{$_} :delete;
+}
+
+my @adj = <time>;
+my @noun = <time flies arrow>;
+my @verb = <time flies like>;
+my @art = <an>;
+my @prep = <like>;
+
+ok( "time flies like an arrow" ~~
+ m:s:ex/^ [
+ $<adj> = (@adj)
+ $<subj> = (@noun)
+ $<verb> = (@verb)
+ $<art> = (@art)
+ $<obj> = (@noun)
+ |
+ $<subj> = (@noun)
+ $<verb> = (@verb)
+ $<prep> = (@prep)
+ $<art> = (@art)
+ $<obj> = (@noun)
+ |
+ $<verb> = (@verb)
+ $<obj> = (@noun)
+ $<prep> = (@prep)
+ $<art> = (@art)
+ $<noun> = (@noun)
+ ]
+ /, 'Multiple capturing');
+
+is(~$/[0]<adj>, 'time', 'Capture 0 adj');
+is(~$/[0]<subj>, 'flies', 'Capture 0 subj');
+is(~$/[0]<verb>, 'like', 'Capture 0 verb');
+is(~$/[0]<art>, 'an', 'Capture 0 art');
+is(~$/[0]<obj>, 'arrow', 'Capture 0 obj');
+
+is(~$/[1]<subj>, 'time', 'Capture 1 subj');
+is(~$/[1]<verb>, 'flies', 'Capture 1 verb');
+is(~$/[1]<prep>, 'like', 'Capture 1 prep');
+is(~$/[1]<art>, 'an', 'Capture 1 art');
+is(~$/[1]<obj>, 'arrow', 'Capture 1 obj');
+
+is(~$/[2]<verb>, 'time', 'Capture 2 verb');
+is(~$/[2]<obj>, 'flies', 'Capture 2 obj');
+is(~$/[2]<prep>, 'like', 'Capture 2 prep');
+is(~$/[2]<art>, 'an', 'Capture 2 art');
+is(~$/[2]<noun>, 'arrow', 'Capture 2 noun');
+
+
+regex subj { <?noun> }
+regex obj { <?noun> }
+regex noun { time | flies | arrow }
+regex verb { flies | like | time }
+regex adj { time }
+regex art { an? }
+regex prep { like }
+
+skip_rest("XXX - infinite loop"); exit;
+
+ok("time flies like an arrow" ~~
+ m:s:ex/^ [ <adj> <subj> <verb> <art> <obj>
+ | <subj> <verb> <prep> <art> <noun>
+ | <verb> <obj> <prep> <art> <noun>
+ ]
+ /,
+ "Any with capturing rules"
+);
+
+is(~$/[0]<adj>, 'time', 'Rule capture 0 adj');
+is(~$/[0]<subj>, 'flies', 'Rule capture 0 subj');
+is(~$/[0]<verb>, 'like', 'Rule capture 0 verb');
+is(~$/[0]<art>, 'an', 'Rule capture 0 art');
+is(~$/[0]<obj>, 'arrow', 'Rule capture 0 obj');
+
+is(~$/[1]<subj>, 'time', 'Rule capture 1 subj');
+is(~$/[1]<verb>, 'flies', 'Rule capture 1 verb');
+is(~$/[1]<prep>, 'like', 'Rule capture 1 prep');
+is(~$/[1]<art>, 'an', 'Rule capture 1 art');
+is(~$/[1]<noun>, 'arrow', 'Rule capture 1 noun');
+
+is(~$/[2]<verb>, 'time', 'Rule capture 2 verb');
+is(~$/[2]<obj>, 'flies', 'Rule capture 2 obj');
+is(~$/[2]<prep>, 'like', 'Rule capture 2 prep');
+is(~$/[2]<art>, 'an', 'Rule capture 2 art');
+is(~$/[2]<noun>, 'arrow', 'Rule capture 2 noun');
+
+
+ok(!( "fooooo" ~~ m:exhaustive { s o+ } ), 'Subsequent failed any match...');
+ ok(@$/ == 0, '...leaves @$/ empty');
+}
+

0 comments on commit 8105ed2

Please sign in to comment.
Something went wrong with that request. Please try again.