File Coverage

blib/lib/MVC/Neaf/Route.pm
Criterion Covered Total %
statement 99 99 100.0
branch 40 50 80.0
condition 21 26 80.7
subroutine 17 17 100.0
pod 8 8 100.0
total 185 200 92.5


line stmt bran cond sub pod time code
1             package MVC::Neaf::Route;
2              
3 94     94   47930 use strict;
  94         252  
  94         2832  
4 94     94   485 use warnings;
  94         210  
  94         4165  
5              
6             our $VERSION = '0.29';
7              
8             =head1 NAME
9              
10             MVC::Neaf::Route - Route (path+method) class for Not Even A Framework
11              
12             =head1 DESCRIPTION
13              
14             This module contains information about a handler defined using
15             L: method, path, handling code, connected hooks, default values etc.
16              
17             It is useless in and off itself.
18              
19             =head1 METHODS
20              
21             =cut
22              
23 94     94   596 use Carp;
  94         247  
  94         5803  
24 94     94   645 use Encode;
  94         226  
  94         7634  
25 94     94   5907 use Module::Load;
  94         11840  
  94         1993  
26 94     94   5742 use Scalar::Util qw( looks_like_number blessed );
  94         207  
  94         5515  
27 94     94   610 use URI::Escape qw( uri_unescape );
  94         192  
  94         4912  
28              
29 94     94   629 use parent qw(MVC::Neaf::Util::Base);
  94         236  
  94         799  
30 94     94   34604 use MVC::Neaf::Util qw( canonize_path path_prefixes run_all run_all_nodie http_date make_getters );
  94         252  
  94         130394  
