Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 5249f858db
Fetching contributors…

Cannot retrieve contributors at this time

file 150 lines (121 sloc) 4.55 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 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.

# L<S05/Modifiers/:exhaustive>

=end pod

#?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)" );
        #?rakudo emit #
        %expected{$_} :delete;
        #?rakudo emit %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');

done();

# vim: ft=perl6
Something went wrong with that request. Please try again.