File Coverage

blib/lib/MVC/Neaf/Route/Main.pm
Criterion Covered Total %
statement 511 517 98.8
branch 207 234 88.4
condition 82 116 70.6
subroutine 60 61 98.3
pod 28 28 100.0
total 888 956 92.8


line stmt bran cond sub pod time code
1             package MVC::Neaf::Route::Main;
2              
3 81     81   52550 use strict;
  81         186  
  81         2348  
4 81     81   391 use warnings;
  81         163  
  81         3385  
5             our $VERSION = '0.29';
6              
7             =head1 NAME
8              
9             MVC::Neaf::Route::Main - main application class for Not Even A Framework.
10              
11             =head1 DESCRIPTION
12              
13             This class contains a L application structure
14             and implements the core of Neaf logic.
15              
16             It is a L object itself,
17             containing a hash of other routes designated by their path prefixes.
18              
19             =head1 APPLICATION SETUP METHODS
20              
21             =cut
22              
23 81     81   486 use Carp;
  81         181  
  81         4793  
24 81     81   564 use Cwd qw(cwd abs_path);
  81         218  
  81         4504  
25 81     81   44919 use Encode;
  81         1190690  
  81         6802  
26 81     81   685 use File::Basename qw(dirname);
  81         241  
  81         8374  
27 81     81   41186 use Module::Load;
  81         90457  
  81         576  
28 81     81   5586 use Scalar::Util qw( blessed looks_like_number reftype );
  81         188  
  81         4810  
29 81     81   36275 use URI::Escape;
  81         120699  
  81         5141  
30              
31 81     81   592 use parent qw(MVC::Neaf::Route);
  81         179  
  81         486  
32 81     81   42026 use MVC::Neaf::Request::PSGI;
  81         302  
  81         3201  
33 81     81   577 use MVC::Neaf::Route::PreRoute;
  81         181  
  81         2739  
34 81         8389 use MVC::Neaf::Util qw(
35             caller_info
36             canonize_path
37             check_path
38             data_fh
39             decode_b64
40             encode_b64
41             extra_missing
42             http_date
43             maybe_list
44             run_all
45             run_all_nodie
46             supported_methods
47 81     81   424 );
  81         187  
48 81     81   38750 use MVC::Neaf::Util::Container;
  81         238  
  81         230274  
