line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
|
2
|
|
|
|
|
|
|
use Carp; |
3
|
37
|
|
|
37
|
|
187289
|
|
|
37
|
|
|
|
|
84
|
|
|
37
|
|
|
|
|
1852
|
|
4
|
|
|
|
|
|
|
use Kelp::Base; |
5
|
37
|
|
|
37
|
|
828
|
|
|
37
|
|
|
|
|
65
|
|
|
37
|
|
|
|
|
188
|
|
6
|
|
|
|
|
|
|
attr pattern => sub { die "pattern is required" }; |
7
|
|
|
|
|
|
|
attr via => undef; |
8
|
|
|
|
|
|
|
attr method => sub { $_[0]->via }; |
9
|
|
|
|
|
|
|
attr name => sub { $_[0]->pattern }; |
10
|
|
|
|
|
|
|
attr check => sub { {} }; |
11
|
|
|
|
|
|
|
attr defaults => sub { {} }; |
12
|
|
|
|
|
|
|
attr bridge => 0; |
13
|
|
|
|
|
|
|
attr regex => sub { $_[0]->_build_regex }; |
14
|
|
|
|
|
|
|
attr named => sub { {} }; |
15
|
|
|
|
|
|
|
attr param => sub { [] }; |
16
|
|
|
|
|
|
|
attr to => undef; |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
my $class = shift; |
20
|
|
|
|
|
|
|
my $self = $class->SUPER::new(@_); |
21
|
214
|
|
|
214
|
0
|
3376
|
$self->{_tokens} = []; |
22
|
214
|
|
|
|
|
608
|
$self->regex; # Compile the regex |
23
|
214
|
|
|
|
|
457
|
return $self; |
24
|
214
|
|
|
|
|
497
|
} |
25
|
214
|
|
|
|
|
597
|
|
26
|
|
|
|
|
|
|
my ( $self, $char, $switch, $token ) = @_; |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
push @{$self->{_tokens}}, $token; |
29
|
96
|
|
|
96
|
|
338
|
|
30
|
|
|
|
|
|
|
my ( $a, $b, $r ) = ( "(?<$token>", ')', undef ); |
31
|
96
|
|
|
|
|
145
|
for ($switch) { |
|
96
|
|
|
|
|
194
|
|
32
|
|
|
|
|
|
|
if ( $_ eq ':' || $_ eq '?' ) { |
33
|
96
|
|
|
|
|
235
|
$r = $a . ( $self->check->{$token} // '[^\/]+' ) . $b |
34
|
96
|
|
|
|
|
153
|
} |
35
|
96
|
100
|
100
|
|
|
245
|
if ( $_ eq '*' ) { |
36
|
92
|
|
100
|
|
|
203
|
$r = $a . '.+' . $b |
37
|
|
|
|
|
|
|
} |
38
|
96
|
100
|
|
|
|
245
|
} |
39
|
4
|
|
|
|
|
9
|
|
40
|
|
|
|
|
|
|
$char = $char . '?' if $char eq '/' && $switch eq '?'; |
41
|
|
|
|
|
|
|
$r .= '?' if $switch eq '?'; |
42
|
|
|
|
|
|
|
|
43
|
96
|
100
|
100
|
|
|
338
|
return $char . $r; |
44
|
96
|
100
|
|
|
|
160
|
} |
45
|
|
|
|
|
|
|
|
46
|
96
|
|
|
|
|
373
|
my $self = shift; |
47
|
|
|
|
|
|
|
return $self->pattern if ref $self->pattern eq 'Regexp'; |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
my $PAT = '(.?)([:*?])(\w+)'; |
50
|
214
|
|
|
214
|
|
282
|
my $pattern = $self->pattern; |
51
|
214
|
100
|
|
|
|
466
|
|
52
|
|
|
|
|
|
|
# Curly braces and brackets are only used for separation. |
53
|
210
|
|
|
|
|
350
|
# We replace all of them with \0, then convert the pattern |
54
|
210
|
|
|
|
|
342
|
# into a regular expression. This way if the regular expression |
55
|
|
|
|
|
|
|
# contains curlies, they won't be removed. |
56
|
|
|
|
|
|
|
$pattern =~ s/[{}]/\0/g; |
57
|
|
|
|
|
|
|
$pattern =~ s{$PAT}{$self->_rep_regex($1, $2, $3)}eg; |
58
|
|
|
|
|
|
|
$pattern =~ s/\0//g; |
59
|
|
|
|
|
|
|
$pattern .= '/?' unless $pattern =~ m{/$}; |
60
|
210
|
|
|
|
|
656
|
$pattern .= '$' unless $self->bridge; |
61
|
210
|
|
|
|
|
1551
|
|
|
96
|
|
|
|
|
233
|
|
62
|
210
|
|
|
|
|
434
|
return qr{^$pattern}; |
63
|
210
|
100
|
|
|
|
609
|
} |
64
|
210
|
100
|
|
|
|
474
|
|
65
|
|
|
|
|
|
|
my ( $self, $switch, $token, %args ) = @_; |
66
|
210
|
|
|
|
|
3603
|
my $rep = $args{$token} // $self->defaults->{$token} // ''; |
67
|
|
|
|
|
|
|
if ($switch ne '?' && !$rep) { |
68
|
|
|
|
|
|
|
return '{?' . $token . '}'; |
69
|
|
|
|
|
|
|
} |
70
|
65
|
|
|
65
|
|
210
|
my $check = $self->check->{$token}; |
71
|
65
|
|
100
|
|
|
174
|
if ( $check && $args{$token} !~ $check ) { |
|
|
|
100
|
|
|
|
|
72
|
65
|
100
|
100
|
|
|
179
|
return '{!' . $token . '}'; |
73
|
12
|
|
|
|
|
47
|
} |
74
|
|
|
|
|
|
|
return $rep; |
75
|
53
|
|
|
|
|
95
|
} |
76
|
53
|
100
|
100
|
|
|
139
|
|
77
|
2
|
|
|
|
|
12
|
my ( $self, %args ) = @_; |
78
|
|
|
|
|
|
|
|
79
|
51
|
|
|
|
|
155
|
my $pattern = $self->pattern; |
80
|
|
|
|
|
|
|
if ( ref $pattern eq 'Regexp' ) { |
81
|
|
|
|
|
|
|
carp "Can't build a path for regular expressions"; |
82
|
|
|
|
|
|
|
return; |
83
|
37
|
|
|
37
|
1
|
130
|
} |
84
|
|
|
|
|
|
|
|
85
|
37
|
|
|
|
|
79
|
my $PAT = '([:*?])(\w+)'; |
86
|
37
|
50
|
|
|
|
74
|
$pattern =~ s/{?$PAT}?/$self->_rep_build($1, $2, %args)/eg; |
87
|
0
|
|
|
|
|
0
|
if ($pattern =~ /{([!?])(\w+)}/) { |
88
|
0
|
|
|
|
|
0
|
carp $1 eq '!' |
89
|
|
|
|
|
|
|
? "Field $2 doesn't match checks" |
90
|
|
|
|
|
|
|
: "Default value for field $2 is missing"; |
91
|
37
|
|
|
|
|
58
|
return; |
92
|
37
|
|
|
|
|
290
|
} |
|
65
|
|
|
|
|
164
|
|
93
|
37
|
100
|
|
|
|
127
|
return $pattern; |
94
|
13
|
100
|
|
|
|
1366
|
} |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
my ( $self, $path, $method ) = @_; |
97
|
13
|
|
|
|
|
563
|
return 0 if ( $self->method && $self->method ne ( $method // '' ) ); |
98
|
|
|
|
|
|
|
return 0 unless my @matched = $path =~ $self->regex; |
99
|
24
|
|
|
|
|
110
|
|
100
|
|
|
|
|
|
|
@matched = () unless $#+; # were there any captures? see perlvar @+ |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
# Initialize the named parameters hash and its default values |
103
|
1206
|
|
|
1206
|
1
|
8620
|
my %named = map { $_ => $+{$_} } keys %+; |
104
|
1206
|
100
|
100
|
|
|
1871
|
for ( keys %{ $self->defaults } ) { |
|
|
|
100
|
|
|
|
|
105
|
1132
|
100
|
|
|
|
1885
|
$named{$_} = $self->defaults->{$_} unless exists $named{$_}; |
106
|
|
|
|
|
|
|
} |
107
|
282
|
100
|
|
|
|
844
|
$self->named( \%named ); |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
# Initialize the param array, containing the values of the |
110
|
282
|
|
|
8
|
|
1514
|
# named placeholders in the order they appear in the regex. |
|
187
|
|
|
|
|
1021
|
|
|
8
|
|
|
|
|
11187
|
|
|
8
|
|
|
|
|
2664
|
|
|
8
|
|
|
|
|
1494
|
|
111
|
282
|
|
|
|
|
454
|
if ( my @tokens = @{ $self->{_tokens} } ) { |
|
282
|
|
|
|
|
616
|
|
112
|
4
|
100
|
|
|
|
11
|
$self->param( [ map { $named{$_} } @tokens ] ); |
113
|
|
|
|
|
|
|
} |
114
|
282
|
|
|
|
|
783
|
else { |
115
|
|
|
|
|
|
|
$self->param( [ map { $_ eq '' ? undef : $_ } @matched] ); |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
|
118
|
282
|
100
|
|
|
|
359
|
return 1; |
|
282
|
|
|
|
|
719
|
|
119
|
116
|
|
|
|
|
181
|
} |
|
197
|
|
|
|
|
455
|
|
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
1; |
122
|
166
|
100
|
|
|
|
452
|
|
|
13
|
|
|
|
|
39
|
|
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
=head1 NAME |
125
|
282
|
|
|
|
|
1066
|
|
126
|
|
|
|
|
|
|
Kelp::Routes::Pattern - Route patterns for Kelp routes |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
=head1 SYNOPSIS |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
my $p = Kelp::Routes::Pattern->new( pattern => '/:name/:place' ); |
131
|
|
|
|
|
|
|
if ( $p->match('/james/london') ) { |
132
|
|
|
|
|
|
|
%named = %{ $p->named }; # ( name => 'james', place => 'london' ) |
133
|
|
|
|
|
|
|
@param = @{ $p->param }; # ( 'james', 'london' ) |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
=head1 DESCRIPTION |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
This module is needed by L<Kelp::Routes>. It provides matching for |
139
|
|
|
|
|
|
|
individual route patterns, returning the named placeholders in a hash and an |
140
|
|
|
|
|
|
|
array. |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
=head1 ATTRIBUTES |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
=head2 pattern |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
The pattern to match against. Each pattern is a string, which may contain named |
147
|
|
|
|
|
|
|
placeholders. For more information on the types and use of placeholders, look at |
148
|
|
|
|
|
|
|
L<Kelp::Routes/PLACEHOLDERS>. |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
my $p = Kelp::Routes::Patters->new( pattern => '/:id/*other' ); |
151
|
|
|
|
|
|
|
... |
152
|
|
|
|
|
|
|
$p->match('/4/something-else'); # True |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
=head2 method |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
Specifies an HTTP method to be matched by the route. |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
my $p = Kelp::Routes::Patters->new( |
159
|
|
|
|
|
|
|
pattern => '/:id/*other', |
160
|
|
|
|
|
|
|
method => 'PUT' |
161
|
|
|
|
|
|
|
); |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
$p->match('/4/something-else', 'GET'); # False. Only PUT allowed. |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
=head2 name |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
You are encouraged to give each route a name, so you can look it up later when |
168
|
|
|
|
|
|
|
you build a URL for it. |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
my $p = Kelp::Routes::Patters->new( |
171
|
|
|
|
|
|
|
pattern => '/:id/*other', |
172
|
|
|
|
|
|
|
name => 'other_id' |
173
|
|
|
|
|
|
|
); |
174
|
|
|
|
|
|
|
... |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
say $p->build( 'other_id', id => '100', other => 'something-else' ); |
177
|
|
|
|
|
|
|
# Prints '/100/something-else' |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
If no name is provided for the route, the C<pattern> is used. |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
=head2 check |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
A hashref with placeholder names as keys and regular expressions as values. It |
184
|
|
|
|
|
|
|
is used to match the values of the placeholders against the provided regular |
185
|
|
|
|
|
|
|
expressions. |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
my $p = Kelp::Routes::Patters->new( |
188
|
|
|
|
|
|
|
pattern => '/:id/*other', |
189
|
|
|
|
|
|
|
check => { id => qr/\d+/ } # id may only be a didgit |
190
|
|
|
|
|
|
|
); |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
$p->match('/4/other'); # True |
193
|
|
|
|
|
|
|
$p->match('/q/other'); # False |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
Note: Do not add C<^> at the beginning or C<$> at the end of the regular |
196
|
|
|
|
|
|
|
expressions, because they are merged into a bigger regex. |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
=head2 defaults |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
A hashref with placeholder defaults. This only applies to optional placeholders, |
201
|
|
|
|
|
|
|
or those prefixed with a question mark. If a default value is provided for any |
202
|
|
|
|
|
|
|
of them, it will be used in case the placeholder value is missing. |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
my $p = Kelp::Routes::Patters->new( |
205
|
|
|
|
|
|
|
pattern => '/:id/?other', |
206
|
|
|
|
|
|
|
defaults => { other => 'info' } |
207
|
|
|
|
|
|
|
); |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
$p->match('/100'); |
210
|
|
|
|
|
|
|
# $p->named will contain { id => 100, other => 'info' } |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
$p->match('/100/delete'); |
213
|
|
|
|
|
|
|
# $p->named will contain { id => 100, other => 'delete' } |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
=head2 bridge |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
A True/False value. Specifies if the route is a bridge. For more information |
218
|
|
|
|
|
|
|
about bridges, please see L<Kelp::Routes/BRIDGES> |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
=head2 regex |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
We recommend that you stick to using patterns, because they are simpler and |
223
|
|
|
|
|
|
|
easier to read, but if you need to match a really complicated route, then |
224
|
|
|
|
|
|
|
you can use a regular expression. |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
my $p = Kelp::Routes::Patters->new( regex => qr{^(\d+)/(\d+)$} ); |
227
|
|
|
|
|
|
|
$p->match('/100/200'); # True. $p->param will be [ 100, 200 ] |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
After matching, the L</param> array will be initialized with the values of the |
230
|
|
|
|
|
|
|
captures in the order they appear in the regex. |
231
|
|
|
|
|
|
|
If you used a regex with named captures, then a hashref L</named> will also be |
232
|
|
|
|
|
|
|
initialized with the names and values of the named placeholders. In other words, |
233
|
|
|
|
|
|
|
this hash will be a permanent copy of the C<%+> built-in hash. |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
my $p = Kelp::Routes::Patters->new( regex => qr{^(?<id>\d+)/(?<line>\d+)$} ); |
236
|
|
|
|
|
|
|
$p->match('/100/200'); # True. |
237
|
|
|
|
|
|
|
# $p->param will be [ 100, 200 ] |
238
|
|
|
|
|
|
|
# $p->named will be { id => 100, line => 200 } |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
If C<regex> is not explicitly given a value it will be built from the |
241
|
|
|
|
|
|
|
C<pattern>. |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
=head2 named |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
A hashref which will be initialized by the L</match> function. After matching, |
246
|
|
|
|
|
|
|
it will contain placeholder names and values for the matched route. |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
=head2 param |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
An arrayref, which will be initialized by the L</match> function. After matching, |
251
|
|
|
|
|
|
|
it will contain all placeholder values in the order they were specified in the |
252
|
|
|
|
|
|
|
pattern. |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
=head2 to |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
Specifies the route destination. See examples in L<Kelp::Routes>. |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
=head1 METHODS |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
=head2 match |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
C<match( $path, $method )> |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
Matches an already initialized route against a path and http method. If the match |
265
|
|
|
|
|
|
|
was successful, this sub will return a true value and the L</named> and L</param> |
266
|
|
|
|
|
|
|
attributes will be initialized with the names and values of the matched placeholders. |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
=head2 build |
269
|
|
|
|
|
|
|
C<build( %args )> |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
Builds a URL from a pattern. |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
my $p = Kelp::Routes::Patters->new( pattern => '/:id/:line/:row' ); |
274
|
|
|
|
|
|
|
$p->build( id => 100, line => 5, row => 8 ); # Returns '/100/5/8' |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
=head1 ACKNOWLEDGEMENTS |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
This module was inspired by L<Routes::Tiny>. |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
The concept of bridges was borrowed from L<Mojolicious> |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
=cut |