File Coverage

blib/lib/Dancer2/Core/Route.pm
Criterion Covered Total %
statement 129 130 99.2
branch 69 76 90.7
condition 7 8 87.5
subroutine 17 17 100.0
pod 2 4 50.0
total 224 235 95.3


line stmt bran cond sub pod time code
1             package Dancer2::Core::Route;
2             # ABSTRACT: Dancer2's route handler
3             $Dancer2::Core::Route::VERSION = '1.0.0';
4 147     147   146943 use Moo;
  147         13399  
  147         1114  
5 147     147   57934 use Dancer2::Core::Types;
  147         421  
  147         1078  
6 147     147   1694212 use Module::Runtime 'use_module';
  147         3827  
  147         1180  
7 147     147   7970 use Carp 'croak';
  147         406  
  147         8915  
8 147     147   1163 use List::Util 'first';
  147         462  
  147         9724  
9 147     147   1062 use Scalar::Util 'blessed';
  147         384  
  147         7148  
10 147     147   2078 use Ref::Util qw< is_regexpref >;
  147         1618  
  147         7015  
11 147     147   74183 use Type::Registry;
  147         1269300  
  147         1338  
12              
13             our ( $REQUEST, $RESPONSE, $RESPONDER, $WRITER, $ERROR_HANDLER );
14              
15             has method => (
16             is => 'ro',
17             isa => Dancer2Method,
18             required => 1,
19             );
20              
21             has code => (
22             is => 'ro',
23             required => 1,
24             isa => CodeRef,
25             );
26              
27             has regexp => (
28             is => 'ro',
29             required => 1,
30             );
31              
32             has spec_route => ( is => 'ro' );
33              
34             has prefix => (
35             is => 'ro',
36             isa => Maybe [Dancer2Prefix],
37             predicate => 1,
38             );
39              
40             has options => (
41             is => 'ro',
42             isa => HashRef,
43             trigger => \&_check_options,
44             predicate => 1,
45             );
46              
47             sub _check_options {
48 594     594   76973 my ( $self, $options ) = @_;
49 594 50       2022 return 1 unless defined $options;
50              
51 594         1925 my @supported_options = (
52             qw/content_type agent user_agent content_length
53             path_info/
54             );
55 594         1369 for my $opt ( keys %{$options} ) {
  594         1968  
56             croak "Not a valid option for route matching: `$opt'"
57 3 50       6 if not( grep {/^$opt$/} @supported_options );
  15         79  
58             }
59 594         12578 return 1;
60             }
61              
62             # private attributes
63              
64             has _should_capture => (
65             is => 'ro',
66             isa => Bool,
67             );
68              
69             has _match_data => (
70             is => 'rw',
71             isa => HashRef,
72             );
73              
74             has _params => (
75             is => 'ro',
76             isa => ArrayRef,
77             default => sub { [] },
78             );
79              
80             has _typed_params => (
81             is => 'ro',
82             isa => ArrayRef,
83             default => sub { [] },
84             );
85              
86             sub match {
87 1343     1343 1 23497 my ( $self, $request ) = @_;
88              
89 1343 100       4509 if ( $self->has_options ) {
90 1093 100       2803 return unless $self->validate_options($request);
91             }
92              
93 1340         4185 my @values = $request->path =~ $self->regexp;
94              
95 1340 100       27537 return unless @values;
96              
97             # if some named captures are found, return captures
98             # - Note no @values implies no named captures
99 147 100   147   151405 if (my %captures = %+ ) {
  147         65238  
  147         210632  
  592         5792  
100 2         48 return $self->_match_data( { captures => \%captures } );
101             }
102              
103             # regex comments are how we know if we captured a token,
104             # splat or a megasplat
105 590         2871 my @token_or_splat =
106             $self->regexp =~ /\(\?#((?:typed_)?token|(?:mega)?splat)\)/g;
107              
108 590 100       1752 if (@token_or_splat) {
109             # our named tokens
110 86         184 my @tokens = @{ $self->_params };
  86         420  
111 86         216 my @typed_tokens = @{ $self->_typed_params };
  86         319  
112              
113 86         201 my %params;
114             my @splat;
115 86         349 for ( my $i = 0; $i < @values; $i++ ) {
116             # Is this value from a token?
117 107 100       354 if ( defined $token_or_splat[$i] ) {
118 106 100       337 if ( $token_or_splat[$i] eq 'typed_token' ) {
119 13         22 my ( $token, $type ) = @{ shift @typed_tokens };
  13         32  
120              
121 13 100       32 if (defined $values[$i]) {
122             # undef value mean that token was marked as optional so
123             # we only do type check on defined value
124             return
125 11 100       43 unless $type->check($values[$i]);
126             }
127 10         1397 $params{$token} = $values[$i];
128 10         35 next;
129             }
130 93 100       284 if ( $token_or_splat[$i] eq 'token' ) {
131 29         111 $params{ shift @tokens } = $values[$i];
132 29         110 next;
133             }
134              
135             # megasplat values are split on '/'
136 64 100       226 if ($token_or_splat[$i] eq 'megasplat') {
137 25 100       192 $values[$i] = [
138             defined $values[$i] ? split( m{/} , $values[$i], -1 ) : ()
139             ];
140             }
141             }
142 65         250 push @splat, $values[$i];
143             }
144 83         2149 return $self->_match_data( {
145             %params,
146             (splat => \@splat)x!! @splat,
147             });
148             }
149              
150 504 100       2023 if ( $self->_should_capture ) {
151 3         77 return $self->_match_data( { splat => \@values } );
152             }
153              
154 501         10654 return $self->_match_data( {} );
155             }
156              
157             sub execute {
158 565     565 1 1800 my ( $self, $app, @args ) = @_;
159 565         1699 local $REQUEST = $app->request;
160 565         9400 local $RESPONSE = $app->response;
161              
162 565         7616 my $content = $self->code->( $app, @args );
163              
164             # users may set content in the response. If the response has
165             # content, and the returned value from the route code is not
166             # an object (well, reference) we ignore the returned value
167             # and use the existing content in the response instead.
168 454 100 66     54568 $RESPONSE->has_content && !ref $content
169             and return $app->_prep_response( $RESPONSE );
170              
171 453 100       4487 my $type = blessed($content)
172             or return $app->_prep_response( $RESPONSE, $content );
173              
174             # Plack::Response: proper ArrayRef-style response
175 1 50       7 $type eq 'Plack::Response'
176             and $RESPONSE = Dancer2::Core::Response->new_from_plack($RESPONSE);
177              
178             # CodeRef: raw PSGI response
179             # do we want to allow it and forward it back?
180             # do we want to upgrade it to an asynchronous response?
181 1 50       4 $type eq 'CODE'
182             and die "We do not support returning code references from routes.\n";
183              
184             # Dancer2::Core::Response, Dancer2::Core::Response::Delayed:
185             # proper responses
186 1 50       4 $type eq 'Dancer2::Core::Response'
187             and return $RESPONSE;
188              
189 1 50       6 $type eq 'Dancer2::Core::Response::Delayed'
190             and return $content;
191              
192             # we can't handle arrayref or hashref
193             # because those might be serialized back
194 0         0 die "Unrecognized response type from route: $type.\n";
195             }
196              
197             # private subs
198              
199             sub BUILDARGS {
200 668     668 0 707604 my ( $class, %args ) = @_;
201              
202 668         1790 my $prefix = $args{prefix};
203 668         1442 my $regexp = $args{regexp};
204              
205 668         1562 my $type_library = delete $args{type_library};
206 668 100       1998 if ( $type_library) {
207 3 50       10 eval { use_module($type_library); 1 }
  3         63  
  3         60151  
208             or croak "type_library $type_library cannot be loaded";
209             }
210 668   100     3632 $type_library ||= 'Dancer2::Core::Types';
211              
212             # init prefix
213 668 100       2735 if ( $prefix ) {
    100          
214             $args{regexp} =
215 34 100       191 is_regexpref($regexp) ? qr{^\Q${prefix}\E${regexp}$} :
216             $prefix . $regexp;
217             }
218             elsif ( !is_regexpref($regexp) ) {
219             # No prefix, so ensure regexp begins with a '/'
220 627 100       2455 index( $regexp, '/', 0 ) == 0 or $args{regexp} = "/$regexp";
221             }
222              
223             # init regexp
224 668         1323 $regexp = $args{regexp}; # updated value
225 668         1442 $args{spec_route} = $regexp;
226              
227 668 100       1740 if ( is_regexpref($regexp)) {
228 8         18 $args{_should_capture} = 1;
229             }
230             else {
231             @args{qw/ regexp _params _typed_params _should_capture/} =
232 660         1037 @{ _build_regexp_from_string($regexp, $type_library) };
  660         1747  
233             }
234              
235 665         17566 return \%args;
236             }
237              
238             sub _build_regexp_from_string {
239 660     660   1528 my ($string, $type_library) = @_;
240              
241 660         1153 my $capture = 0;
242 660         1142 my ( @params, @typed_params );
243              
244 660         2914 my $type_registry = Type::Registry->new;
245 660         7149 $type_registry->add_types($type_library);
246              
247             # look for route with tokens [aka params] (/hello/:foo)
248 660 100       7626670 if ( $string =~ /:/ ) {
249 53         505 my @found = $string =~ m|:([^/.\?]+)|g;
250 53         156 foreach my $token ( @found ) {
251 59 100       271 if ( $token =~ s/\[(.+)\]$// ) {
252              
253             # typed token
254 15         62 my $type = $type_registry->lookup($1);
255 14         6498 push @typed_params, [ $token, $type ];
256             }
257             else {
258 44         145 push @params, $token;
259             }
260             }
261 52 100       173 if (@typed_params) {
262 13         72 $string =~ s!(:[^/.\?]+\[[^/.\?]+\])!(?#typed_token)([^/]+)!g;
263 13         27 $capture = 1;
264             }
265 52 100       158 if (@params) {
266 44     44   333 first { $_ eq 'splat' } @params
267 40 100       440 and croak q{Named placeholder 'splat' is deprecated};
268              
269 43     43   269 first { $_ eq 'captures' } @params
270 39 100       248 and croak q{Named placeholder 'captures' is deprecated};
271              
272 38         241 $string =~ s!(:[^\/\.\?]+)!(?#token)([^/]+)!g;
273 38         114 $capture = 1;
274             }
275             }
276              
277             # parse megasplat
278             # we use {0,} instead of '*' not to fall in the splat rule
279             # same logic for [^\n] instead of '.'
280 657 100       2678 $capture = 1 if $string =~ s!\Q**\E!(?#megasplat)([^\n]+)!g;
281              
282             # parse wildcards
283 657 100       1993 $capture = 1 if $string =~ s!\*!(?#splat)([^/]+)!g;
284              
285             # escape dots
286 657 100       1960 $string =~ s/\./\\\./g if $string =~ /\./;
287              
288             # escape slashes
289 657         2651 $string =~ s/\//\\\//g;
290              
291 657         8803 return [ "^$string\$", \@params, \@typed_params, $capture ];
292             }
293              
294             sub validate_options {
295 1093     1093 0 2086 my ( $self, $request ) = @_;
296              
297 1093         1674 for my $option ( keys %{ $self->options } ) {
  1093         3496  
298             return 0
299             if (
300             ( not $request->$option )
301 4 100 100     23 || ( $request->$option !~ $self->options->{ $option } )
302             )
303             }
304 1090         2773 return 1;
305             }
306              
307             1;
308              
309             __END__
310              
311             =pod
312              
313             =encoding UTF-8
314              
315             =head1 NAME
316              
317             Dancer2::Core::Route - Dancer2's route handler
318              
319             =head1 VERSION
320              
321             version 1.0.0
322              
323             =head1 ATTRIBUTES
324              
325             =head2 method
326              
327             The HTTP method of the route (lowercase). Required.
328              
329             =head2 code
330              
331             The code reference to execute when the route is ran. Required.
332              
333             =head2 regexp
334              
335             The regular expression that defines the path of the route.
336             Required. Coerce from Dancer2's route I<patterns>.
337              
338             =head2 prefix
339              
340             The prefix to prepend to the C<regexp>. Optional.
341              
342             =head2 options
343              
344             A HashRef of conditions on which the matching will depend. Optional.
345              
346             =head1 METHODS
347              
348             =head2 match
349              
350             Try to match the route with a given L<Dancer2::Core::Request> object.
351             Returns the hash of matching data if success (captures and values of the route
352             against the path of the request) or C<undef> if not.
353              
354             my $match = $route->match( $request );
355              
356             =head2 execute
357              
358             Runs the coderef of the route.
359              
360             =head1 AUTHOR
361              
362             Dancer Core Developers
363              
364             =head1 COPYRIGHT AND LICENSE
365              
366             This software is copyright (c) 2023 by Alexis Sukrieh.
367              
368             This is free software; you can redistribute it and/or modify it under
369             the same terms as the Perl 5 programming language system itself.
370              
371             =cut