1package Path::Dispatcher::Rule::Tokens;
2# ABSTRACT: predicate is a list of tokens
3
4our $VERSION = '1.08';
5
6use Moo;
7use MooX::TypeTiny;
8use Types::Standard qw(Str ArrayRef Bool);
9
10extends 'Path::Dispatcher::Rule';
11
12has tokens => (
13    is         => 'ro',
14    isa        => ArrayRef,
15    required   => 1,
16);
17
18has delimiter => (
19    is      => 'ro',
20    isa     => Str,
21    default => ' ',
22);
23
24has case_sensitive => (
25    is      => 'ro',
26    isa     => Bool,
27    default => 1,
28);
29
30sub _match_as_far_as_possible {
31    my $self = shift;
32    my $path = shift;
33
34    my @got      = $self->tokenize($path->path);
35    my @expected = @{ $self->tokens };
36    my @matched;
37
38    while (@got && @expected) {
39        my $expected = $expected[0];
40        my $got      = $got[0];
41
42        last unless $self->_match_token($got, $expected);
43
44        push @matched, $got;
45        shift @expected;
46        shift @got;
47    }
48
49    return (\@matched, \@got, \@expected);
50}
51
52sub _match {
53    my $self = shift;
54    my $path = shift;
55
56    my ($matched, $got, $expected) = $self->_match_as_far_as_possible($path);
57
58    return if @$expected; # didn't provide everything necessary
59    return if @$got && !$self->prefix; # had tokens left over
60
61    my $leftover = $self->untokenize(@$got);
62
63    return if !$matched;
64
65    return {
66        positional_captures => $matched,
67        leftover            => $leftover,
68    };
69}
70
71sub complete {
72    my $self = shift;
73    my $path = shift;
74
75    my ($matched, $got, $expected) = $self->_match_as_far_as_possible($path);
76    return if @$got > 1; # had tokens leftover
77    return if !@$expected; # consumed all tokens
78
79    my $next = shift @$expected;
80    my $part = @$got ? shift @$got : '';
81    my @completions;
82
83    for my $completion (ref($next) eq 'ARRAY' ? @$next : $next) {
84        next if ref($completion);
85
86        next unless substr($completion, 0, length($part)) eq $part;
87        push @completions, $self->untokenize(@$matched, $completion);
88    }
89
90    return @completions;
91}
92
93sub _each_token {
94    my $self     = shift;
95    my $got      = shift;
96    my $expected = shift;
97    my $callback = shift;
98
99    if (ref($expected) eq 'ARRAY') {
100        for my $alternative (@$expected) {
101            $self->_each_token($got, $alternative, $callback);
102        }
103    }
104    elsif (!ref($expected) || ref($expected) eq 'Regexp') {
105        $callback->($got, $expected);
106    }
107    else {
108        die "Unexpected token '$expected'"; # the irony is not lost on me :)
109    }
110}
111
112sub _match_token {
113    my $self     = shift;
114    my $got      = shift;
115    my $expected = shift;
116
117    my $matched = 0;
118    $self->_each_token($got, $expected, sub {
119        my ($g, $e) = @_;
120        if (!ref($e)) {
121            ($g, $e) = (lc $g, lc $e) if !$self->case_sensitive;
122            $matched ||= $g eq $e;
123        }
124        elsif (ref($e) eq 'Regexp') {
125            $matched ||= $g =~ $e;
126        }
127    });
128
129    return $matched;
130}
131
132sub tokenize {
133    my $self = shift;
134    my $path = shift;
135    return grep { length } split $self->delimiter, $path;
136}
137
138sub untokenize {
139    my $self   = shift;
140    my @tokens = @_;
141    return join $self->delimiter,
142           grep { length }
143           map { split $self->delimiter, $_ }
144           @tokens;
145}
146
147__PACKAGE__->meta->make_immutable;
148no Moo;
149
1501;
151
152__END__
153
154=pod
155
156=encoding UTF-8
157
158=head1 NAME
159
160Path::Dispatcher::Rule::Tokens - predicate is a list of tokens
161
162=head1 VERSION
163
164version 1.08
165
166=head1 SYNOPSIS
167
168    my $rule = Path::Dispatcher::Rule::Tokens->new(
169        tokens    => [ "comment", "show", qr/^\d+$/ ],
170        delimiter => '/',
171        block     => sub { display_comment(shift->pos(3)) },
172    );
173
174    $rule->match("/comment/show/25");
175
176=head1 DESCRIPTION
177
178Rules of this class use a list of tokens to match the path.
179
180=head1 ATTRIBUTES
181
182=head2 tokens
183
184Each token can be a literal string, a regular expression, or a list of either
185(which are taken to mean alternations). For example, the tokens:
186
187    [ 'ticket', [ 'show', 'display' ], [ qr/^\d+$/, qr/^#\w{3}/ ] ]
188
189first matches "ticket". Then, the next token must be "show" or "display". The
190final token must be a number or a pound sign followed by three word characters.
191
192The results are the tokens in the original string, as they were matched. If you
193have three tokens, then C<< match->pos(1) >> will be the string's first token
194("ticket"), C<< match->pos(2) >> its second ("display"), and C<< match->pos(3)
195>> its third ("#AAA").
196
197Capture groups inside a regex token are completely ignored.
198
199=head2 delimiter
200
201A string that is used to tokenize the path. The delimiter must be a string
202because prefix matches use C<join> on unmatched tokens to return the leftover
203path. In the future this may be extended to support having a regex delimiter.
204
205The default is a space, but if you're matching URLs you probably want to change
206this to a slash.
207
208=head2 case_sensitive
209
210Decide whether the rule matching is case sensitive. Default is 1, case
211sensitive matching.
212
213=head1 SUPPORT
214
215Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Path-Dispatcher>
216(or L<bug-Path-Dispatcher@rt.cpan.org|mailto:bug-Path-Dispatcher@rt.cpan.org>).
217
218=head1 AUTHOR
219
220Shawn M Moore, C<< <sartak at bestpractical.com> >>
221
222=head1 COPYRIGHT AND LICENSE
223
224This software is copyright (c) 2020 by Shawn M Moore.
225
226This is free software; you can redistribute it and/or modify it under
227the same terms as the Perl 5 programming language system itself.
228
229=cut
230