49              
50             # TODO 0.30 remove
51             sub _one_and_true {
52 879     879   1467 my $self = shift;
53 879 100       2953 return $self if ref $self;
54              
55 2         8 my $method = [caller 1]->[3];
56 2         93 $method =~ s/.*:://;
57              
58 2 100       11 if ($self eq 'MVC::Neaf') {
59 1         7 require MVC::Neaf;
60 1         20 carp "MVC::Neaf->$method() call is DEPRECATED, use neaf->$method or MVC::Neaf->new()";
61 1         829 return MVC::Neaf::neaf();
62             };
63              
64 1         14 croak "Method $method called on unblessed '$self'";
65             };
66              
67             =head2 new()
68              
69             new( )
70              
71             This is also called by Cnew>,
72             in case one wants to instantiate a Neaf application object
73             instead of using the default L.
74              
75             A hash of %options may be added in the future, but isn't supported currently.
76              
77             =cut
78              
79             sub new {
80 96     96 1 12334 my ($class, %opt) = @_;
81              
82 96 100       474 croak('MVC::Neaf->new: no options currently supported: '.join ", ", sort keys %opt)
83             if %opt;
84              
85 95         304 my $self = bless {}, $class;
86              
87 95         1013 $self->set_path_defaults( { -status => 200, -view => 'JS' } );
88              
89             # This is required for $self->hooks to produce something.
90             # See also todo_hooks where the real hooks sit.
91 95         258 $self->{hooks} = {};
92              
93             # magical by default
94 95         307 $self->{magic} = 1;
95              
96 95         358 return $self;
97             };
98              
99             =head2 add_route()
100              
101             Define a handler for given by URI path and HTTP method(s).
102             This is the backend behind NEAF's C route specifications.
103              
104             route( '/path' => CODEREF, %options )
105              
106             Any incoming request to uri matching C
107             (C too, but NOT C)
108             will now be directed to CODEREF.
109              
110             Longer paths are GUARANTEED to be checked first.
111              
112             Dies if the same method and path combination is given twice
113             (but see C and C below).
114             Multiple methods may be given for the same path.
115              
116             Exactly one leading slash will be prepended no matter what you do.
117             (C, C and C are all the same).
118              
119             The C MUST accept exactly one argument,
120             referred to as C<$request> or C<$req> hereafter,
121             and return an unblessed hashref with response data.
122              
123             %options may include:
124              
125             =over
126              
127             =item * C - list of allowed HTTP methods.
128             Default is [GET, POST].
129             Multiple handles can be defined for the same path, provided that
130             methods do not intersect.
131             HEAD method is automatically handled if GET is present, however,
132             one MAY define a separate HEAD handler explicitly.
133              
134             =item * C => C - allow URI subpaths
135             to be handled by this handler.
136              
137             A 404 error will be generated unless C is present
138             and PATH_INFO matches the regex (without the leading slashes).
139              
140             If path_info_regex matches, it will be available in the controller
141             as C<$req-Epath_info>.
142              
143             If capture groups are present in said regular expression,
144             their content will also be available as C<$req-Epath_info_split>.
145              
146             B<[EXPERIMENTAL]> Name and semantics MAY change in the future.
147              
148             =item * C => { name => C, name2 => C<'\d+'> }
149              
150             Add predefined regular expression validation to certain request parameters,
151             so that they can be queried by name only.
152             See C in L.
153              
154             B<[EXPERIMENTAL]> Name and semantics MAY change in the future.
155              
156             =item * strict => 1|0
157              
158             If true, request's C and C
159             will emit HTTP error 422
160             whenever mandatory validation fails.
161              
162             If parameter or cookie is missing, just return default.
163             This MAY change in the future.
164              
165             B<[EXPERIMENTAL]> Name and meaning MAY change in the future.
166              
167             =item * C - default View object for this Controller.
168             Must be a name of preloaded view,
169             an object with a C method, or a CODEREF
170             receiving hashref and returning a list of two scalars
171             (content and content-type).
172              
173             B<[DEPRECATED]> Use C<-view> instead, meaning is exactly the same.
174              
175             =item * C - if set, set Expires: HTTP header accordingly.
176              
177             B<[EXPERIMENTAL]> Name and semantics MAY change in the future.
178              
179             =item * C - a C<\%hash> of values that will be added to results
180             EVERY time the handler returns.
181             Consider using C below if you need to append
182             the same values to multiple paths.
183              
184             =item * C => 1 - replace old route even if it exists.
185             If not set, route collisions causes exception.
186             Use this if you know better.
187              
188             This still issues a warning.
189              
190             B<[EXPERIMENTAL]> Name and meaning may change in the future.
191              
192             =item * C => 1 - if route is already defined, do nothing.
193             If not, allow to redefine it later.
194              
195             B<[EXPERIMENTAL]> Name and meaning may change in the future.
196              
197             =item * C - just for information, has no action on execution.
198             This will be displayed if application called with --list (see L).
199              
200             =item * C => 0|1 - a flag just for information.
201             In theory, public endpoints should be searchable from the outside
202             while non-public ones should only be reachable from other parts of application.
203             This is not enforced whatsoever.
204              
205             =back
206              
207             Also, any number of dash-prefixed keys MAY be present.
208             This is the same as putting them into C hash.
209              
210             =cut
211              
212             my $year = 365 * 24 * 60 * 60;
213             my %known_route_args;
214             $known_route_args{$_}++ for qw(
215             default method view cache_ttl
216             path_info_regex param_regex strict
217             description caller tentative override public
218             );
219              
220             sub add_route {
221 117     117 1 6855 my $self = shift;
222              
223 117 100       566 $self->my_croak( "Odd number of elements in hash assignment" )
224             if @_ % 2;
225 116         620 my ($path, $sub, %args) = @_;
226 116         379 $self = _one_and_true($self);
227              
228 115 100       587 $self->my_croak( "handler must be a coderef, not ".ref $sub )
229             unless UNIVERSAL::isa( $sub, "CODE" );
230              
231             # check defaults to be a hash before accessing them
232             $self->my_croak( "default must be unblessed hash" )
233 113 100 100     487 if $args{default} and ref $args{default} ne 'HASH';
234              
235             # minus-prefixed keys are typically defaults
236             $_ =~ /^-/ and $args{default}{$_} = delete $args{$_}
237 112   66     898 for keys %args;
238              
239             # kill extra args
240 112         406 my @extra = grep { !$known_route_args{$_} } keys %args;
  219         718  
241 112 100       364 $self->my_croak( "Unexpected keys in route setup: @extra" )
242             if @extra;
243              
244 111         466 $args{path} = $path = check_path canonize_path( $path );
245              
246 111         578 $args{method} = maybe_list( $args{method}, qw( GET POST ) );
247 111         288 $_ = uc $_ for @{ $args{method} };
  111         574  
248              
249             $self->my_croak("Public endpoint must have nonempty description")
250 111 100 100     513 if $args{public} and not $args{description};
251              
252 110         697 my @real_method = $self->_detect_duplicate( \%args, $args{method} );
253              
254             # Do the work
255 106         305 $args{parent} = $self;
256 106         299 $args{code} = $sub;
257              
258             # Always have regex defined to simplify routing
259             $args{path_info_regex} = (defined $args{path_info_regex})
260 106 100       1028 ? qr#^$args{path_info_regex}$#
261             : qr#^$#;
262              
263             # Just for information
264 106 100       438 $args{public} = $args{public} ? 1 : 0;
265 106   100     666 $args{caller} ||= [caller(0)]; # save file,line
266              
267 106 100       729 if (exists $args{view}) {
268             # TODO 0.30
269 1         18 carp "NEAF: route(): view argument is deprecated, use -view instead";
270 1         757 $args{default}{-view} = delete $args{view};
271             };
272              
273             # preload view so that we can fail early
274             $args{default}{-view} = $self->get_view( $args{default}{-view} )
275 106 100       580 if $args{default}{-view};
276              
277             # ready, shallow copy handler & burn cache
278 106         253 delete $self->{route_re};
279              
280             $self->{route}{ $path }{$_} = MVC::Neaf::Route->new( %args, method => $_ )
281 106         940 for @real_method;
282              
283             # This is for get+post sugar
284 105         374 $self->{last_added} = \%args;
285              
286 105         451 return $self;
287             }; # end sub route
288              
289             # in: { path => '/...', tentative => 0|1, override=> 0|1 }, \@method_list
290             # out: @real_method_list
291             # dies/warns if violations found
292             sub _detect_duplicate {
293 117     117   411 my ($self, $profile, $methods) = @_;
294              
295 117         297 my $path = $profile->{path};
296             # Handle duplicate route definitions
297             my @dupe = grep {
298 117         297 exists $self->{route}{$path}{$_}
299 154 100       1178 and !$self->{route}{$path}{$_}{tentative};
300             } @$methods;
301              
302 117 100       408 if (@dupe) {
303 7         10 my %olddef;
304 7         17 foreach (@dupe) {
305 9         22 my $where = $self->{route}{$path}{$_}{where};
306 9         14 push @{ $olddef{$where} }, $_;
  9         38  
307             };
308              
309             # flatten olddef hash, format list
310 7         24 my $oldwhere = join ", ", map { "$_ [@{ $olddef{$_} }]" } keys %olddef;
  8         32  
  8         62  
311 7   100     27 my $oldpath = $path || '/';
312              
313             # Alas, must do error message by hand
314 7         27 my $caller = [caller 1]->[3];
315 7         337 $caller =~ s/.*:://;
316 7 100       42 if ($profile->{override}) {
    100          
317 2         26 carp( (ref $self)."->$caller: Overriding old handler for"
318             ." $oldpath defined $oldwhere");
319             } elsif( $profile->{tentative} ) {
320             # if we're tentative, filter out already known method/route pairs
321 1         2 my %filter;
322 1         2 $filter{$_}++ for @{ $methods };
  1         4  
323 1         5 delete $filter{$_} for @dupe;
324 1         5 return keys %filter;
325             } else {
326 4         320 croak( (ref $self)."->$caller: Attempting to set duplicate handler for"
327             ." $oldpath defined $oldwhere");
328             };
329             };
330              
331 112         1841 return @$methods;
332             };
333              
334             # This is for get+post sugar
335             # TODO 0.90 merge with alias, GET => implicit HEAD
336             # TODO 0.30 public method
337             sub _dup_route {
338 7     7   30 my ($self, $method, $profile) = @_;
339              
340 7   33     40 $profile ||= $self->{last_added};
341 7         13 my $path = $profile->{path};
342              
343 7         30 my @real_method = $self->_detect_duplicate($profile, [ $method ]);
344              
345 7         19 delete $self->{route_re};
346             $self->{route}{ $path }{$_} = MVC::Neaf::Route->new( %$profile, method => $_ )
347 7         55 for @real_method;
348             };
349              
350             =head2 static()
351              
352             $neaf->static( '/path' => $local_path, %options );
353              
354             $neaf->static( '/other/path' => [ "content", "content-type" ] );
355              
356             Serve static content located under C<$file_path>.
357             Both directories and single files may be added.
358              
359             If an arrayref of C<[ $content, $content_type ]> is given as second argument,
360             serve content from memory instead.
361              
362             %options may include:
363              
364             =over
365              
366             =item * C => C - buffer size for reading/writing files.
367             Default is 4096. Smaller values may be set, but are NOT recommended.
368              
369             =item * C => C - if given, files below the buffer size
370             will be stored in memory for C seconds.
371              
372             B<[EXPERIMENTAL]> Cache API is not yet established.
373              
374             =item * allow_dots => 1|0 - if true, serve files/directories
375             starting with a dot (.git etc), otherwise give a 404.
376              
377             B<[EXPERIMENTAL]>
378              
379             =item * dir_index => 1|0 - if true, generate index for a directory;
380             otherwise a 404 is returned, and deliberately so, for security reasons.
381              
382             B<[EXPERIMENTAL]>
383              
384             =item * dir_template - specify template for directory listing
385             (with images etc). A sane default is provided.
386              
387             B<[EXPERIMENTAL]>
388              
389             =item * view - specify view object for rendering directory template.
390             By default a localized C instance is used.
391              
392             B<[EXPERIMENTAL]> Name MAY be changed (dir_view etc).
393              
394             =item * override - override the route that was here before.
395             See C above.
396              
397             =item * tentative - don't complain if replaced later.
398              
399             =item * description - comment. The default is "Static content at $directory"
400              
401             =item * public => 0|1 - a flag just for information.
402             In theory, public endpoints should be searchable from the outside
403             while non-public ones should only be reachable from other parts of application.
404             This is not enforced whatsoever.
405              
406             =back
407              
408             See L for implementation.
409              
410             File type detection is based on extentions so far, and the list is quite short.
411             This MAY change in the future.
412             Known file types are listed in C<%MVC::Neaf::X::Files::ExtType> hash.
413             Patches welcome.
414              
415             I
416             using a web application framework.
417             Use a real web server instead.
418             Not need to set up one for merely testing icons/js/css, though.>
419              
420             =cut
421              
422             sub static {
423 5     5 1 58 my ($self, $path, $dir, %options) = @_;
424 5         43 $self = _one_and_true($self);
425              
426 5   50     158 $options{caller} ||= [caller 0];
427              
428 5         15 my %fwd_opt;
429             defined $options{$_} and $fwd_opt{$_} = delete $options{$_}
430 5   66     66 for qw( tentative override caller public );
431              
432 5 100       23 if (ref $dir eq 'ARRAY') {
433 1         6 my $sub = $self->_static_global->preload( $path => $dir )->one_file_handler;
434 1         265 return $self->route( $path => $sub, method => 'GET', %fwd_opt,
435             , description => Carp::shortmess( "Static content from memory" ));
436             };
437              
438 4         1554 require MVC::Neaf::X::Files;
439 4         58 my $xfiles = MVC::Neaf::X::Files->new(
440             %options, root => $self->dir($dir), base_url => $path );
441 4         15 return $self->route( $xfiles->make_route, %fwd_opt );
442             };
443              
444             # Instantiate a global static handler to preload in-memory
445             # static files into.
446             # TODO 0.30 lame name, find better
447             sub _static_global {
448 6     6   16 my $self = shift;
449              
450 6   66     33 return $self->{global_static} ||= do {
451 5         2611 require MVC::Neaf::X::Files;
452 5         56 MVC::Neaf::X::Files->new( root => '/dev/null' );
453             };
454             };
455              
456              
457             =head2 alias()
458              
459             $neaf->alias( $newpath => $oldpath )
460              
461             Create a new name for already registered route.
462             The handler will be executed as is,
463             but the hooks and defaults will be re-calculated.
464             So be careful.
465              
466             B<[CAUTION]> As of 0.21, C does NOT adhere tentative/override switches.
467             This needs to be fixed in the future.
468              
469             =cut
470              
471             # TODO 0.30 add_alias or something
472             sub alias {
473 3     3 1 10 my ($self, $new, $old) = @_;
474 3         7 $self = _one_and_true($self);
475              
476 3         9 $new = canonize_path( $new );
477 3         7 $old = canonize_path( $old );
478              
479 3         9 check_path( $old, $new );
480              
481 3 100       18 $self->{route}{$old}
482             or $self->my_croak( "Cannot create alias for unknown route $old" );
483              
484             # TODO 0.30 restrict methods, handle tentative/override, detect dupes
485             $self->my_croak( "Attempting to set duplicate handler for path "
486             .( length $new ? $new : "/" ) )
487 2 50       13 if $self->{route}{ $new };
    100          
488              
489             # reset cache
490 1         3 delete $self->{route_re};
491              
492             # FIXME clone()
493 1         3 $self->{route}{$new} = $self->{route}{$old};
494 1         3 return $self;
495             };
496              
497             =head2 set_path_defaults
498              
499             set_path_defaults( { version => 0.99 }, path => '/api', %options );
500              
501             %options may include:
502              
503             =over
504              
505             =item * path - restrict this set of defaults to given prefix(es);
506              
507             =item * method - restrict this set of defaults to given method(s);
508              
509             =item * exclude - exclude some prefixes;
510              
511             =back
512              
513             Append the given values to the hash returned by I route
514             under the given path(s) and method(s).
515              
516             Longer paths take over the shorter ones.
517             Route's own default values take over any path-based defaults.
518             Whatever the controller returns overrides all of these.
519              
520             =cut
521              
522             # TODO 0.30 rename defaults => [something]
523             sub set_path_defaults {
524 105     105 1 419 my $self = shift;
525 105         366 $self = _one_and_true($self);
526              
527             # Old form - path => \%hash
528             # TODO 0.30 kill
529 105 100       452 if (@_ == 2) {
530 1         15 carp "set_path_defaults(): '/prefix' => \%values form is DEPRECATED, use \%values, path => '/prefix' instead";
531 1         860 push @_, path => shift;
532             };
533              
534 105         274 my ($values, %opt) = @_;
535              
536 105 100       776 $self->my_croak( "values must be a \%hash" )
537             unless ref $values eq 'HASH';
538              
539 104         1004 extra_missing( \%opt, { path => 1, method => 1 } );
540              
541 104   66     2357 $self->{defaults} ||= MVC::Neaf::Util::Container->new;
542 104         640 $self->{defaults}->store( $values, %opt );
543              
544 104         260 return $self;
545             };
546              
547             =head2 get_path_defaults
548              
549             get_path_defaults ( $methods, $path, [ \%override ... ] )
550              
551             Fetch default values for given (path, method) combo as a single hash.
552              
553             =cut
554              
555             sub get_path_defaults {
556 204     204 1 724 my ($self, $method, $path, @override) = @_;
557              
558 204         920 my @source = $self->{defaults}->fetch( method => $method, path => $path );
559 204         737 my %hash = map { %$_ } @source, grep defined, @override;
  420         1562  
560             defined $hash{$_} or delete $hash{$_}
561 204   66     1286 for keys %hash;
562              
563 204         909 \%hash;
564             };
565              
566              
567             =head2 add_hook()
568              
569             $neaf->add_hook ( phase => CODEREF, %options );
570              
571             Set hook that will be executed on a given request processing phase.
572              
573             Valid phases include:
574              
575             =over
576              
577             =item * pre_route [die]
578              
579             =item * pre_logic [die]
580              
581             =item * pre_content
582              
583             =item * pre_render [die]
584              
585             =item * pre_reply [reverse]
586              
587             =item * pre_cleanup [reverse]
588              
589             =back
590              
591             See L below for detailed
592             discussion of each phase.
593              
594             The CODEREF receives one and only argument - the C<$request> object.
595             Return value is B, see explanation below.
596              
597             Use C<$request>'s C, C, and C methods
598             for communication between hooks.
599              
600             Dying in a hook MAY cause interruption of request processing
601             or merely a warning, depending on the phase.
602              
603             %options may include:
604              
605             =over
606              
607             =item * path => '/path' - where the hook applies. Default is '/'.
608             Multiple locations may be supplied via C<[ /foo, /bar ...]>
609              
610             =item * exclude => '/path/skip' - don't apply to these locations,
611             even if under '/path'.
612             Multiple locations may be supplied via C<[ /foo, /bar ...]>
613              
614             =item * method => 'METHOD' || [ list ]
615             List of request HTTP methods to which given hook applies.
616              
617             =item * prepend => 0|1 - all other parameters being equal,
618             hooks will be executed in order of adding.
619             This option allows to override this and run given hook first.
620             Note that this does NOT override path bubbling order.
621              
622             =back
623              
624             =cut
625              
626             my %add_hook_args;
627             $add_hook_args{$_}++ for qw(method path exclude prepend);
628              
629             our %hook_phases;
630             $hook_phases{$_}++ for qw(pre_route
631             pre_logic pre_content pre_render pre_reply pre_cleanup);
632              
633             sub add_hook {
634 35     35 1 249 my ($self, $phase, $code, %opt) = @_;
635 35         95 $self = _one_and_true($self);
636              
637 35         140 extra_missing( \%opt, \%add_hook_args );
638 35 100       137 $self->my_croak( "hook must be a coderef, not ".ref $code )
639             unless UNIVERSAL::isa( $code, 'CODE' );
640             $self->my_croak( "illegal phase: $phase" )
641 34 100       113 unless $hook_phases{$phase};
642              
643 33         131 $opt{method} = maybe_list( $opt{method}, supported_methods() );
644 33 100       123 if ($phase eq 'pre_route') {
645             # handle pre_route separately
646             $self->my_croak("cannot specify paths/excludes for $phase")
647 11 100 100     86 if defined $opt{path} || defined $opt{exclude};
648             };
649              
650 31         97 $opt{path} = maybe_list( $opt{path}, '' );
651 31   50     320 $opt{caller} ||= [ caller(0) ]; # where the hook was set
652              
653 31   66     288 $self->{todo_hooks}{$phase} ||= MVC::Neaf::Util::Container->new;
654 31         171 $self->{todo_hooks}{$phase}->store( $code, %opt );
655              
656 31         133 return $self;
657             };
658              
659             =head2 get_hooks
660              
661             get_hooks( $method, $path )
662              
663             Fetch all hooks previously set for given path as a { phase => [ list ] } hash.
664              
665             =cut
666              
667             sub get_hooks {
668 201     201 1 660 my ($self, $method, $path) = @_;
669              
670 201         338 my %ret;
671              
672 201         327 foreach my $phase ( keys %{ $self->{todo_hooks} } ) {
  201         719  
673 51         159 $ret{$phase} = [ $self->{todo_hooks}{$phase}->fetch( method => $method, path => $path ) ];
674             };
675              
676             # Some hooks to be executed in reverse order
677 13         40 $ret{$_} and @{ $ret{$_} } = reverse @{ $ret{$_} }
  13         29  
678 201   66     950 for qw( pre_reply pre_cleanup );
679              
680             # Prepend session handler unconditionally, if present
681 201 100       647 if (my $key = $self->{session_view_as}) {
682 3         16 unshift @{ $ret{pre_render} }, sub {
683 2     2   10 $_[0]->reply->{$key} = $_[0]->load_session;
684 3         5 };
685             };
686              
687 201 100       564 if (my $force_view = $self->{force_view}) {
688             # TODO 0.40 also push pre-rendered -content through force_view
689 4     2   8 push @{ $ret{pre_render} }, sub { $_[0]->reply->{-view} = $force_view };
  4         31  
  2         7  
690             };
691              
692 201         709 return \%ret;
693             };
694              
695             =head2 set_helper
696              
697             set_helper( name => \&code, %options )
698              
699             =cut
700              
701             sub set_helper {
702 18     18 1 104 my ($self, $name, $code, %opt) = @_;
703              
704 18 100 66     189 $self->my_croak( "helper must be a CODEREF, not ".ref $code )
705             unless ref $code and UNIVERSAL::isa( $code, 'CODE' );
706 17         64 _install_helper( $name );
707              
708 14   66     158 $self->{todo_helpers}{$name} ||= MVC::Neaf::Util::Container->new( exclusive => 1 );
709 14         80 $self->{todo_helpers}{$name}->store( $code, %opt );
710             };
711              
712             sub _install_helper {
713 17     17   41 my $name = shift;
714              
715 17 100       71 return if $MVC::Neaf::Request::allow_helper{$name};
716              
717 7 100 100     113 croak( "NEAF: helper: inappropriate helper name '$name'" )
718             if $name !~ /^[a-z][a-z_0-9]*/ or $name =~ /^(?:do|neaf)/;
719              
720 5 100       100 croak "NEAF: helper: Cannot override existing method '$name' in Request"
721             if MVC::Neaf::Request->can( $name );
722              
723             my $sub = sub {
724 9     9   63 my $req = shift;
725              
726 9         40 my $code = $req->route->helpers->{$name};
727 9 100       28 croak ("Helper '$name' is not defined for ".$req->method." ".$req->route->path)
728             unless $code;
729              
730 8         23 $code->( $req, @_ );
731 4         29 };
732              
733             # HACK magic here - plant method into request
734             {
735 81     81   737 no strict 'refs'; ## no critic
  81         271  
  81         3527  
  4         11  
736 81     81   616 use warnings FATAL => qw(all);
  81         228  
  81         377148  
737 4         9 *{"MVC::Neaf::Request::$name"} = $sub;
  4         32  
738             };
739              
740 4         16 $MVC::Neaf::Request::allow_helper{$name}++;
741             };
742              
743             =head2 get_helpers
744              
745             =cut
746              
747             sub get_helpers {
748 201     201 1 563 my ($self, $method, $path) = @_;
749              
750 201         414 my $todo = $self->{todo_helpers};
751              
752 201         336 my %ret;
753 201         654 foreach my $name( keys %$todo ) {
754 29         102 my ($last) = reverse $todo->{$name}->fetch( method => $method, path => $path );
755 29 100       124 $ret{$name} = $last if $last;
756             };
757              
758 201         809 return \%ret;
759             };
760              
761             =head2 load_view()
762              
763             load_view( "name", $view_object ); # stores object
764             # assuming it's an L
765             load_view( "name", $module_name, %params ); # calls new()
766             load_view( "name", $module_alias ); # ditto, see list of aliases below
767             load_view( "name", \&CODE ); # use that sub to generate
768             # content from hash
769              
770             Setup view under name C<$name>.
771             Subsequent requests with C<-view = $name> would be processed by that view
772             object.
773              
774             Use C to fetch the object itself.
775              
776             =over
777              
778             =item * if object is given, just save it.
779              
780             =item * if module name + parameters is given, try to load module
781             and create new() instance.
782              
783             Short aliases C, C, and C may be used
784             for corresponding C modules.
785              
786             =item * if coderef is given, use it as a C method.
787              
788             =back
789              
790             Returns the view object, NOT the object this method was called on.
791              
792             =cut
793              
794             my %view_alias = (
795             TT => 'MVC::Neaf::View::TT',
796             JS => 'MVC::Neaf::View::JS',
797             Dumper => 'MVC::Neaf::View::Dumper',
798             );
799             sub load_view {
800 40     40 1 187 my ($self, $name, $obj, @param) = @_;
801 40         105 $self = _one_and_true($self);
802              
803 40 100 100     299 $self->my_croak("At least two arguments required")
804             unless defined $name and defined $obj;
805              
806             # Instantiate if needed
807 38 100       220 if (!ref $obj) {
808             # in case an alias is used, apply alias
809 36   33     209 $obj = $view_alias{ $obj } || $obj;
810              
811             # Try loading...
812 36 100       385 if (!$obj->can("new")) {
813 34 50       119 eval { load $obj; 1 }
  34         216  
  34         609  
814             or $self->my_croak( "Failed to load view $name=>$obj: $@" );
815             };
816 36         436 $obj = $obj->new( neaf_base_dir => $self->neaf_base_dir, @param );
817             };
818              
819 38 100 66     779 $self->my_croak( "view must be a coderef or a MVC::Neaf::View object" )
      100        
820             unless blessed $obj and $obj->can("render")
821             or ref $obj eq 'CODE';
822              
823 37         188 $self->{seen_view}{$name} = $obj;
824              
825 37         110 return $obj;
826             };
827              
828             =head2 set_forced_view()
829              
830             $neaf->set_forced_view( $view )
831              
832             If set, this view object will be user instead of ANY other view.
833              
834             See L.
835              
836             Returns self.
837              
838             =cut
839              
840             sub set_forced_view {
841 2     2 1 7 my ($self, $view) = @_;
842 2         18 $self = _one_and_true($self);
843              
844 2         12 delete $self->{force_view};
845 2 50       18 return $self unless $view;
846              
847 2         15 $self->{force_view} = $self->get_view( $view );
848              
849 2         7 return $self;
850             };
851              
852             =head2 magic( bool )
853              
854             Get/set "magic" bit that triggers stuff like loading resources from __DATA__
855             on run() and such.
856              
857             Neaf is magical by default.
858              
859             =cut
860              
861             # Dumb accessor(boolean)
862             sub magic {
863 3     3 1 10 my $self = shift;
864 3 100       8 if (@_) {
865 1         4 $self->{magic} = !! shift;
866 1         4 return $self;
867             } else {
868 2         10 return $self->{magic};
869             };
870             };
871              
872             =head2 load_resources()
873              
874             $neaf->load_resources( $file_name || \*FH )
875              
876             Load pseudo-files from a file (typically C<__DATA__>),
877             say templates or static files.
878              
879             As of 0.27, load_resources happens automatically upon L,
880             but only once for each calling file.
881             Use Cmagic(0)> if you know better
882             (e.g. you want to use __DATA__ for something else).
883              
884             The format is as follows:
885              
886             @@ /main.html view=TT
887              
888             [% some_tt_template %]
889              
890             @@ /favicon.ico format=base64 type=png
891              
892             iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAMAAABEpIrGAAAABGdBTUEAAL
893             GPC/xhBQAAAAFzUkdCAK7OHOkAAAAgY0hS<....more encoded lines>
894              
895             I,
896             in a slightly incompatible way.>
897              
898             An entry starts with a literal C<@@>, followed by 1 or more spaces,
899             followed by a slash and a file name, optionally followed by a list
900             of options, and finally by a newline.
901              
902             Everything following the newline and until next such entry
903             is considered file content.
904              
905             Options may include:
906              
907             =over
908              
909             =item * C
910              
911             =item * C
912              
913             =item * C - specify a template for given view(s)
914             Leading slash will be stripped in this case.
915              
916             =back
917              
918             Entries with unknown options will be skipped with a warning.
919              
920             B<[EXPERIMENTAL]> This method and exact format of data is being worked on.
921              
922             =cut
923              
924             # TODO split this sub & move to a separate file
925             my $INLINE_SPEC = qr/^(?:\[(\w+)\]\s+)?(\S+)((?:\s+\w+=\S+)*)$/;
926             my %load_resources_opt;
927             $load_resources_opt{$_}++ for qw( view format type );
928             sub load_resources {
929 13     13 1 82 my ($self, $file, $name) = @_;
930              
931 13 100 66     58 if (!ref $file and defined $file) {
932 2 50       96 open my $fd, "<", $file
933             or $self->my_croak( "Failed to open(r) $file: $!" );
934 2         7 $name = $file;
935 2         6 $file = $fd;
936             };
937              
938             # Don't load the same filename twice
939             return $self
940 13 100 100     79 if defined $name and $self->{load_resources}{$name}++;
941              
942 12         22 my $content;
943              
944 12 100       44 if (ref $file eq 'GLOB') {
    100          
945 6         28 local $/;
946 6         174 $content = <$file>;
947 6 50       40 defined $content
948             or $self->my_croak( "Failed to read from $file: $!" );
949 6         88 close $file;
950             # Die later
951             } elsif (ref $file eq 'SCALAR') {
952 5         9 $content = $$file;
953             } else {
954 1         5 $self->my_croak( "Argument must be a scalar, a scalar ref, or a file descriptor" );
955             };
956              
957 11 100       98 defined $content
958             or $self->my_croak( "Failed load content" );
959              
960             # TODO 0.40 The regex should be: ^@@\s+(/\S+(?:\s+\w+=\S+)*)\s*$
961             # but we must deprecate '[TT] foo.html' first
962 10         146 my @parts = split m{^@@\s+(\S.*?)\s*$}m, $content, -1;
963 10         22 shift @parts;
964 10 50       43 confess "NEAF load_resources failed unexpectedly, file a bug in MVC::Neaf"
965             if @parts % 2;
966              
967 10         25 my %templates;
968             my %static;
969 10         29 while (@parts) {
970             # parse pseudo-file
971 17         34 my $spec = shift @parts;
972 17         31 my $content = shift @parts;
973              
974             # process header
975 17         145 my ($dest, $name, $extra) = ($spec =~ $INLINE_SPEC);
976 17 50       51 $self->my_croak("Bad resource spec format @@ $spec")
977             unless defined $name;
978 17         74 my %opt = $extra =~ /(\w+)=(\S+)/g;
979 17 100       46 if ($dest) {
980 1         5 $opt{view} = $dest;
981 1         26 carp "DEPRECATED '@@ [$dest]' resource format,"
982             ." use '@@ $name view=$dest' instead";
983             };
984              
985 17 100       755 if ( my @unknown = grep { !$load_resources_opt{$_} } keys %opt ) {
  14         55  
986 1         23 carp "Unknown options (@unknown) in '@@ name' in $file, skipping";
987 1         647 next;
988             };
989              
990             # process content
991 16 100       49 if (!$opt{format}) {
    50          
992 13         54 $content =~ s/^\n+//s;
993 13         51 $content =~ s/\s+$//s;
994 13         168 $content = Encode::decode_utf8( $content, 1 );
995             } elsif ($opt{format} eq 'base64') {
996 3         11 $content = decode_b64( $content );
997             } else {
998             # TODO 0.50 calculate line
999 0         0 $self->my_croak("Unknown format $opt{format} in '@@ $spec' in $file");
1000             };
1001              
1002             # store for loading
1003 16 100       144 if (defined( my $view = $opt{view} )) {
1004             # template
1005             $self->my_croak("Duplicate template '@@ $spec' in $file")
1006 9 50       35 if defined $templates{$view}{$name};
1007 9         45 $templates{$view}{$name} = $content;
1008             } else {
1009             # static file
1010             $self->my_croak("Duplicate static file '@@ $spec' in $file")
1011 7 100       42 if $static{$name};
1012 6         41 $static{$name} = [ $content, $opt{type} ];
1013             };
1014             }; # end while @parts
1015              
1016             # now do the loading
1017 9         35 foreach my $name( keys %templates ) {
1018 6         570 my $view = $self->get_view( $name, 1 );
1019 6 100       47 if (!$view) {
    100          
1020 2         31 carp "NEAF: Unknown view $name mentioned in $file";
1021             } elsif ($view->can("preload")) {
1022 3         8 $view->preload( %{ $templates{$name} } );
  3         18  
1023             } else {
1024 1         15 carp "NEAF: View $name mentioned in $file doesn't support template preloading";
1025             };
1026             };
1027 9 100       1043 if( %static ) {
1028 5         45 my $st = $self->_static_global;
1029 5         30 $st->preload( %static );
1030 5         21 foreach( keys %static ) {
1031 5         20 $self->add_route( $_ => $st->one_file_handler, method => 'GET'
1032             , description => "Static resource from $file" );
1033             };
1034             };
1035              
1036 9         62 return $self;
1037             };
1038              
1039             =head2 set_session_handler()
1040              
1041             $neaf->set_session_handler( %options )
1042              
1043             Set a handler for managing sessions.
1044              
1045             If such handler is set, the request object will provide C,
1046             C, and C methods to manage
1047             cross-request user data.
1048              
1049             % options may include:
1050              
1051             =over
1052              
1053             =item * C (required in method form, first argument in DSL form)
1054             - an object providing the storage primitives;
1055              
1056             =item * C - time to live for session (default is 0, which means until
1057             browser is closed);
1058              
1059             =item * C - name of cookie storing session id.
1060             The default is "session".
1061              
1062             =item * C - if set, add the whole session into data hash
1063             under this name before view processing.
1064              
1065             =back
1066              
1067             The engine MUST provide the following methods
1068             (see L for details):
1069              
1070             =over
1071              
1072             =item * session_ttl (implemented in MVC::Neaf::X::Session);
1073              
1074             =item * session_id_regex (implemented in MVC::Neaf::X::Session);
1075              
1076             =item * get_session_id (implemented in MVC::Neaf::X::Session);
1077              
1078             =item * create_session (implemented in MVC::Neaf::X::Session);
1079              
1080             =item * save_session (required);
1081              
1082             =item * load_session (required);
1083              
1084             =item * delete_session (implemented in MVC::Neaf::X::Session);
1085              
1086             =back
1087              
1088             =cut
1089              
1090             sub set_session_handler {
1091 5     5 1 27 my ($self, %opt) = @_; # TODO 0.30 use helpers when ready
1092 5         18 $self = _one_and_true($self);
1093              
1094 5         16 my $sess = delete $opt{engine};
1095 5   100     30 my $cook = $opt{cookie} || 'neaf.session';
1096              
1097 5 50       22 $self->my_croak("engine parameter is required")
1098             unless $sess;
1099              
1100 5 100       17 if (!ref $sess) {
1101 2   33     16 $opt{session_ttl} = delete $opt{ttl} || $opt{session_ttl};
1102              
1103 2 50       5 my $obj = eval { load $sess; $sess->new( %opt ); }
  2         11  
  2         43  
1104             or $self->my_croak("Failed to load session '$sess': $@");
1105              
1106 2         5 $sess = $obj;
1107             };
1108              
1109 5         17 my @missing = grep { !$sess->can($_) }
  35         177  
1110             qw(get_session_id session_id_regex session_ttl
1111             create_session load_session save_session delete_session );
1112 5 50       26 $self->my_croak("engine object does not have methods: @missing")
1113             if @missing;
1114              
1115 5         23 my $regex = $sess->session_id_regex;
1116 5   50     31 my $ttl = $opt{ttl} || $sess->session_ttl || 0;
1117              
1118 5         31 my $setup = {
1119             engine => $sess,
1120             cookie => $cook,
1121             regex => $regex,
1122             ttl => $ttl,
1123             };
1124              
1125 5     20   48 $self->set_helper( _session_setup => sub { $setup }, override => 1 );
  20         104  
1126 5         18 $self->{session_view_as} = $opt{view_as};
1127 5         22 return $self;
1128             };
1129              
1130             =head2 set_error_handler()
1131              
1132             $neaf->set_error_handler ( $status => CODEREF( $request, %options ), %where )
1133              
1134             Set custom error handler.
1135              
1136             Status MUST be a 3-digit number (as in HTTP).
1137              
1138             %where may include C, C, and C keys.
1139             If omitted, just install error handler globally.
1140              
1141             Other allowed keys MAY appear in the future.
1142              
1143             The following options will be passed to coderef:
1144              
1145             =over
1146              
1147             =item * status - status being returned;
1148              
1149             =item * caller - file:line where the route was set up;
1150             This is DEPRECATED and will silently disappear around version 0.25
1151              
1152             =item * error - exception, an L object.
1153              
1154             =back
1155              
1156             The coderef MUST return an unblessed hash just like a normal controller does.
1157              
1158             In case of exception or unexpected return format
1159             default HTML error page will be returned.
1160              
1161             Also available in static form, as C \%hash )>.
1162              
1163             This is a synonym to C $status, ... } }>.
1164              
1165             =cut
1166              
1167             sub set_error_handler {
1168 9     9 1 46 my ($self, $status, $code, %where) = @_;
1169 9         35 $self = _one_and_true($self);
1170              
1171 9 50       43 $status =~ /^(?:\d\d\d)$/
1172             or $self->my_croak( "1st argument must be an http status");
1173 9         70 extra_missing( \%where, { path => 1, exclude => 1, method => 1 } );
1174              
1175 9 100       44 if (ref $code eq 'HASH') {
1176 2         5 my $hash = $code;
1177             $code = sub {
1178 3     3   11 my ($req, %opt) = @_;
1179              
1180 3         35 return { -status => $opt{status}, %opt, %$hash };
1181 2         14 };
1182             };
1183 9 50       47 reftype $code eq 'CODE'
1184             or $self->my_croak( "2nd argument must be a callback or hash");
1185              
1186 9   66     87 my $store = $self->{error_template}{$status}
1187             ||= MVC::Neaf::Util::Container->new();
1188              
1189 9         46 $store->store( $code, %where );
1190              
1191 9         44 return $self;
1192             };
1193              
1194             =head2 on_error()
1195              
1196             on_error( sub { my ($request, $error) = @_ } )
1197              
1198             Install custom error handler for a dying controller.
1199             Neaf's own exceptions, redirects, and C status returns will NOT
1200             trigger it.
1201              
1202             E.g. write to log, or something.
1203              
1204             Return value from this callback is ignored.
1205             If it dies, only a warning is emitted.
1206              
1207             =cut
1208              
1209             sub on_error {
1210 1     1 1 2 my ($self, $code) = @_;
1211 1         4 $self = _one_and_true($self);
1212              
1213 1 50       5 if (defined $code) {
1214 1 50       5 ref $code eq 'CODE'
1215             or $self->my_croak( "Argument MUST be a callback" );
1216 1         3 $self->{on_error} = $code;
1217             } else {
1218 0         0 delete $self->{on_error};
1219             };
1220              
1221 1         2 return $self;
1222             };
1223              
1224             =head2 post_setup
1225              
1226             This function is run after configuration has been completed,
1227             but before first request is served.
1228              
1229             It goes as follows:
1230              
1231             =over
1232              
1233             =item * compile all the routes into a giant regexp;
1234              
1235             =item * Add HEAD handling to where only GET exists;
1236              
1237             =item * finish set_session_handler works
1238              
1239             =item * set the lock on route;
1240              
1241             =back
1242              
1243             Despite the locking, further modifications are not prohibited.
1244             This MAY change in the future.
1245              
1246             =cut
1247              
1248             sub post_setup {
1249 170     170 1 339 my $self = shift;
1250              
1251             # TODO 0.30 disallow calling this method twice
1252             # confess "Attempt to call post_setup twice"
1253             # if $self->{lock};
1254              
1255 170   66     1066 $self->{route_re} ||= $self->_make_route_re;
1256              
1257             # Add implicit HEAD for all GETs via shallow copy
1258 170         361 foreach my $node (values %{ $self->{route} }) {
  170         670  
1259 268 100       1034 $node->{GET} or next;
1260 251   66     1085 $node->{HEAD} ||= $node->{GET}->clone( method => 'HEAD' );
1261             };
1262              
1263 170         514 $self->{lock}++;
1264             };
1265              
1266             # Create a giant regexp from a hash of paths
1267             # PURE
1268             # The regex can be matched against an URI path,
1269             # in which case it returns either nothing,
1270             # or mathed route in $1 (prefix) and the rest of the string in $2 (postfix)
1271             sub _make_route_re {
1272 75     75   292 my ($self, $hash) = @_;
1273              
1274 75   66     506 $hash ||= $self->{route};
1275              
1276             # Make longest paths come first
1277 75         539 my @path_list = reverse sort keys %$hash;
1278              
1279             # escape all metacharacters except /
1280             # which is converted to '/+' so that foo///bar is also matched
1281             my $re = join "|", map {
1282 75         314 join '/+', map {
1283 98         716 quotemeta
1284 188         905 } split /\/+/, $_
1285             } @path_list;
1286              
1287             # split path into (/foo/bar)/(baz)?param=value
1288             # return prefix as $1 and postfix as $2, if present
1289 75         3542 return qr{^($re)(?:/+([^?]*))?(?:\?|$)};
1290             };
1291              
1292             =head2 run()
1293              
1294             $neaf->run();
1295              
1296             Run the application.
1297             This SHOULD be the last statement in your application's main file.
1298              
1299             When run() is called, the routes are compiled into one giant regex,
1300             and the post-setup is run, if needed.
1301              
1302             Additionally if neaf is in magical mode,
1303             L is called on the enclosing file's DATA descriptor.
1304             Magic mode is on by default. See L.
1305              
1306             If called in void context, assumes execution as C
1307             and prints results to C.
1308             If command line options are present at the moment,
1309             enters debug mode via L.
1310             Call C for more.
1311              
1312             Otherwise returns a C-compliant coderef.
1313             This will also happen if you application is C'd,
1314             meaning that it returns a true value and actually serves nothing until
1315             C is called again.
1316              
1317             Running under mod_perl requires setting a handler with
1318             L.
1319              
1320             =cut
1321              
1322             sub run {
1323 176     176 1 10396 my $self = shift;
1324 176         482 $self = _one_and_true($self);
1325              
1326             # "Magically" load __DATA__ section from calling file
1327 176 100       621 if ($self->{magic}) {
1328 174         711 my ($file, $data) = data_fh(1);
1329 174 100       581 $self->load_resources( $data, $file )
1330             if $data;
1331             };
1332              
1333 176 100       511 if (!defined wantarray) {
1334             # void context - we're being called as CGI
1335 6 100       17 if (@ARGV) {
1336 5         26 require MVC::Neaf::CLI;
1337 5         28 MVC::Neaf::CLI->run($self);
1338             } else {
1339 1         521 require Plack::Handler::CGI;
1340             # Somehow this caused uninitialized warning in Plack::Handler::CGI
1341             $ENV{SCRIPT_NAME} = ''
1342 1 50       1104 unless defined $ENV{SCRIPT_NAME};
1343 1         7 Plack::Handler::CGI->new->run( $self->run );
1344             };
1345 6         175 return;
1346             };
1347              
1348             # Do postsetup after CGI/CLI execution
1349             # because it's unneeded there - only one route may be needed so why bother
1350 170         904 $self->post_setup;
1351              
1352             return sub {
1353 21     21   29565 $self->handle_request(
1354             MVC::Neaf::Request::PSGI->new( env => $_[0] ));
1355 170         1258 };
1356             };
1357              
1358             =head1 INTROSPECTION AND TESTING METHODS
1359              
1360             =head2 run_test()
1361              
1362             $neaf->run_test( \%PSGI_ENV, %options )
1363              
1364             $neaf->run_test( "/path?parameter=value", %options )
1365              
1366             Run a L request and return a list of
1367             C<($status, HTTP::Headers::Fast, $whole_content )>.
1368              
1369             Returns just the content in scalar context.
1370              
1371             Just as the name suggests, useful for testing only (it reduces boilerplate).
1372              
1373             Continuation responses are supported, but will be returned in one chunk.
1374              
1375             %options may include:
1376              
1377             =over
1378              
1379             =item * method - set method (default is GET)
1380              
1381             =item * cookie = \%hash - force HTTP_COOKIE header
1382              
1383             =item * header = \%hash - override some headers
1384             This gets overridden by type, cookie etc. in case of conflict
1385              
1386             =item * body = 'DATA' - force body in request
1387              
1388             =item * type - content-type of body
1389              
1390             =item * uploads - a hash of L objects.
1391              
1392             =item * secure = 0|1 - C vs C
1393              
1394             =item * override = \%hash - force certain data in C
1395             Gets overridden by all of the above.
1396              
1397             =back
1398              
1399             =cut
1400              
1401              
1402             my %run_test_allow;
1403             $run_test_allow{$_}++
1404             for qw( type method cookie body override secure uploads header );
1405             sub run_test {
1406 135     135 1 11182 my ($self, $env, %opt) = @_;
1407 135         435 $self = _one_and_true($self);
1408              
1409 135         506 my @extra = grep { !$run_test_allow{$_} } keys %opt;
  48         172  
1410 135 50       445 $self->my_croak( "Extra keys @extra" )
1411             if @extra;
1412              
1413 135 100       444 if (!ref $env) {
1414 130         1050 $env =~ /^(.*?)(?:\?(.*))?$/;
1415 130 100       1706 $env = {
1416             REQUEST_URI => $env,
1417             REQUEST_METHOD => 'GET',
1418             QUERY_STRING => defined $2 ? $2 : '',
1419             SERVER_NAME => 'localhost',
1420             SERVER_PORT => 80,
1421             SCRIPT_NAME => '',
1422             PATH_INFO => $1,
1423             'psgi.version' => [1,1],
1424             'psgi.errors' => \*STDERR,
1425             }
1426             };
1427             # TODO 0.30 complete emulation of everything a sane person needs
1428 135 100       533 $env->{REQUEST_METHOD} = $opt{method} if $opt{method};
1429 135         240 $env->{$_} = $opt{override}{$_} for keys %{ $opt{override} };
  135         584  
1430              
1431 135 100       532 if (my $head = $opt{header} ) {
1432 4         17 foreach (keys %$head) {
1433 4         9 my $name = uc $_;
1434 4         8 $name =~ tr/-/_/;
1435 4         15 $env->{"HTTP_$name"} = $head->{$_};
1436             };
1437             };
1438 135 100       441 if (exists $opt{secure}) {
1439 1 50       4 $env->{'psgi.url_scheme'} = $opt{secure} ? 'https' : 'http';
1440             };
1441 135 100       414 if (my $cook = $opt{cookie}) {
1442 14 100       60 if (ref $cook eq 'HASH') {
1443             $cook = join '; ', map {
1444 12         33 uri_escape_utf8($_).'='.uri_escape_utf8($cook->{$_})
  13         106  
1445             } keys %$cook;
1446             };
1447             $env->{HTTP_COOKIE} = $env->{HTTP_COOKIE}
1448 14 50       596 ? "$env->{HTTP_COOKIE}; $cook"
1449             : $cook;
1450             };
1451 135 100       475 if (my $body = $opt{body} ) {
1452 6 50   2   141 open my $dummy, "<", \$body
  2         14  
  2         4  
  2         17  
1453             or die ("NEAF: FATAL: Redirect failed in run_test");
1454 6         1878 $env->{'psgi.input'} = $dummy;
1455 6         21 $env->{CONTENT_LENGTH} = length $body;
1456             };
1457 135 100       436 if (my $type = $opt{type}) {
1458 1 50       5 $type = 'application/x-www-form-urlencoded' if $type eq '?';
1459             $env->{CONTENT_TYPE} = $opt{type} eq '?' ? '' : $opt{type}
1460 1 50       6 };
1461              
1462 135         240 my %fake;
1463 135         381 $fake{uploads} = delete $opt{uploads};
1464              
1465 135         658 scalar $self->run; # warm up caches
1466              
1467 135         1429 my $req = MVC::Neaf::Request::PSGI->new( %fake, env => $env );
1468              
1469 135         681 my $ret = $self->handle_request( $req );
1470 135 100       486 if (ref $ret eq 'CODE') {
1471             # PSGI functional interface used.
1472 5         2053 require MVC::Neaf::Request::FakeWriter;
1473 5         50 $ret = MVC::Neaf::Request::FakeWriter->new->respond( $ret );
1474             };
1475              
1476             return (
1477             $ret->[0],
1478 135         539 HTTP::Headers::Fast->new( @{ $ret->[1] } ),
1479 135         319 join '', @{ $ret->[2] },
  135         11958  
1480             );
1481             };
1482              
1483             =head2 get_routes()
1484              
1485             $neaf->get_routes( $callback->(\%route_spec, $path, $method) )
1486              
1487             Returns a 2-level hashref with ALL routes for inspection.
1488              
1489             So C<$hash{'/path'}{'GET'} = { handler, expected params, description etc }>
1490              
1491             If callback is present, run it against route definition
1492             and append to hash its return value, but ONLY if it's true.
1493              
1494             As of 0.20, route definitions are only protected by shallow copy,
1495             so be careful with them.
1496              
1497             This SHOULD NOT be used by application itself.
1498              
1499             =cut
1500              
1501             # TODO 0.30 Route->inspect, Route::Main->inspect
1502             sub get_routes {
1503 11     11 1 1824 my ($self, $code) = @_;
1504 11         125 $self = _one_and_true($self);
1505              
1506 11   100 20   199 $code ||= sub { $_[0] };
  20         39  
1507 11         125 scalar $self->run; # burn caches
1508              
1509             # TODO 0.30 must do deeper copying
1510 11         65 my $all = $self->{route};
1511 11         36 my %ret;
1512 11         35 foreach my $path ( keys %$all ) {
1513 17         40 my $batch = $all->{$path};
1514 17         67 foreach my $method ( keys %$batch ) {
1515 48         85 my $route = $batch->{$method};
1516 48 100       129 $route->post_setup
1517             unless $route->is_locked;
1518              
1519 48         121 my $filtered = $code->( $route->clone, $path, $method );
1520 48 100       310 $ret{$path}{$method} = $filtered if $filtered;
1521             };
1522             };
1523              
1524 11         86 return \%ret;
1525             };
1526              
1527             =head1 RUN TIME METHODS
1528              
1529             =head2 handle_request
1530              
1531             handle_request( $req )
1532              
1533             This is the CORE of Not Even A Framework.
1534             Should not be called directly - use C instead.
1535              
1536             C really boils down to
1537              
1538             my ($self, $req) = @_;
1539              
1540             my $req->path =~ /($self->{GIANT_ROUTING_RE})/
1541             or die 404;
1542              
1543             my $endpoint = $self->{ROUTES}{$1}{ $req->method }
1544             or die 405;
1545              
1546             my $reply_hash = $endpoint->{CODE}->($req);
1547              
1548             my $content = $reply_hash->{-view}->render( $reply_hash );
1549              
1550             return [ $reply_hash->{-status}, [...], [ $content ] ];
1551              
1552             The rest 200+ lines of it, spread across this module and L,
1553             are for running callbacks, handling corner cases, and substituting sane defaults.
1554              
1555             =cut
1556              
1557             sub handle_request {
1558 157     157 1 437 my ($self, $req) = @_;
1559 157         403 $self = _one_and_true($self);
1560              
1561 157         373 my $data = eval {
1562 157         827 my $hash = $self->dispatch_logic( $req, '', $req->path );
1563 114         2352 $hash = $req->_set_reply( $hash );
1564              
1565 113 100       453 if (my $hooks = $req->route->hooks->{pre_content}) {
1566             run_all_nodie( $hooks, sub {
1567 0     0   0 $req->log_error( "NEAF: pre_content hook failed: $@" )
1568 2         14 }, $req );
1569             };
1570              
1571             $hash->{-content} = $self->dispatch_view( $req )
1572 113 100       608 unless defined $hash->{-content};
1573 109         272 $hash;
1574             };
1575              
1576 157 100       1862 if (!$data) {
1577             # TODO 0.30 Error handler should be route-dependent.
1578 48         365 $req->_unset_reply;
1579 48         253 $data = $self->_error_to_reply( $req, $@ );
1580             };
1581              
1582             # Encode content, fix headers - do it before hooks
1583 157         1106 $req->_mangle_headers;
1584 157         910 $req->_apply_late_hooks;
1585 157         780 $req->_respond;
1586             };
1587              
1588             =head2 get_view()
1589              
1590             $route->get_view( "name", $lazy )
1591              
1592             Fetch view object by name.
1593              
1594             This is used to fetch/instantiate whatever is in C<-view> of the
1595             controller return hash.
1596              
1597             Uses C ( name => name ) if needed, unless $lazy flag is on.
1598              
1599             If L was called, return its argument instead.
1600              
1601             =cut
1602              
1603             sub get_view {
1604 79     79 1 270 my ($self, $view, $lazy) = @_;
1605 79         225 $self = _one_and_true($self);
1606              
1607             # An object/code means controller knows better
1608 79 100       268 return $view
1609             if ref $view;
1610              
1611             # Try loading & caching if not present.
1612             $self->load_view( $view, $view )
1613 65 100 100     588 unless $lazy || $self->{seen_view}{$view};
1614              
1615             # Finally, return the thing.
1616 65         226 return $self->{seen_view}{$view};
1617             };
1618              
1619             =head2 INTERNAL LOGIC METHODS
1620              
1621             The following methods are part of NEAF's core and should not be called
1622             unless you want something I special.
1623              
1624             The following terminology is used hereafter:
1625              
1626             =over
1627              
1628             =item * prefix - part of URI that matched given NEAF route;
1629              
1630             =item * suffix - anything after the matching part
1631             but before query parameters (the infamous C).
1632              
1633             =back
1634              
1635             When recursive routing is applied, C is left untouched,
1636             C becomes prefix, and C is split into new C + C.
1637              
1638             When a leaf route is found, it matches $suffix to its own regex
1639             and either dies 404 or proceeds with application logic.
1640              
1641             =head2 find_route( $method, $suffix )
1642              
1643             Find subtree that matches given ($method, $suffix) pair.
1644              
1645             May die 404 or 405 if no suitable route is found.
1646              
1647             Otherwise returns (route, new_stem, new_suffix).
1648              
1649             =cut
1650              
1651             sub find_route {
1652 157     157 1 477 my ($self, $method, $path) = @_;
1653              
1654             # Lookup the rules for the given path
1655             $path =~ $self->{route_re}
1656 157 100       1537 or die "404\n";
1657              
1658 151         779 my ($prefix, $postfix) = ($1, $2);
1659 151         411 $prefix =~ s#//+#/#g; # CANONIZE
1660              
1661 151 100       569 my $node = $self->{route}{$prefix}
1662             or die "404\n";
1663              
1664 147         348 my $route = $node->{ $method };
1665 147 100       419 unless ($route) {
1666 4         43 die MVC::Neaf::Exception->new(
1667             -status => 405,
1668             -headers => [Allow => join ", ", keys %$node]
1669             );
1670             };
1671              
1672 143 100       451 $postfix = '' unless defined $postfix;
1673 143         541 return ($route, $prefix, $postfix);
1674             };
1675              
1676             =head2 dispatch_logic
1677              
1678             dispatch_logic( $req, $prefix, $suffix )
1679              
1680             Find a matching route and apply it to the request.
1681              
1682             This is recursive, may die, and may spoil C<$req>.
1683              
1684             Upon successful termination, a reply hash is returned.
1685             See also L.
1686              
1687             =cut
1688              
1689             sub dispatch_logic {
1690 157     157 1 629 my ($self, $req, $stem, $suffix) = @_;
1691              
1692             $self->post_setup
1693 157 50       504 unless $self->{lock};
1694              
1695 157         728 my $method = $req->method;
1696              
1697             # We MUST now ensure that $req->route is avail at any time
1698             # so add self to route
1699             # but maybe this whould be in dispatch_logic
1700 157   66     2518 my $stub = $self->{pre_route_stub}{ $method }
1701             ||= MVC::Neaf::Route::PreRoute->new(
1702             method => $method, parent => $self );
1703 157         827 $req->_import_route( $stub );
1704              
1705             # run pre_route hooks if any
1706 157         832 my $pre_route_hooks = $stub->hooks->{pre_route};
1707 157 100       478 run_all( $pre_route_hooks, $req )
1708             if $pre_route_hooks;
1709              
1710 157         638 my ($route, $new_stem, $new_suffix) = $self->find_route( $method, $suffix );
1711              
1712 143         682 $route->dispatch_logic( $req, $new_stem, $new_suffix );
1713             };
1714              
1715             =head2 dispatch_view
1716              
1717             Apply view to a request.
1718              
1719             =cut
1720              
1721             sub dispatch_view {
1722 56     56 1 193 my ($self, $req) = @_;
1723              
1724 56         269 my $data = $req->reply;
1725 56         156 my $route = $req->route;
1726              
1727 56         125 my $content;
1728              
1729 56         117 eval {
1730             run_all( $route->hooks->{pre_render}, $req )
1731 56 100       173 if $route->hooks->{pre_render};
1732              
1733 55         275 my $view = $self->get_view( $data->{-view} );
1734              
1735 55 50       463 ($content, my $type) = blessed $view
1736             ? $view->render( $data ) : $view->( $data );
1737              
1738 52   66     498 $data->{-type} ||= $type;
1739             };
1740              
1741 56 100       2387 if (!defined $content) {
1742 4   50     83 $req->log_error( "NEAF: Request processed, but rendering failed: ". ($@ || "unknown error") );
1743 4         205 die MVC::Neaf::Exception->new(
1744             -status => 500,
1745             -reason => "Rendering error: $@"
1746             );
1747             };
1748              
1749 52         293 return $content;
1750             };
1751              
1752             sub _error_to_reply {
1753 48     48   170 my ($self, $req, $err) = @_;
1754              
1755             # Convert all errors to Neaf expt.
1756 48 100       319 if (!blessed $err) {
    100          
1757 38         367 $err = MVC::Neaf::Exception->new(
1758             -status => $err,
1759             -nocaller => 1,
1760             );
1761             }
1762             elsif ( !$err->isa("MVC::Neaf::Exception")) {
1763 1         7 $err = MVC::Neaf::Exception->new(
1764             -status => 500,
1765             -sudden => 1,
1766             -reason => $err,
1767             -nocaller => 1,
1768             );
1769             };
1770              
1771             # Now $err is guaranteed to be a Neaf error
1772              
1773             # Use on_error callback to fixup error or gather stats
1774 48 100 100     211 if( $err->is_sudden and exists $self->{on_error}) {
1775 1 50 0     13 eval {
1776 1         12 $self->{on_error}->($req, $err, $req->endpoint_origin);
1777 1         6 1;
1778             }
1779             or $req->log_error( "NEAF: on_error callback failed: ".($@ || "unknown reason") );
1780             };
1781              
1782             # Try fancy error template
1783 48 100       312 if (my $tpl = $self->_get_error_handler( $err->status, $req )) {
1784 9         31 my $ret = eval {
1785 9         36 my $data = $tpl->( $req,
1786             status => $err->status,
1787             error => $err,
1788             );
1789 8   66     46 $data->{-status} ||= $err->status;
1790 8         46 $data = $req->_set_reply( $data );
1791 8   66     63 $data->{-content} ||= $self->dispatch_view( $req );
1792 8         25 $data;
1793             };
1794 9 100       79 return $ret if $ret;
1795 1   50     4 $req->log_error( "NEAF: error_template for ".$err->status." failed:"
1796             .( $@ || "unknown reason") );
1797             };
1798              
1799             # Options exhausted - return plain error message,
1800             # keep track of reason on the inside
1801 40 100       185 $req->log_error( $err->reason )
1802             if $err->is_sudden;
1803 40         531 $req->_set_reply( $err->make_reply( $req ) );
1804             };
1805              
1806             sub _get_error_handler {
1807 48     48   174 my ($self, $status, $req) = @_;
1808              
1809 48         142 my $store = $self->{error_template}{$status};
1810 48 100       275 return unless $store;
1811              
1812 10         36 return $store->fetch_last( method => $req->method, path => $req->path );
1813             };
1814              
1815             =head2 neaf_base_dir()
1816              
1817             Returns the containing directory of the first non-Neaf calling file,
1818             or cwd() with a warning otherwise.
1819              
1820             =cut
1821              
1822             # Should we cache? If so, how to determine we're in a different file now?
1823             sub neaf_base_dir {
1824 38     38 1 135 my $self = shift;
1825              
1826 38         219 my $file = caller_info()->[1];
1827 38 50 33     1169 if (defined $file and -f $file) {
1828 38         1195 $file = abs_path($file);
1829             # TODO actually don't use magic, add use param instead
1830 38 100       3570 return $file =~ /(.*)\.pm$/ ? $1 : dirname $file;
1831             };
1832              
1833 0         0 my $cwd = cwd;
1834 0         0 carp "Unable to determine relative path via caller, consider using absolute paths. Defaulting to cwd='$cwd'";
1835 0         0 return $cwd;
1836             };
1837              
1838             =head1 DEPRECATED METHODS
1839              
1840             Some methods become obsolete during Neaf development.
1841             Anything that is considered deprecated will continue to be supported
1842             I after official deprecation
1843             and a corresponding warning being added.
1844              
1845             Please keep an eye on C though.
1846              
1847             B
1848              
1849             =over
1850              
1851             =item * route
1852              
1853             Old alias for L.
1854              
1855             =cut
1856              
1857             sub route {
1858 29     29 1 839 my $self = shift;
1859              
1860             # TODO 0.30 deprecate
1861              
1862 29         193 $self->add_route(@_);
1863             };
1864              
1865             =back
1866              
1867             =head1 LICENSE AND COPYRIGHT
1868              
1869             This module is part of L suite.
1870              
1871             Copyright 2016-2023 Konstantin S. Uvarin C.
1872              
1873             This program is free software; you can redistribute it and/or modify it
1874             under the terms of either: the GNU General Public License as published
1875             by the Free Software Foundation; or the Artistic License.
1876              
1877             See L for more information.
1878              
1879             =cut
1880              
1881             1;