31              
32             our @CARP_NOT = qw(MVC::Neaf MVC::Neaf::Request);
33              
34             =head2 new
35              
36             Route has the following read-only attributes:
37              
38             =over
39              
40             =item * parent (required)
41              
42             =item * path (required)
43              
44             =item * method (required)
45              
46             =item * code (required)
47              
48             =item * default
49              
50             =item * cache_ttl
51              
52             =item * path_info_regex
53              
54             =item * param_regex
55              
56             =item * description
57              
58             =item * public
59              
60             =item * caller
61              
62             =item * where
63              
64             =item * tentative
65              
66             =item * override TODO
67              
68             =item * hooks
69              
70             =item * helpers
71              
72             =back
73              
74             =cut
75              
76             # Should just Moo here but we already have a BIG dependency footprint
77             my @ESSENTIAL = qw( parent method path code );
78             my @OPTIONAL = qw(
79             param_regex path_info_regex strict
80             default helpers hooks
81             caller description public where
82             override tentative
83             cache_ttl
84             );
85             my %RO_FIELDS;
86             $RO_FIELDS{$_}++ for @ESSENTIAL, @OPTIONAL;
87             my $year = 365 * 24 * 60 * 60;
88              
89             sub new {
90 288     288 1 8561 my ($class, %opt) = @_;
91              
92             # kill generated fields
93 288         1039 delete $opt{$_} for qw( lock );
94              
95 288         709 my @missing = grep { !defined $opt{$_} } @ESSENTIAL;
  1152         2550  
96 288         1071 my @extra = grep { !$RO_FIELDS{$_} } keys %opt;
  2573         4428  
97              
98 288 100       1009 $class->my_croak( "Required fields missing: @missing; unknown fields present: @extra" )
99             if @extra + @missing;
100              
101             # Canonize args
102 287         818 $opt{method} = uc $opt{method};
103 287   100     788 $opt{default} ||= {};
104 287         858 $opt{path} = canonize_path($opt{path});
105 287 100       843 $opt{public} = $opt{public} ? 1 : 0;
106              
107             # Check args
108             $class->my_croak("'code' must be a subroutine, not ".(ref $opt{code}||'scalar'))
109 287 100 50     1119 unless UNIVERSAL::isa($opt{code}, 'CODE');
110             $class->my_croak("'public' endpoint must have a 'description'")
111 286 100 100     856 if $opt{public} and not $opt{description};
112             $class->my_croak( "'default' must be unblessed hash" )
113 285 50       890 if ref $opt{default} ne 'HASH';
114             $class->my_croak("'method' must be a plain scalar")
115 285 100       1392 unless $opt{method} =~ /^[A-Z0-9_]+$/;
116              
117             # Always have regex defined to simplify routing
118 284 100       1158 if (!UNIVERSAL::isa($opt{path_info_regex}, 'Regexp')) {
119             $opt{path_info_regex} = (defined $opt{path_info_regex})
120 4 50       26 ? qr#^$opt{path_info_regex}$#
121             : qr#^$#;
122             };
123              
124             # Just for information
125 284   100     759 $opt{caller} ||= [caller(0)]; # save file,line
126 284   66     1746 $opt{where} ||= "at $opt{caller}[1] line $opt{caller}[2]";
127              
128             # preprocess regular expression for params
129 284 100       812 if ( my $reg = $opt{param_regex} ) {
130 15         23 my %real_reg;
131             $class->my_croak("'param_regex' must be a hash of regular expressions")
132 15 100 100     92 if ref $reg ne 'HASH' or grep { !defined $reg->{$_} } keys %$reg;
  10         50  
133             $real_reg{$_} = qr(^$reg->{$_}$)s
134 12         247 for keys %$reg;
135 12         43 $opt{param_regex} = \%real_reg;
136             };
137              
138 281 100       664 if ( $opt{cache_ttl} ) {
139             $class->my_croak("'cache_ttl' must be a number")
140 5 100       25 unless looks_like_number($opt{cache_ttl});
141             # as required by RFC
142 4 50       8 $opt{cache_ttl} = -100000 if $opt{cache_ttl} < 0;
143 4 50       11 $opt{cache_ttl} = $year if $opt{cache_ttl} > $year;
144             };
145              
146 280         1730 return bless \%opt, $class;
147             };
148              
149             =head2 clone
150              
151             Create a copy of existing route, possibly overriding some of the fields.
152              
153             =cut
154              
155             # TODO 0.30 -> Util::Base?
156             sub clone {
157 134     134 1 559 my ($self, %override) = @_;
158              
159 134         907 return (ref $self)->new( %$self, %override );
160             };
161              
162             =head2 lock()
163              
164             Prohibit any further modifications to this route.
165              
166             =cut
167              
168             sub lock {
169 201     201 1 381 my $self = shift;
170 201         452 $self->{lock}++;
171 201         382 return $self;
172             };
173              
174             =head2 is_locked
175              
176             Check that route is locked.
177              
178             =cut
179              
180             # TODO 0.40 a version with croak
181             sub is_locked {
182 249     249 1 454 my $self = shift;
183 249         914 return !!$self->{lock};
184             };
185              
186             =head2 add_form()
187              
188             add_form( name => $validator )
189              
190             Create a named form for future query data validation
191             via C<$request-Eform("name")>.
192             See L.
193              
194             The C<$validator> is one of:
195              
196             =over
197              
198             =item * An object with C method accepting one C<\%hashref>
199             argument (the raw form data).
200              
201             =item * A CODEREF accepting the same argument.
202              
203             =back
204              
205             Whatever is returned by validator is forwarded into the controller.
206              
207             Neaf comes with a set of predefined validator classes that return
208             a convenient object that contains collected valid data, errors (if any),
209             and an is_valid flag.
210              
211             The C parameter of the functional form has predefined values
212             C (the default), C, and C (all case-insensitive)
213             pointing towards L, L,
214             and L, respectively.
215              
216             You are encouraged to use C
217             (See L and L)
218             for anything except super-basic regex checks.
219              
220             If an arbitrary class name is given instead, C will be called
221             on that class with \%spec ref as first parameter.
222              
223             Consider the following script:
224              
225             use MVC::Neaf;
226             neaf form => my => { foo => '\d+', bar => '[yn]' };
227             get '/check' => sub {
228             my $req = shift;
229             my $in = $req->form("my");
230             return $in->is_valid ? { ok => $in->data } : { error => $in->error };
231             };
232             neaf->run
233              
234             And by running this one gets
235              
236             bash$ curl http://localhost:5000/check?bar=xxx
237             {"error":{"bar":"BAD_FORMAT"}}
238             bash$ curl http://localhost:5000/check?bar=y
239             {"ok":{"bar":"y"}}
240             bash$ curl http://localhost:5000/check?bar=yy
241             {"error":{"bar":"BAD_FORMAT"}}
242             bash$ curl http://localhost:5000/check?foo=137\&bar=n
243             {"ok":{"bar":"n","foo":"137"}}
244             bash$ curl http://localhost:5000/check?foo=leet
245             {"error":{"foo":"BAD_FORMAT"}}
246              
247             =cut
248              
249             my %FORM_ENGINE = (
250             neaf => 'MVC::Neaf::X::Form',
251             livr => 'MVC::Neaf::X::Form::LIRV',
252             wildcard => 'MVC::Neaf::X::Form::Wildcard',
253             );
254              
255             sub add_form {
256 2     2 1 10 my ($self, $name, $spec, %opt) = @_;
257             # TODO 0.30 Make path-based?
258              
259 2 50 33     14 $name and $spec
260             or $self->my_croak( "Form name and spec must be nonempty" );
261 2 50       18 exists $self->{forms}{$name}
262             and $self->my_croak( "Form $name redefined" );
263              
264 2 50       25 if (!blessed $spec) {
265 2   100     13 my $eng = delete $opt{engine} || 'MVC::Neaf::X::Form';
266 2   66     13 $eng = $FORM_ENGINE{ lc $eng } || $eng;
267              
268 2 50       17 if (!$eng->can("new")) {
269 2 50       6 eval { load $eng; 1 }
  2         13  
  2         34  
270             or $self->my_croak( "Failed to load form engine $eng: $@" );
271             };
272              
273 2         20 $spec = $eng->new( $spec, %opt );
274             };
275              
276 2         9 $self->{forms}{$name} = $spec;
277 2         13 return $self;
278             };
279              
280             =head2 get_form()
281              
282             $neaf->get_form( "name" )
283              
284             Fetch form named "name" previously added via add_form to
285             this route or one of its parent routes.
286              
287             See L.
288             See also L.
289              
290             =cut
291              
292             sub get_form {
293 6     6 1 30 my ($self, $name) = @_;
294              
295             # Aggressive caching for the win
296 6   100     45 return $self->{forms}{$name} ||= do {
297 3         11 my $parent = $self->parent;
298 3 100       26 croak("Failed to locate form '$name'")
299             unless $parent;
300 2         37 $parent->get_form($name);
301             };
302             };
303              
304             # TODO 0.40 get_view should be per-route, not global
305              
306             =head2 post_setup
307              
308             Calculate hooks and path-based defaults.
309              
310             Locks route, dies if already locked.
311              
312             =cut
313              
314             sub post_setup {
315 201     201 1 418 my $self = shift;
316              
317             # LOCK PROFILE
318 201 50       645 confess "Attempt to repeat route setup. MVC::Neaf broken, please file a bug"
319             if $self->is_locked;
320              
321 201         962 my $neaf = $self->parent;
322             # CALCULATE DEFAULTS
323             # merge data sources, longer paths first
324 201         732 $self->{default} = $neaf->get_path_defaults ( $self->method, $self->path, $self->{default} );
325 201         756 $self->{hooks} = $neaf->get_hooks ( $self->method, $self->path );
326 201         663 $self->{helpers} = $neaf->get_helpers ( $self->method, $self->path );
327              
328 201         827 $self->lock;
329              
330 201         437 return;
331             };
332              
333             =head2 INTERNAL LOGIC
334              
335             The following methods are part of NEAF's core and should not be called
336             unless you want something I special.
337              
338             =head2 dispatch_logic
339              
340             dispatch_logic( $req, $stem, $suffix )
341              
342             May die. May spoil request.
343              
344             Apply controller code to given request object, path stem, and path suffix.
345              
346             Upon success, return a Neaf response hash (see L).
347              
348             =cut
349              
350             sub dispatch_logic {
351 143     143 1 536 my ($self, $req, $stem, $suffix) = @_;
352              
353             $self->post_setup
354 143 100       656 unless $self->{lock};
355              
356             # TODO 0.90 optimize this or do smth. Still MUST keep route_re a prefix tree
357 143 100       547 if ($suffix =~ /%/) {
358 6         22 $suffix = decode_utf8( uri_unescape( $suffix ) );
359             };
360 143 100       769 my @split = $suffix =~ $self->path_info_regex
361             or die "404\n";
362 136         777 $req->_import_route( $self, $stem, $suffix, \@split );
363              
364             # execute hooks
365             run_all( $self->{hooks}{pre_logic}, $req)
366 136 100       513 if exists $self->{hooks}{pre_logic};
367              
368             # Run the controller!
369 135         530 my $reply = $self->code->($req);
370             # TODO cannot write to request until hash type-checked
371             # $req->_set_reply( $reply );
372 114         878 $reply;
373             };
374              
375             # Setup getters
376             make_getters( %RO_FIELDS );
377              
378             =head1 LICENSE AND COPYRIGHT
379              
380             This module is part of L suite.
381              
382             Copyright 2016-2023 Konstantin S. Uvarin C.
383              
384             This program is free software; you can redistribute it and/or modify it
385             under the terms of either: the GNU General Public License as published
386             by the Free Software Foundation; or the Artistic License.
387              
388             See L for more information.
389              
390             =cut
391              
392             1;