File Coverage

blib/lib/Dancer2/Core/App.pm
Criterion Covered Total %
statement 619 649 95.3
branch 193 230 83.9
condition 68 112 60.7
subroutine 99 104 95.1
pod 15 45 33.3
total 994 1140 87.1


line stmt bran cond sub pod time code
1             # ABSTRACT: encapsulation of Dancer2 packages
2             package Dancer2::Core::App;
3             $Dancer2::Core::App::VERSION = '1.0.0';
4 145     145   299956 use Moo;
  145         851578  
  145         820  
5 145     145   183078 use Carp qw<croak carp>;
  145         396  
  145         7410  
6 145     145   899 use Scalar::Util 'blessed';
  145         373  
  145         5944  
7 145     145   2564 use Module::Runtime 'is_module_name';
  145         5925  
  145         879  
8 145     145   59992 use Safe::Isa;
  145         58517  
  145         20721  
9 145     145   62673 use Sub::Quote;
  145         758781  
  145         9267  
10 145     145   1123 use File::Spec;
  145         301  
  145         4324  
11 145     145   810 use Module::Runtime qw< require_module use_module >;
  145         328  
  145         952  
12 145     145   7331 use List::Util ();
  145         334  
  145         2913  
13 145     145   45806 use Ref::Util qw< is_ref is_globref is_scalarref >;
  145         150525  
  145         9518  
14              
15 145     145   65239 use Plack::App::File;
  145         2430898  
  145         5988  
16 145     145   63576 use Plack::Middleware::FixMissingBodyInRedirect;
  145         1113833  
  145         5989  
17 145     145   59966 use Plack::Middleware::Head;
  145         38943  
  145         4762  
18 145     145   58746 use Plack::Middleware::Conditional;
  145         36652  
  145         4726  
19 145     145   60363 use Plack::Middleware::ConditionalGET;
  145         88140  
  145         5309  
20              
21 145     145   57334 use Dancer2::FileUtils 'path';
  145         438  
  145         8897  
22 145     145   2520 use Dancer2::Core;
  145         369  
  145         2804  
23 145     145   60592 use Dancer2::Core::Cookie;
  145         596  
  145         6291  
24 145     145   74107 use Dancer2::Core::Error;
  145         554  
  145         5650  
25 145     145   1191 use Dancer2::Core::Types;
  145         355  
  145         1196  
26 145     145   1799590 use Dancer2::Core::Route;
  145         517  
  145         5271  
27 145     145   59660 use Dancer2::Core::Hook;
  145         520  
  145         4949  
28 145     145   79535 use Dancer2::Core::Request;
  145         603  
  145         6534  
29 145     145   60598 use Dancer2::Core::Factory;
  145         493  
  145         4460  
30              
31 145     145   63125 use Dancer2::Handler::File;
  145         619  
  145         1205962  
32              
33             our $EVAL_SHIM; $EVAL_SHIM ||= sub {
34             my $code = shift;
35             $code->(@_);
36             };
37              
38              
39             # we have hooks here
40             with qw<
41             Dancer2::Core::Role::Hookable
42             Dancer2::Core::Role::ConfigReader
43             >;
44              
45 265     265 0 1979 sub supported_engines { [ qw<logger serializer session template> ] }
46              
47             sub with_plugins {
48 37     37 1 129 my ( $self, @plugins ) = @_;
49 37         176 return map $self->_with_plugin($_), @plugins;
50              
51             }
52              
53             sub _with_plugin {
54 37     37   146 my( $self, $plugin ) = @_;
55              
56 37 100       156 if ( is_ref($plugin) ) {
57             # passing the plugin as an already-created object
58              
59             # already loaded?
60 1 50       6 if( my ( $already ) = grep { ref($plugin) eq ref $_; } @{ $self->plugins } ) {
  2         19  
  1         19  
61 0 0       0 die "trying to load two different objects for plugin ". ref $plugin
62             if refaddr($plugin) != refaddr $already ;
63              
64             }
65             else {
66 1         2 push @{ $self->plugins }, $plugin;
  1         17  
67             }
68              
69 1         11 return $plugin;
70             }
71              
72             # short plugin names get Dancer2::Plugin:: prefix
73             # plugin names starting with a '+' are full package names
74 36 100       227 if ( $plugin !~ s/^\+// ) {
75 7         44 $plugin =~ s/^(?!Dancer2::Plugin::)/Dancer2::Plugin::/;
76             }
77              
78             # check if it's already there
79 36 100       108 if( my ( $already ) = grep { $plugin eq ref $_ } @{ $self->plugins } ) {
  12         141  
  36         772  
80 2         10 return $already;
81             }
82              
83 34         409 push @{ $self->plugins },
  34         557  
84             $plugin = use_module($plugin)->new( app => $self );
85              
86 34         570 return $plugin;
87             }
88              
89             sub with_plugin {
90 37     37 1 8285 my( $self, $plugin ) = @_;
91              
92 37 50       144 croak "expected a single argument"
93             unless @_ == 2;
94              
95 37         167 ( $self->with_plugins($plugin) )[0];
96             }
97              
98             has _factory => (
99             is => 'ro',
100             isa => InstanceOf['Dancer2::Core::Factory'],
101             lazy => 1,
102             default => sub { Dancer2::Core::Factory->new },
103             );
104              
105             has logger_engine => (
106             is => 'ro',
107             isa => ConsumerOf['Dancer2::Core::Role::Logger'],
108             lazy => 1,
109             builder => '_build_logger_engine',
110             writer => 'set_logger_engine',
111             );
112              
113             has session_engine => (
114             is => 'ro',
115             isa => ConsumerOf['Dancer2::Core::Role::SessionFactory'],
116             lazy => 1,
117             builder => '_build_session_engine',
118             writer => 'set_session_engine',
119             );
120              
121             has template_engine => (
122             is => 'ro',
123             isa => ConsumerOf['Dancer2::Core::Role::Template'],
124             lazy => 1,
125             builder => '_build_template_engine',
126             writer => 'set_template_engine',
127             );
128              
129             has serializer_engine => (
130             is => 'ro',
131             isa => ConsumerOf['Dancer2::Core::Role::Serializer'],
132             lazy => 1,
133             builder => '_build_serializer_engine',
134             writer => 'set_serializer_engine',
135             predicate => 'has_serializer_engine',
136             );
137              
138             has '+local_triggers' => (
139             default => sub {
140             my $self = shift;
141             my $triggers = {
142             # general triggers we want to allow, besides engines
143             views => sub {
144             my $self = shift;
145             my $value = shift;
146             $self->template_engine->views($value);
147             },
148              
149             layout => sub {
150             my $self = shift;
151             my $value = shift;
152             $self->template_engine->layout($value);
153             },
154              
155             layout_dir => sub {
156             my $self = shift;
157             my $value = shift;
158             $self->template_engine->layout_dir($value);
159             },
160              
161             log => sub {
162             my ( $self, $value, $config ) = @_;
163              
164             # This will allow to set the log level
165             # using: set log => warning
166             $self->logger_engine->log_level($value);
167             },
168             };
169              
170             foreach my $engine ( @{ $self->supported_engines } ) {
171             $triggers->{$engine} = sub {
172             my $self = shift;
173             my $value = shift;
174             my $config = shift;
175              
176             is_ref($value) and return $value;
177              
178             my $build_method = "_build_${engine}_engine";
179             my $setter_method = "set_${engine}_engine";
180             my $engine_instance = $self->$build_method( $value, $config );
181              
182             # set the engine with the new value from the builder
183             $self->$setter_method($engine_instance);
184              
185             return $engine_instance;
186             };
187             }
188              
189             return $triggers;
190             },
191             );
192              
193             sub _build_logger_engine {
194 254     254   5791 my $self = shift;
195 254         597 my $value = shift;
196 254         545 my $config = shift;
197              
198 254 100       5702 defined $config or $config = $self->config;
199 254 100       3383 defined $value or $value = $config->{logger};
200              
201 254 50       1676 is_ref($value) and return $value;
202              
203             # XXX This is needed for the tests that create an app without
204             # a runner.
205 254 50       1052 defined $value or $value = 'console';
206              
207 254 100       1273 is_module_name($value)
208             or croak "Cannot load logger engine '$value': illegal module name";
209              
210 253         5845 my $engine_options =
211             $self->_get_config_for_engine( logger => $value, $config );
212              
213             my $logger = $self->_factory->create(
214             logger => $value,
215 253         5670 %{$engine_options},
  253         7282  
216             location => $self->config_location,
217             environment => $self->environment,
218             app_name => $self->name,
219             postponed_hooks => $self->postponed_hooks
220             );
221              
222 253 100       6042 exists $config->{log} and $logger->log_level($config->{log});
223              
224 253         7435 return $logger;
225             }
226              
227             sub _build_session_engine {
228 176     176   26995 my $self = shift;
229 176         456 my $value = shift;
230 176         404 my $config = shift;
231              
232 176 100       3868 defined $config or $config = $self->config;
233 176 100 100     3171 defined $value or $value = $config->{'session'} || 'simple';
234              
235 176 100       946 is_ref($value) and return $value;
236              
237 173 100       1098 is_module_name($value)
238             or croak "Cannot load session engine '$value': illegal module name";
239              
240 172         4084 my $engine_options =
241             $self->_get_config_for_engine( session => $value, $config );
242              
243 172         1003 Scalar::Util::weaken( my $weak_self = $self );
244              
245             # Note that engine options will replace the default session_dir (if provided).
246             return $self->_factory->create(
247             session => $value,
248             session_dir => path( $self->config->{appdir}, 'sessions' ),
249 172         2774 %{$engine_options},
250             postponed_hooks => $self->postponed_hooks,
251              
252 3     3   31 log_cb => sub { $weak_self->log(@_) },
253 172         3805 );
254             }
255              
256             sub _build_template_engine {
257 165     165   5213 my $self = shift;
258 165         489 my $value = shift;
259 165         403 my $config = shift;
260              
261 165 100       3495 defined $config or $config = $self->config;
262 165 100       2521 defined $value or $value = $config->{'template'};
263              
264 165 50       873 defined $value or return;
265 165 50       720 is_ref($value) and return $value;
266              
267 165 100       873 is_module_name($value)
268             or croak "Cannot load template engine '$value': illegal module name";
269              
270 164         3526 my $engine_options =
271             $self->_get_config_for_engine( template => $value, $config );
272              
273             my $engine_attrs = {
274             config => $engine_options,
275             layout => $config->{layout},
276             layout_dir => ( $config->{layout_dir} || 'layouts' ),
277             views => $config->{views},
278 164   50     2290 };
279              
280 164         1092 Scalar::Util::weaken( my $weak_self = $self );
281              
282             return $self->_factory->create(
283             template => $value,
284 164         4570 %{$engine_attrs},
285             postponed_hooks => $self->postponed_hooks,
286              
287 7     7   43 log_cb => sub { $weak_self->log(@_) },
288 164         3942 );
289             }
290              
291             sub _build_serializer_engine {
292 20     20   70 my $self = shift;
293 20         54 my $value = shift;
294 20         48 my $config = shift;
295              
296 20 50       80 defined $config or $config = $self->config;
297 20 50       96 defined $value or $value = $config->{serializer};
298              
299 20 50       84 defined $value or return;
300 20 50       70 is_ref($value) and return $value;
301              
302 20         121 my $engine_options =
303             $self->_get_config_for_engine( serializer => $value, $config );
304              
305 20         145 Scalar::Util::weaken( my $weak_self = $self );
306              
307             return $self->_factory->create(
308             serializer => $value,
309             config => $engine_options,
310             postponed_hooks => $self->postponed_hooks,
311              
312 6     6   50 log_cb => sub { $weak_self->log(@_) },
313 20         500 );
314             }
315              
316             sub _get_config_for_engine {
317 614     614   2311 my $self = shift;
318 614         1398 my $engine = shift;
319 614         1312 my $name = shift;
320 614         1259 my $config = shift;
321              
322 614 100 100     3729 defined $config->{'engines'} && defined $config->{'engines'}{$engine}
323             or return {};
324              
325             # try both camelized name and regular name
326 24         64 my $engine_config = {};
327 24         125 foreach my $engine_name ( $name, Dancer2::Core::camelize($name) ) {
328 31 100       182 if ( defined $config->{'engines'}{$engine}{$engine_name} ) {
329 20         69 $engine_config = $config->{'engines'}{$engine}{$engine_name};
330 20         59 last;
331             }
332             }
333              
334 24         80 return $engine_config;
335             }
336              
337             has postponed_hooks => (
338             is => 'ro',
339             isa => HashRef,
340             default => sub { {} },
341             );
342              
343             # TODO I'd be happier with a HashRef, really
344             has plugins => (
345             is => 'rw',
346             isa => ArrayRef,
347             default => sub { [] },
348             );
349              
350             has route_handlers => (
351             is => 'rw',
352             isa => ArrayRef,
353             default => sub { [] },
354             );
355              
356             has name => (
357             is => 'ro',
358             isa => Str,
359             default => sub { (caller(1))[0] },
360             );
361              
362             has request => (
363             is => 'ro',
364             isa => InstanceOf['Dancer2::Core::Request'],
365             writer => '_set_request',
366             clearer => 'clear_request',
367             predicate => 'has_request',
368             );
369              
370             sub set_request {
371 687     687 0 1681 my ($self, $request, $defined_engines) = @_;
372             # typically this is passed in as an optimization within the
373             # dispatch loop but may be called elsewhere
374 687   66     2091 $defined_engines ||= $self->defined_engines;
375             # populate request in app and all engines
376 687         17424 $self->_set_request($request);
377 687         22304 Scalar::Util::weaken( my $weak_request = $request );
378 687         1143 $_->set_request( $weak_request ) for @{$defined_engines};
  687         13603  
379             }
380              
381             has response => (
382             is => 'ro',
383             isa => InstanceOf['Dancer2::Core::Response'],
384             lazy => 1,
385             writer => 'set_response',
386             clearer => 'clear_response',
387             builder => '_build_response',
388             predicate => 'has_response',
389             );
390              
391             has with_return => (
392             is => 'ro',
393             predicate => 1,
394             writer => 'set_with_return',
395             clearer => 'clear_with_return',
396             );
397              
398             has session => (
399             is => 'ro',
400             isa => InstanceOf['Dancer2::Core::Session'],
401             lazy => 1,
402             builder => '_build_session',
403             writer => 'set_session',
404             clearer => 'clear_session',
405             predicate => '_has_session',
406             );
407              
408             around _build_config => sub {
409             my ( $orig, $self ) = @_;
410             my $config = $self->$orig;
411              
412             if ( $config && $config->{'engines'} ) {
413             $self->_validate_engine($_) for keys %{ $config->{'engines'} };
414             }
415              
416             return $config;
417             };
418              
419             sub _build_response {
420 651     651   7205 my $self = shift;
421             return Dancer2::Core::Response->new(
422 651 100       10611 server_tokens => !$self->config->{'no_server_tokens'},
423             $self->has_serializer_engine
424             ? ( serializer => $self->serializer_engine )
425             : (),
426             );
427             }
428              
429             sub _build_session {
430 93     93   1013 my $self = shift;
431 93         158 my $session;
432              
433             # Find the session engine
434 93         3338 my $engine = $self->session_engine;
435              
436             # find the session cookie if any
437 93 100       914 if ( !$self->has_destroyed_session ) {
438 88         150 my $session_id;
439 88         319 my $session_cookie = $self->cookie( $engine->cookie_name );
440 88 100       1210 defined $session_cookie and
441             $session_id = $session_cookie->value;
442              
443             # if we have a session cookie, try to retrieve the session
444 88 100       294 if ( defined $session_id ) {
445             eval {
446             $EVAL_SHIM->(sub {
447 53     53   262 $session = $engine->retrieve( id => $session_id );
448 53         355 });
449 50         329 1;
450             }
451 53 100       117 or do {
452 3   50     147 my $err = $@ || "Zombie Error";
453 3 50       14 if ( $err !~ /Unable to retrieve session/ ) {
454 0         0 croak "Failed to retrieve session: $err"
455             } else {
456             # XXX we throw away the error entirely? Why?
457             }
458             };
459             }
460             }
461              
462             # create the session if none retrieved
463 93   66     1191 return $session ||= $engine->create();
464             }
465              
466             sub has_session {
467 909     909 1 1496 my $self = shift;
468              
469 909         14408 my $engine = $self->session_engine;
470              
471 909   66     15208 return $self->_has_session
472             || ( $self->cookie( $engine->cookie_name )
473             && !$self->has_destroyed_session );
474             }
475              
476             has destroyed_session => (
477             is => 'ro',
478             isa => InstanceOf ['Dancer2::Core::Session'],
479             predicate => 1,
480             writer => 'set_destroyed_session',
481             clearer => 'clear_destroyed_session',
482             );
483              
484             has 'prep_apps' => (
485             'is' => 'ro',
486             'isa' => ArrayRef,
487             'default' => sub { [] },
488             );
489              
490             sub find_plugin {
491 2     2 0 7 my ( $self, $name ) = @_;
492 2     2   9 my $plugin = List::Util::first { ref($_) eq $name } @{ $self->plugins };
  2         20  
  2         47  
493 2 100       21 $plugin or return;
494 1         4 return $plugin;
495             }
496              
497             sub destroy_session {
498 17     17 1 38 my $self = shift;
499              
500             # Find the session engine
501 17         289 my $engine = $self->session_engine;
502              
503             # Expire session, set the expired cookie and destroy the session
504             # Setting the cookie ensures client gets an expired cookie unless
505             # a new session is created and supercedes it
506 17         372 my $session = $self->session;
507 17         606 $session->expires(-86400); # yesterday
508 17         1827 $engine->destroy( id => $session->id );
509              
510             # Invalidate session cookie in request
511             # and clear session in app and engines
512 17         338 $self->set_destroyed_session($session);
513 17         838 $self->clear_session;
514 17         105 $_->clear_session for @{ $self->defined_engines };
  17         72  
515              
516 17         2054 return;
517             }
518              
519             sub setup_session {
520 118     118 0 205 my $self = shift;
521              
522 118         188 for my $engine ( @{ $self->defined_engines } ) {
  118         276  
523 354 50       15783 $self->has_session ?
524             $engine->set_session( $self->session ) :
525             $engine->clear_session;
526             }
527             }
528              
529             sub change_session_id {
530 5     5 1 14 my $self = shift;
531              
532 5         93 my $session = $self->session;
533              
534             # Find the session engine
535 5         217 my $engine = $self->session_engine;
536              
537 5 100       95 if ($engine->can('_change_id')) {
538              
539             # session engine can change session ID
540 3         24 $engine->change_id( session => $session );
541             }
542             else {
543              
544             # Method order is important in here...
545             #
546             # On session build if there is no destroyed session then the session
547             # builder tries to recreate the session using the existing session
548             # cookie. We really don't want to do that in this case so it is
549             # important to create the new session before the
550             # clear_destroyed_session method is called.
551             #
552             # This sucks.
553             #
554             # Sawyer suggested:
555             #
556             # What if you take the session cookie logic out of that attribute into
557             # another attribute and clear that attribute?
558             # That would force the session rebuilt to rebuilt the attribute and
559             # get a different cookie value, no?
560             #
561             # TODO: think about this some more.
562              
563             # grab data, destroy session and store data again
564 2         8 my %data = %{$session->data};
  2         38  
565              
566             # destroy existing session
567 2         32 $self->destroy_session;
568              
569             # get new session
570 2         34 $session = $self->session;
571              
572             # write data from old session into new
573             # Some engines add session id to data so skip id.
574 2         344 while (my ($key, $value) = each %data ) {
575 2 50       44 $session->write($key => $value) unless $key eq 'id';
576             }
577              
578             # clear out destroyed session - no longer relevant
579 2         57 $self->clear_destroyed_session;
580             }
581              
582 5         130 return $session->id;
583             }
584              
585             has prefix => (
586             is => 'rw',
587             isa => Maybe [Dancer2Prefix],
588             predicate => 1,
589             coerce => sub {
590             my $prefix = shift;
591             defined($prefix) and $prefix eq "/" and return;
592             return $prefix;
593             },
594             );
595              
596             # routes registry, stored by method:
597             has routes => (
598             is => 'rw',
599             isa => HashRef,
600             default => sub {
601             { get => [],
602             head => [],
603             post => [],
604             put => [],
605             del => [],
606             options => [],
607             };
608             },
609             );
610              
611             # add_hook will add the hook to the first "hook candidate" it finds that support
612             # it. If none, then it will try to add the hook to the current application.
613             around add_hook => sub {
614             my $orig = shift;
615             my $self = shift;
616              
617             # saving caller information
618             my ( $package, $file, $line ) = caller(4); # deep to 4 : user's app code
619             my $add_hook_caller = [ $package, $file, $line ];
620              
621             my ($hook) = @_;
622             my $name = $hook->name;
623             my $hook_aliases = $self->all_hook_aliases;
624              
625             # look for an alias
626             defined $hook_aliases->{$name} and $name = $hook_aliases->{$name};
627             $hook->name($name);
628              
629             # if that hook belongs to the app, register it now and return
630             $self->has_hook($name) and return $self->$orig(@_);
631              
632             # at this point the hook name must be formatted like:
633             # '$type.$candidate.$name', eg: 'engine.template.before_render' or
634             # 'plugin.database.before_dbi_connect'
635             my ( $hookable_type, $hookable_name, $hook_name ) = split( /\./, $name );
636              
637             ( defined $hookable_name && defined $hook_name )
638             or croak "Invalid hook name `$name'";
639              
640             grep /^$hookable_type$/, qw(core engine handler plugin)
641             or croak "Unknown hook type `$hookable_type'";
642              
643             # register the hooks for existing hookable candidates
644             foreach my $hookable ( $self->hook_candidates ) {
645             $hookable->has_hook($name) and $hookable->add_hook(@_);
646             }
647              
648             # we register the hook for upcoming objects;
649             # that way, each components that can claim the hook will have a chance
650             # to register it.
651              
652             my $postponed_hooks = $self->postponed_hooks;
653              
654             # Hmm, so the hook was not claimed, at this point we'll cache it and
655             # register it when the owner is instantiated
656             $postponed_hooks->{$hookable_type}{$hookable_name} ||= {};
657             $postponed_hooks->{$hookable_type}{$hookable_name}{$name} ||= {};
658             $postponed_hooks->{$hookable_type}{$hookable_name}{$name}{hook} = $hook;
659             $postponed_hooks->{$hookable_type}{$hookable_name}{$name}{caller} =
660             $add_hook_caller;
661              
662             };
663              
664             around execute_hook => sub {
665             my $orig = shift;
666             my $self = shift;
667              
668             local $Dancer2::Core::Route::REQUEST = $self->request;
669             local $Dancer2::Core::Route::RESPONSE = $self->response;
670              
671             my ( $hook, @args ) = @_;
672             if ( !$self->has_hook($hook) ) {
673             foreach my $cand ( $self->hook_candidates ) {
674             $cand->has_hook($hook) and return $cand->execute_hook(@_);
675             }
676             }
677              
678             return $self->$orig(@_);
679             };
680              
681             sub _build_default_config {
682 237     237   3888 my $self = shift;
683              
684 237   33     2043 my $public = $ENV{DANCER_PUBLIC} || path( $self->location, 'public' );
685             return {
686             content_type => ( $ENV{DANCER_CONTENT_TYPE} || 'text/html' ),
687             charset => ( $ENV{DANCER_CHARSET} || '' ),
688             logger => ( $ENV{DANCER_LOGGER} || 'console' ),
689             views => ( $ENV{DANCER_VIEWS}
690 237   50     4322 || path( $self->location, 'views' ) ),
      50        
      50        
      33        
691             environment => $self->environment,
692             appdir => $self->location,
693             public_dir => $public,
694             template => 'Tiny',
695             route_handlers => [
696             [
697             AutoPage => 1
698             ],
699             ],
700             };
701             }
702              
703             sub _init_hooks {
704 236     236   681 my $self = shift;
705              
706             # Hook to flush the session at the end of the request,
707             # this way, we're sure we flush only once per request
708             #
709             # Note: we create a weakened copy $self
710             # before closing over the weakened copy
711             # to avoid circular memory refs.
712 236         949 Scalar::Util::weaken(my $app = $self);
713              
714             $self->add_hook(
715             Dancer2::Core::Hook->new(
716             name => 'core.app.after_request',
717             code => sub {
718 467     467   893 my $response = $Dancer2::Core::Route::RESPONSE;
719              
720             # make sure an engine is defined, if not, nothing to do
721 467         8126 my $engine = $app->session_engine;
722 467 50       4285 defined $engine or return;
723              
724             # if a session has been instantiated or we already had a
725             # session, first flush the session so cookie-based sessions can
726             # update the session ID if needed, then set the session cookie
727             # in the response
728             #
729             # if there is NO session object but the request has a cookie with
730             # a session key, create a dummy session with the same ID (without
731             # actually retrieving and flushing immediately) and generate the
732             # cookie header from the dummy session. Lazy Sessions FTW!
733              
734 467 100       1606 if ( $app->has_session ) {
    100          
735 76         176 my $session;
736 76 100       208 if ( $app->_has_session ) { # Session object exists
737 73         1147 $session = $app->session;
738 73 100       1654 $session->is_dirty and $engine->flush( session => $session );
739             }
740             else { # Cookie header exists. Create a dummy session object
741 3         17 my $cookie = $app->cookie( $engine->cookie_name );
742 3         62 my $session_id = $cookie->value;
743 3         57 $session = Dancer2::Core::Session->new( id => $session_id );
744             }
745 76         784 $engine->set_cookie_header(
746             response => $response,
747             session => $session
748             );
749             }
750             elsif ( $app->has_destroyed_session ) {
751 12         53 my $session = $app->destroyed_session;
752 12         72 $engine->set_cookie_header(
753             response => $response,
754             session => $session,
755             destroyed => 1
756             );
757             }
758             },
759             )
760 236         4778 );
761             }
762              
763             sub supported_hooks {
764 444     444 0 5079 qw/
765             core.app.before_request
766             core.app.after_request
767             core.app.route_exception
768             core.app.before_file_render
769             core.app.after_file_render
770             core.error.before
771             core.error.after
772             core.error.init
773             /;
774             }
775              
776             sub hook_aliases {
777 1785     1785 0 3307 my $self = shift;
778 1785   100     12616 $self->{'hook_aliases'} ||= {
779             before => 'core.app.before_request',
780             before_request => 'core.app.before_request',
781             after => 'core.app.after_request',
782             after_request => 'core.app.after_request',
783             init_error => 'core.error.init',
784             before_error => 'core.error.before',
785             after_error => 'core.error.after',
786             on_route_exception => 'core.app.route_exception',
787              
788             before_file_render => 'core.app.before_file_render',
789             after_file_render => 'core.app.after_file_render',
790             before_handler_file_render => 'handler.file.before_render',
791             after_handler_file_render => 'handler.file.after_render',
792              
793              
794             # compatibility from Dancer1
795             before_error_render => 'core.error.before',
796             after_error_render => 'core.error.after',
797             before_error_init => 'core.error.init',
798              
799             # TODO: call $engine->hook_aliases as needed
800             # But.. currently there are use cases where hook_aliases
801             # are needed before the engines are intiialized :(
802             before_template_render => 'engine.template.before_render',
803             after_template_render => 'engine.template.after_render',
804             before_layout_render => 'engine.template.before_layout_render',
805             after_layout_render => 'engine.template.after_layout_render',
806             before_serializer => 'engine.serializer.before',
807             after_serializer => 'engine.serializer.after',
808             };
809             }
810              
811             sub defined_engines {
812 1579     1579 0 3114 my $self = shift;
813             return [
814 1579 100       25979 $self->template_engine,
815             $self->session_engine,
816             $self->logger_engine,
817             $self->has_serializer_engine
818             ? $self->serializer_engine
819             : (),
820             ];
821             }
822              
823             # FIXME not needed anymore, I suppose...
824 0     0 0 0 sub api_version {2}
825              
826             sub register_plugin {
827 0     0 1 0 my $self = shift;
828 0         0 my $plugin = shift;
829              
830 0         0 $self->log( core => "Registered $plugin");
831              
832 0         0 push @{ $self->plugins }, $plugin;
  0         0  
833             }
834              
835             # This method overrides the default one from Role::ConfigReader
836             sub settings {
837 905     905 0 1821 my $self = shift;
838 905         1543 +{ %{ Dancer2::runner()->config }, %{ $self->config } };
  905         2441  
  905         25228  
839             }
840              
841             sub cleanup {
842 677     677 0 3022 my $self = shift;
843 677         13507 $self->clear_request;
844 677         14288 $self->clear_response;
845 677         15535 $self->clear_session;
846 677         13653 $self->clear_destroyed_session;
847             # Clear engine attributes
848 677         3662 for my $engine ( @{ $self->defined_engines } ) {
  677         1819  
849 2112         72008 $engine->clear_session;
850 2112         39385 $engine->clear_request;
851             }
852             }
853              
854             sub _validate_engine {
855 28     28   63 my $self = shift;
856 28         59 my $name = shift;
857              
858 28 100       56 grep +( $_ eq $name ), @{ $self->supported_engines }
  28         98  
859             or croak "Engine '$name' is not supported.";
860             }
861              
862             sub engine {
863 26     26 0 725 my $self = shift;
864 26         76 my $name = shift;
865              
866 26         148 $self->_validate_engine($name);
867              
868 25         116 my $attr_name = "${name}_engine";
869 25         565 return $self->$attr_name;
870             }
871              
872             sub template {
873 33     33 0 787 my $self = shift;
874              
875 33         585 my $template = $self->template_engine;
876 33         818 $template->set_settings( $self->config );
877              
878             # A session will not exist if there is no request (global keyword)
879             #
880             # A session may exist but the route code may not have instantiated
881             # the session object (sessions are lazy). If this is the case, do
882             # that now, so the templates have the session data for rendering.
883 33 100 100     2028 $self->has_request && $self->has_session && ! $template->has_session
      100        
884             and $self->setup_session;
885              
886             # return content
887 33 100       240 if ($self->has_with_return) {
888 29         108 my $old_with_return = $self->with_return;
889 29         48 my $local_response;
890             $self->set_with_return( sub {
891 1   33 1   22 $local_response ||= shift;
892 29         186 });
893 29         177 my $content = $template->process( @_ );
894 24         185 $self->set_with_return($old_with_return);
895 24 100       92 if ($local_response) {
896 1         5 $self->with_return->($local_response);
897             }
898 23         126 return $content;
899             }
900 4         29 return $template->process( @_ );
901             }
902              
903             sub hook_candidates {
904 45     45 0 92 my $self = shift;
905              
906 45         89 my @engines = @{ $self->defined_engines };
  45         136  
907              
908 45         3790 my @route_handlers;
909 45         88 for my $handler ( @{ $self->route_handlers } ) {
  45         853  
910 45         422 my $handler_code = $handler->{handler};
911 45 50 33     536 blessed $handler_code and $handler_code->can('supported_hooks')
912             and push @route_handlers, $handler_code;
913             }
914              
915             # TODO : get the list of all plugins registered
916 45         101 my @plugins = @{ $self->plugins };
  45         856  
917              
918 45         542 ( @route_handlers, @engines, @plugins );
919             }
920              
921             sub all_hook_aliases {
922 316     316 0 715 my $self = shift;
923              
924 316         1339 my $aliases = $self->hook_aliases;
925 316         835 for my $plugin ( grep { $_->can('hook_aliases') } @{ $self->plugins } ) {
  13         161  
  316         6147  
926 13         29 $aliases = { %{$aliases}, %{ $plugin->hook_aliases } };
  13         79  
  13         45  
927             }
928              
929 316         3720 return $aliases;
930             }
931              
932             sub mime_type {
933 10     10 0 28 my $self = shift;
934 10         48 my $runner = Dancer2::runner();
935              
936             exists $self->config->{default_mime_type}
937             ? $runner->mime_type->default( $self->config->{default_mime_type} )
938 10 100       235 : $runner->mime_type->reset_default;
939              
940 10         512 $runner->mime_type;
941             }
942              
943             sub log {
944 2361     2361 0 32549 my $self = shift;
945 2361         3818 my $level = shift;
946              
947 2361 50       40742 my $logger = $self->logger_engine
948             or croak "No logger defined";
949              
950 2361         44615 $logger->$level(@_);
951             }
952              
953             sub send_as {
954 8     8 0 12 my $self = shift;
955 8         22 my ( $type, $data, $options ) = @_;
956 8   100     35 $options ||= {};
957              
958 8 100       211 $type or croak "Can not send_as using an undefined type";
959              
960 7 100 100     50 if ( lc($type) eq 'html' || lc($type) eq 'plain' ) {
961 2 50       7 if ( $type ne lc $type ) {
962 0         0 local $Carp::CarpLevel = 2;
963 0         0 carp sprintf( "Please use %s as the type for 'send_as', not %s", lc($type), $type );
964             }
965              
966 2   50     37 $options->{charset} = $self->config->{charset} || 'UTF-8';
967 2         45 my $content = Encode::encode( $options->{charset}, $data );
968 2   33     101 $options->{content_type} ||= join '/', 'text', lc $type;
969 2         11 $self->send_file( \$content, %$options ); # returns from sub
970             }
971              
972             # Try and load the serializer class
973 5         18 my $serializer_class = "Dancer2::Serializer::$type";
974             eval {
975             $EVAL_SHIM->(sub {
976 5     5   22 require_module( $serializer_class );
977 5         28 });
978 3         74 1;
979 5 100       14 } or do {
980 2   50     574 my $err = $@ || "Zombie Error";
981 2         247 croak "Unable to load serializer class for $type: $err";
982             };
983              
984             # load any serializer engine config
985 3   50     67 my $engine_options =
986             $self->_get_config_for_engine( serializer => $type, $self->config ) || {};
987 3         44 my $serializer = $serializer_class->new( config => $engine_options );
988 3         71 my $content = $serializer->serialize( $data );
989 3   66     19 $options->{content_type} ||= $serializer->content_type;
990 3         17 $self->send_file( \$content, %$options );
991             }
992              
993             sub send_error {
994 8     8 0 21 my $self = shift;
995 8         27 my ( $message, $status ) = @_;
996              
997 8 100       157 my $err = Dancer2::Core::Error->new(
998             message => $message,
999             app => $self,
1000             ( status => $status )x!! $status,
1001              
1002             $self->has_serializer_engine
1003             ? ( serializer => $self->serializer_engine )
1004             : (),
1005             )->throw;
1006              
1007             # Immediately return to dispatch if with_return coderef exists
1008 8 50       189 $self->has_with_return && $self->with_return->($err);
1009 0         0 return $err;
1010             }
1011              
1012             sub send_file {
1013 16     16 0 30 my $self = shift;
1014 16         32 my $thing = shift;
1015 16         47 my %options = @_;
1016              
1017 16         48 my ($content_type, $charset, $file_path);
1018              
1019             # are we're given a filehandle? (based on what Plack::Middleware::Lint accepts)
1020             my $is_filehandle = Plack::Util::is_real_fh($thing)
1021 16   33     59 || ( is_globref($thing) && *{$thing}{IO} && *{$thing}{IO}->can('getline') )
1022             || ( Scalar::Util::blessed($thing) && $thing->can('getline') );
1023 16         793 my ($fh) = ($thing)x!! $is_filehandle;
1024              
1025             # if we're given an IO::Scalar object, DTRT (take the scalar ref from it)
1026 16 50 33     54 if (Scalar::Util::blessed($thing) && $thing->isa('IO::Scalar')) {
1027 0         0 $thing = $thing->sref;
1028             }
1029              
1030             # if we're given a SCALAR reference, build a filehandle to it
1031 16 100       50 if ( is_scalarref($thing) ) {
1032             ## no critic qw(InputOutput::RequireCheckedOpen)
1033 6         71 open $fh, "<", $thing;
1034             }
1035              
1036             # If we haven't got a filehandle, create one to the requested content
1037 16 100       47 if (! $fh) {
1038 9         18 my $path = $thing;
1039             # remove prefix from given path (if not a filehandle)
1040 9         228 my $prefix = $self->prefix;
1041 9 50 33     98 if ( $prefix && $prefix ne '/' ) {
1042 0         0 $path =~ s/^\Q$prefix\E//;
1043             }
1044             # static file dir - either system root or public_dir
1045             my $dir = $options{system_path}
1046             ? File::Spec->rootdir
1047             : $ENV{DANCER_PUBLIC}
1048             || $self->config->{public_dir}
1049 9 100 33     147 || path( $self->location, 'public' );
1050              
1051 9         121 $file_path = Dancer2::Handler::File->merge_paths( $path, $dir );
1052             my $err_response = sub {
1053 0     0   0 my $status = shift;
1054 0         0 $self->response->status($status);
1055 0         0 $self->response->header( 'Content-Type', 'text/plain' );
1056 0         0 $self->response->content( Dancer2::Core::HTTP->status_message($status) );
1057 0         0 $self->with_return->( $self->response );
1058 9         75 };
1059 9 50       57 $err_response->(403) if !defined $file_path;
1060 9 50       183 $err_response->(404) if !-f $file_path;
1061 9 50       138 $err_response->(403) if !-r $file_path;
1062              
1063             # Read file content as bytes
1064 9         48 $fh = Dancer2::FileUtils::open_file( "<", $file_path );
1065 9         59 binmode $fh;
1066 9   50     33 $content_type = Dancer2::runner()->mime_type->for_file($file_path) || 'text/plain';
1067 9 100       179 if ( $content_type =~ m!^text/! ) {
1068 5   50     110 $charset = $self->config->{charset} || "utf-8";
1069             }
1070             }
1071              
1072             # Now we are sure we can render the file...
1073 16         486 $self->execute_hook( 'core.app.before_file_render', $file_path );
1074              
1075             # response content type and charset
1076 16 100       195 ( exists $options{'content_type'} ) and $content_type = $options{'content_type'};
1077 16 100       39 ( exists $options{'charset'} ) and $charset = $options{'charset'};
1078 16 100 100     126 $content_type .= "; charset=$charset" if $content_type and $charset;
1079 16 100       291 ( defined $content_type )
1080             and $self->response->header('Content-Type' => $content_type );
1081              
1082             # content disposition
1083             ( exists $options{filename} )
1084             and $self->response->header( 'Content-Disposition' =>
1085 16 100 100     2041 ($options{content_disposition} || "attachment") . "; filename=\"$options{filename}\"" );
1086              
1087             # use a delayed response unless server does not support streaming
1088 16 100       223 my $use_streaming = exists $options{streaming} ? $options{streaming} : 1;
1089 16         26 my $response;
1090 16         73 my $env = $self->request->env;
1091 16 100 66     131 if ( $env->{'psgi.streaming'} && $use_streaming ) {
1092             my $cb = sub {
1093 15     15   30 my $responder = $Dancer2::Core::Route::RESPONDER;
1094 15         23 my $res = $Dancer2::Core::Route::RESPONSE;
1095 15         330 return $responder->(
1096             [ $res->status, $res->headers_to_array, $fh ]
1097             );
1098 15         108 };
1099              
1100 15         74 Scalar::Util::weaken( my $weak_self = $self );
1101              
1102             $response = Dancer2::Core::Response::Delayed->new(
1103 0     0   0 error_cb => sub { $weak_self->logger_engine->log( warning => @_ ) },
1104 15         320 cb => $cb,
1105             request => $Dancer2::Core::Route::REQUEST,
1106             response => $Dancer2::Core::Route::RESPONSE,
1107             );
1108             }
1109             else {
1110 1         22 $response = $self->response;
1111             # direct assignment to hash element, avoids around modifier
1112             # trying to serialise this this content.
1113 1         21 $response->{content} = Dancer2::FileUtils::read_glob_content($fh);
1114 1         28 $response->is_encoded(1); # bytes are already encoded
1115             }
1116              
1117 16         14568 $self->execute_hook( 'core.app.after_file_render', $response );
1118 16         181 $self->with_return->( $response );
1119             }
1120              
1121             sub BUILD {
1122             my $self = shift;
1123             $self->init_route_handlers();
1124             $self->_init_hooks();
1125              
1126             $self->log(core => 'Built config from files: ' . join(' ', @{$self->config_files}));
1127             }
1128              
1129             sub finish {
1130 205     205 0 540 my $self = shift;
1131              
1132             # normalize some values that require calculations
1133             defined $self->config->{'static_handler'}
1134 205 100       3440 or $self->config->{'static_handler'} = -d $self->config->{'public_dir'};
1135              
1136 205         13686 $self->register_route_handlers;
1137 205         3055 $self->compile_hooks;
1138              
1139 205 50 66     1898 @{$self->plugins}
  205         3972  
1140             && $self->plugins->[0]->can('_add_postponed_plugin_hooks')
1141             && $self->plugins->[0]->_add_postponed_plugin_hooks(
1142             $self->postponed_hooks
1143             );
1144              
1145 205         3381 foreach my $prep_cb ( @{ $self->prep_apps } ) {
  205         1216  
1146 4         15 $prep_cb->($self);
1147             }
1148             }
1149              
1150             sub init_route_handlers {
1151 237     237 0 613 my $self = shift;
1152              
1153 237         4550 my $handlers_config = $self->config->{route_handlers};
1154 236         8706 for my $handler_data ( @{$handlers_config} ) {
  236         864  
1155 235         533 my ($handler_name, $config) = @{$handler_data};
  235         694  
1156 235 50       1149 $config = {} if !is_ref($config);
1157              
1158 235         5019 my $handler = $self->_factory->create(
1159             Handler => $handler_name,
1160             app => $self,
1161             %$config,
1162             postponed_hooks => $self->postponed_hooks,
1163             );
1164              
1165 235         251977 push @{ $self->route_handlers }, {
  235         5597  
1166             name => $handler_name,
1167             handler => $handler,
1168             };
1169             }
1170             }
1171              
1172             sub register_route_handlers {
1173 205     205 0 575 my $self = shift;
1174 205         492 for my $handler ( @{$self->route_handlers} ) {
  205         4561  
1175 203         2972 my $handler_code = $handler->{handler};
1176 203         1580 $handler_code->register($self);
1177             }
1178             }
1179              
1180             sub compile_hooks {
1181 208     208 0 656 my ($self) = @_;
1182              
1183 208         991 for my $position ( $self->supported_hooks ) {
1184 1664         11032 my $compiled_hooks = [];
1185 1664         2380 for my $hook ( @{ $self->hooks->{$position} } ) {
  1664         25186  
1186 250         3713 Scalar::Util::weaken( my $app = $self );
1187             my $compiled = sub {
1188             # don't run the filter if halt has been used
1189 681 100 66 681   2680 $Dancer2::Core::Route::RESPONSE &&
1190             $Dancer2::Core::Route::RESPONSE->is_halted
1191             and return;
1192              
1193 680         2428 eval { $EVAL_SHIM->($hook,@_); 1; }
  671         3450  
1194 680 100       5679 or do {
1195 4   50     176 my $err = $@ || "Zombie Error";
1196 4         24 $app->cleanup;
1197 4         61 $app->log('error', "Exception caught in '$position' filter: $err");
1198 4         437 croak "Exception caught in '$position' filter: $err";
1199             };
1200 250         1600 };
1201              
1202 250         546 push @{$compiled_hooks}, $compiled;
  250         844  
1203             }
1204 1664         13945 $self->replace_hook( $position, $compiled_hooks );
1205             }
1206             }
1207              
1208             sub lexical_prefix {
1209 5     5 1 1313 my $self = shift;
1210 5         14 my $prefix = shift;
1211 5         10 my $cb = shift;
1212              
1213 5 100       20 $prefix eq '/' and undef $prefix;
1214              
1215             # save the app prefix
1216 5         99 my $app_prefix = $self->prefix;
1217              
1218             # alter the prefix for the callback
1219 5 100       55 my $new_prefix =
    100          
1220             ( defined $app_prefix ? $app_prefix : '' )
1221             . ( defined $prefix ? $prefix : '' );
1222              
1223             # if the new prefix is empty, it's a meaningless prefix, just ignore it
1224 5 100       79 length $new_prefix and $self->prefix($new_prefix);
1225              
1226 5         120 my $err;
1227 5         72 my $ok= eval { $EVAL_SHIM->($cb); 1 }
  4         20  
1228 5 100 50     22 or do { $err = $@ || "Zombie Error"; };
  1         21  
1229              
1230             # restore app prefix
1231 5         89 $self->prefix($app_prefix);
1232              
1233 5 100       411 $ok or croak "Unable to run the callback for prefix '$prefix': $err";
1234             }
1235              
1236             sub add_route {
1237 617     617 1 1795 my $self = shift;
1238 617         2431 my %route_attrs = @_;
1239              
1240             my $route = Dancer2::Core::Route->new(
1241             type_library => $self->config->{type_library},
1242 617         12190 prefix => $self->prefix,
1243             %route_attrs,
1244             );
1245              
1246 617         54164 my $method = $route->method;
1247              
1248 617         1230 push @{ $self->routes->{$method} }, $route;
  617         11303  
1249              
1250 617         9235 return $route;
1251             }
1252              
1253             sub route_exists {
1254 0     0 1 0 my $self = shift;
1255 0         0 my $route = shift;
1256              
1257 0         0 my $routes = $self->routes->{ $route->method };
1258              
1259 0         0 foreach my $existing_route (@$routes) {
1260 0 0       0 $existing_route->spec_route eq $route->spec_route
1261             and return 1;
1262             }
1263              
1264 0         0 return 0;
1265             }
1266              
1267             sub routes_regexps_for {
1268 1     1 1 684 my $self = shift;
1269 1         3 my $method = shift;
1270              
1271 1         2 return [ map $_->regexp, @{ $self->routes->{$method} } ];
  1         24  
1272             }
1273              
1274             sub cookie {
1275 548     548 0 1093 my $self = shift;
1276              
1277 548 50       3179 @_ == 1 and return $self->request->cookies->{ $_[0] };
1278              
1279             # writer
1280 0         0 my ( $name, $value, %options ) = @_;
1281 0         0 my $c =
1282             Dancer2::Core::Cookie->new( name => $name, value => $value, %options );
1283 0         0 $self->response->push_header( 'Set-Cookie' => $c->to_header );
1284             }
1285              
1286             sub redirect {
1287 26     26 1 62 my $self = shift;
1288 26         52 my $destination = shift;
1289 26         50 my $status = shift;
1290              
1291 26 100       100 if ($destination =~ m{^/(?!/)}) {
1292             # If the app is mounted to something other than "/", we must
1293             # preserve its path.
1294 12         95 my $script_name = $self->request->script_name;
1295 12         102 $script_name =~ s{/$}{}; # Remove trailing slash (if present).
1296 12         35 $destination = $script_name . $destination;
1297             }
1298              
1299 26         452 $self->response->redirect( $destination, $status );
1300              
1301             # Short circuit any remaining before hook / route code
1302             # ('pass' and after hooks are still processed)
1303 26 50       3892 $self->has_with_return
1304             and $self->with_return->($self->response);
1305             }
1306              
1307             sub halt {
1308 7     7 1 10 my $self = shift;
1309 7         136 $self->response->halt( @_ );
1310              
1311             # Short citcuit any remaining hook/route code
1312 7 50       336 $self->has_with_return
1313             and $self->with_return->($self->response);
1314             }
1315              
1316             sub pass {
1317 2     2 1 6 my $self = shift;
1318 2         39 $self->response->pass;
1319              
1320             # Short citcuit any remaining hook/route code
1321 2 50       104 $self->has_with_return
1322             and $self->with_return->($self->response);
1323             }
1324              
1325             sub forward {
1326 44     44 1 91 my $self = shift;
1327 44         97 my $url = shift;
1328 44         85 my $params = shift;
1329 44         72 my $options = shift;
1330              
1331 44         165 my $new_request = $self->make_forward_to( $url, $params, $options );
1332              
1333 44 50       278 $self->has_with_return
1334             and $self->with_return->($new_request);
1335              
1336             # nothing else will run after this
1337             }
1338              
1339             # Create a new request which is a clone of the current one, apart
1340             # from the path location, which points instead to the new location
1341             sub make_forward_to {
1342 53     53 0 196 my $self = shift;
1343 53         96 my $url = shift;
1344 53         100 my $params = shift;
1345 53         82 my $options = shift;
1346              
1347 53         156 my $overrides = { PATH_INFO => $url };
1348             exists $options->{method} and
1349 53 100       186 $overrides->{REQUEST_METHOD} = $options->{method};
1350              
1351             # "clone" the existing request
1352 53         263 my $new_request = $self->request->_shallow_clone( $params, $overrides );
1353              
1354             # If a session object was created during processing of the original request
1355             # i.e. a session object exists but no cookie existed
1356             # add a cookie so the dispatcher can assign the session to the appropriate app
1357 53         1242 my $engine = $self->session_engine;
1358 53 100 66     1591 $engine && $self->_has_session or return $new_request;
1359 11         38 my $name = $engine->cookie_name;
1360 11 100       26 exists $new_request->cookies->{$name} and return $new_request;
1361 10         207 $new_request->cookies->{$name} =
1362             Dancer2::Core::Cookie->new( name => $name, value => $self->session->id );
1363              
1364 10         34 return $new_request;
1365             }
1366              
1367 1     1 1 1996 sub app { shift }
1368              
1369             # DISPATCHER
1370             sub to_app {
1371 203     203 0 1039 my $self = shift;
1372              
1373             # build engines
1374             {
1375 203         475 for ( qw<logger session template> ) {
  203         731  
1376 609         19904 my $attr = "${_}_engine";
1377 609         12564 $self->$attr;
1378             }
1379              
1380             # the serializer engine does not have a default
1381             # and is the only engine that can actually not have a value
1382 203 100       18686 if ( $self->config->{'serializer'} ) {
1383 21         759 $self->serializer_engine;
1384             }
1385             }
1386              
1387 203         3534 $self->finish;
1388              
1389             my $psgi = sub {
1390 597     597   1333374 my $env = shift;
1391              
1392             # pre-request sanity check
1393 597         1932 my $method = uc $env->{'REQUEST_METHOD'};
1394 597 100       2483 $Dancer2::Core::Types::supported_http_methods{$method}
1395             or return [
1396             405,
1397             [ 'Content-Type' => 'text/plain' ],
1398             [ "Method Not Allowed\n\n$method is not supported." ]
1399             ];
1400              
1401 595         1010 my $response;
1402             eval {
1403 595         4263 $EVAL_SHIM->(sub{ $response = $self->dispatch($env)->to_psgi });
  595         2085  
1404 595         5284 1;
1405 595 50       1089 } or do {
1406 0   0     0 my $err = $@ || "Zombie Error";
1407             return [
1408 0         0 500,
1409             [ 'Content-Type' => 'text/plain' ],
1410             [ "Internal Server Error\n\n$err" ],
1411             ];
1412             };
1413              
1414 595         6540 return $response;
1415 203         1298 };
1416              
1417             # Only add static content handler if required
1418 203 100       3705 if ( $self->config->{'static_handler'} ) {
1419             # Use App::File to "serve" the static content
1420             my $static_app = Plack::App::File->new(
1421             root => $self->config->{public_dir},
1422 8     8   1925 content_type => sub { $self->mime_type->for_file( $_[0] ) },
1423 112         2929 )->to_app;
1424             # Conditionally use the static handler wrapped with ConditionalGET
1425             # when the file exists. Otherwise the request passes into our app.
1426             $psgi = Plack::Middleware::Conditional->wrap(
1427             $psgi,
1428 429     429   2132270 condition => sub { -f path( $self->config->{public_dir}, shift->{PATH_INFO} ) },
1429 112     112   9135 builder => sub { Plack::Middleware::ConditionalGET->wrap( $static_app ) },
1430 112         7280 );
1431             }
1432              
1433             # Wrap with common middleware
1434 203 100       9430 if ( ! $self->config->{'no_default_middleware'} ) {
1435             # FixMissingBodyInRedirect
1436 199         4073 $psgi = Plack::Middleware::FixMissingBodyInRedirect->wrap( $psgi );
1437             # Apply Head. After static so a HEAD request on static content DWIM.
1438 199         9779 $psgi = Plack::Middleware::Head->wrap( $psgi );
1439             }
1440              
1441 203         8757 return $psgi;
1442             }
1443              
1444             sub dispatch {
1445 595     595 0 1093 my $self = shift;
1446 595         1020 my $env = shift;
1447              
1448 595         2165 my $runner = Dancer2::runner();
1449 595         1090 my $request;
1450 595         1019 my $request_built_successfully = eval {
1451             $EVAL_SHIM->(sub {
1452 595   100 595   4226 $request = $runner->{'internal_request'} || $self->build_request($env);
1453 595         2997 });
1454 591         2784 1;
1455             };
1456             # Catch bad content causing deserialization to fail when building the request
1457 595 100       2396 if ( ! $request_built_successfully ) {
1458 4         12 my $err = $@;
1459 4         23 Scalar::Util::weaken(my $app = $self);
1460 4         47 return Dancer2::Core::Error->new(
1461             app => $app,
1462             message => $err,
1463             status => 400, # 400 Bad request (dont send again), rather than 500
1464             )->throw;
1465             }
1466              
1467 591         14591 my $cname = $self->session_engine->cookie_name;
1468 591         7617 my $defined_engines = $self->defined_engines;
1469              
1470             DISPATCH:
1471 591         30645 while (1) {
1472 618         2773 my $http_method = lc $request->method;
1473 618         5291 my $path_info = $request->path_info;
1474              
1475             # Add request to app and engines
1476 618         4685 $self->set_request($request, $defined_engines);
1477              
1478 618         68628 $self->log( core => "looking for $http_method $path_info" );
1479              
1480             ROUTE:
1481 618         1320 foreach my $route ( @{ $self->routes->{$http_method} } ) {
  618         10512  
1482             #warn "testing route " . $route->regexp . "\n";
1483             # TODO store in route cache
1484              
1485             # go to the next route if no match
1486 1278 100       8685 my $match = $route->match($request)
1487             or next ROUTE;
1488              
1489 554         19301 $request->_set_route_params($match);
1490 554         2431 $request->_set_route_parameters($match);
1491 554         22000 $request->_set_route($route);
1492              
1493             # Add session to app *if* we have a session and the request
1494             # has the appropriate cookie header for _this_ app.
1495 554 100       1988 if ( my $sess = $runner->{'internal_sessions'}{$cname} ) {
1496 6         130 $self->set_session($sess);
1497             }
1498              
1499             # calling the actual route
1500 554         1155 my $response;
1501              
1502             # this is very evil, but allows breaking out of multiple stack
1503             # frames without throwing an exception. Avoiding exceptions means
1504             # a naive eval won't swallow our flow control mechanisms, and
1505             # avoids __DIE__ handlers. It also prevents some cleanup routines
1506             # from working, since they are expecting control to return to them
1507             # after an eval.
1508             DANCER2_CORE_APP_ROUTE_RETURN: {
1509 554 50       964 if (!$self->has_with_return) {
  554         2294  
1510             $self->set_with_return(sub {
1511 103     103   458 $response = shift;
1512 145     145   1496 no warnings 'exiting';
  145         443  
  145         134669  
1513 103         648 last DANCER2_CORE_APP_ROUTE_RETURN;
1514 554         3562 });
1515             }
1516 554         1904 $response = $self->_dispatch_route($route);
1517             };
1518              
1519             # ensure we clear the with_return handler
1520 554         11526 $self->clear_with_return;
1521              
1522             # handle forward requests
1523 554 100       5642 if ( ref $response eq 'Dancer2::Core::Request' ) {
1524             # this is actually a request, not response
1525             # however, we need to clean up the request & response
1526 44         802 $self->clear_request;
1527 44         903 $self->clear_response;
1528              
1529             # this is in case we're asked for an old-style dispatching
1530 44 100       462 if ( $runner->{'internal_dispatch'} ) {
1531             # Get the session object from the app before we clean up
1532             # the request context, so we can propagate this to the
1533             # next dispatch cycle (if required).
1534             $self->_has_session
1535 17 100       176 and $runner->{'internal_sessions'}{$cname} =
1536             $self->session;
1537              
1538 17         93 $runner->{'internal_forward'} = 1;
1539 17         39 $runner->{'internal_request'} = $response;
1540 17         46 return $self->response_not_found($request);
1541             }
1542              
1543 27         65 $request = $response;
1544 27         79 next DISPATCH;
1545             }
1546              
1547             # from here we assume the response is a Dancer2::Core::Response
1548              
1549             # halted response, don't process further
1550 510 100       8615 if ( $response->is_halted ) {
1551 34         413 $self->cleanup;
1552 34         559 delete $runner->{'internal_request'};
1553 34         2339 return $response;
1554             }
1555              
1556             # pass the baton if the response says so...
1557 476 100       10524 if ( $response->has_passed ) {
1558             ## A previous route might have used splat, failed
1559             ## this needs to be cleaned from the request.
1560             exists $request->{_params}{splat}
1561 9 100       91 and delete $request->{_params}{splat};
1562              
1563 9         145 $response->has_passed(0); # clear for the next round
1564              
1565             # clear the content because if you pass it,
1566             # the next route is in charge of catching it
1567 9         357 $response->clear_content;
1568 9         59 next ROUTE;
1569             }
1570              
1571             # it's just a regular response
1572 467         14510 $self->execute_hook( 'core.app.after_request', $response );
1573 467         1852 $self->cleanup;
1574 467         3047 delete $runner->{'internal_request'};
1575              
1576 467         5074 return $response;
1577             }
1578              
1579             # we don't actually want to continue the loop
1580 73         219 last;
1581             }
1582              
1583             # No response! ensure Core::Dispatcher recognizes this failure
1584             # so it can try the next Core::App
1585             # and set the created request so we don't create it again
1586             # (this is important so we don't ignore the previous body)
1587 73 100       243 if ( $runner->{'internal_dispatch'} ) {
1588 51         127 $runner->{'internal_404'} = 1;
1589 51         128 $runner->{'internal_request'} = $request;
1590             }
1591              
1592             # Render 404 response, cleanup, and return the response.
1593 73         237 my $response = $self->response_not_found($request);
1594 73         240 $self->cleanup;
1595 73         730 return $response;
1596             }
1597              
1598             sub build_request {
1599 546     546 0 1451 my ( $self, $env ) = @_;
1600              
1601             # If we have an app, send the serialization engine
1602             my $request = Dancer2::Core::Request->new(
1603             env => $env,
1604 546 100 100     1919 is_behind_proxy => $self->settings->{'behind_proxy'} || 0,
1605              
1606             $self->has_serializer_engine
1607             ? ( serializer => $self->serializer_engine )
1608             : (),
1609             );
1610              
1611 542         3352 return $request;
1612             }
1613              
1614             # Call any before hooks then the matched route.
1615             sub _dispatch_route {
1616 554     554   1283 my ( $self, $route ) = @_;
1617              
1618 554         1044 local $@;
1619             eval {
1620             $EVAL_SHIM->(sub {
1621 554     554   14839 $self->execute_hook( 'core.app.before_request', $self );
1622 554         4244 });
1623 545         7756 1;
1624 554 100       1137 } or do {
1625 4   50     162 my $err = $@ || "Zombie Error";
1626 4         26 return $self->response_internal_error($err);
1627             };
1628 545         9277 my $response = $self->response;
1629              
1630 545 100       12354 if ( $response->is_halted ) {
1631 2         25 return $self->_prep_response( $response );
1632             }
1633              
1634             eval {
1635 543     543   3256 $EVAL_SHIM->(sub{ $response = $route->execute($self) });
  543         5845  
1636 432         2274 1;
1637 543 100       4550 } or do {
1638 13   50     717 my $err = $@ || "Zombie Error";
1639 13         69 return $self->response_internal_error($err);
1640             };
1641              
1642 432         2844 return $response;
1643             }
1644              
1645             sub _prep_response {
1646 455     455   1295 my ( $self, $response, $content ) = @_;
1647              
1648             # The response object has no back references to the content or app
1649             # Update the default_content_type of the response if any value set in
1650             # config so it can be applied when the response is encoded/returned.
1651 455         10204 my $config = $self->config;
1652 455 50 33     5891 if ( exists $config->{content_type}
1653             and my $ct = $config->{content_type} ) {
1654 455         8121 $response->default_content_type($ct);
1655             }
1656              
1657             # if we were passed any content, set it in the response
1658 455 100       22935 defined $content && $response->content($content);
1659 455         47368 return $response;
1660             }
1661              
1662             sub response_internal_error {
1663 17     17 0 64 my ( $self, $error ) = @_;
1664              
1665 17         514 $self->execute_hook( 'core.app.route_exception', $self, $error );
1666 17         267 $self->log( error => "Route exception: $error" );
1667              
1668 17         285 local $Dancer2::Core::Route::REQUEST = $self->request;
1669 17         329 local $Dancer2::Core::Route::RESPONSE = $self->response;
1670              
1671 17         418 return Dancer2::Core::Error->new(
1672             app => $self,
1673             status => 500,
1674             exception => $error,
1675             )->throw;
1676             }
1677              
1678             sub response_not_found {
1679 99     99 0 238 my ( $self, $request ) = @_;
1680              
1681 99         281 $self->set_request($request);
1682              
1683 99         9438 local $Dancer2::Core::Route::REQUEST = $self->request;
1684 99         1743 local $Dancer2::Core::Route::RESPONSE = $self->response;
1685              
1686 99         7245 my $response = Dancer2::Core::Error->new(
1687             app => $self,
1688             status => 404,
1689             message => $request->path,
1690             )->throw;
1691              
1692 99         1215 $self->cleanup;
1693              
1694 99         905 return $response;
1695             }
1696              
1697             1;
1698              
1699             __END__
1700              
1701             =pod
1702              
1703             =encoding UTF-8
1704              
1705             =head1 NAME
1706              
1707             Dancer2::Core::App - encapsulation of Dancer2 packages
1708              
1709             =head1 VERSION
1710              
1711             version 1.0.0
1712              
1713             =head1 DESCRIPTION
1714              
1715             Everything a package that uses Dancer2 does is encapsulated into a
1716             C<Dancer2::Core::App> instance. This class defines all that can be done in such
1717             objects.
1718              
1719             Mainly, it will contain all the route handlers, the configuration settings and
1720             the hooks that are defined in the calling package.
1721              
1722             Note that with Dancer2, everything that is done within a package is scoped to
1723             that package, thanks to that encapsulation.
1724              
1725             =head1 ATTRIBUTES
1726              
1727             =head2 plugins
1728              
1729             =head2 runner_config
1730              
1731             =head2 default_config
1732              
1733             =head2 with_return
1734              
1735             Used to cache the coderef that will return from back to the dispatcher, across
1736             an arbitrary number of stack frames.
1737              
1738             =head2 destroyed_session
1739              
1740             We cache a destroyed session here; once this is set we must not attempt to
1741             retrieve the session from the cookie in the request. If no new session is
1742             created, this is set (with expiration) as a cookie to force the browser to
1743             expire the cookie.
1744              
1745             =head1 METHODS
1746              
1747             =head2 has_session
1748              
1749             Returns true if session engine has been defined and if either a session
1750             object has been instantiated or if a session cookie was found and not
1751             subsequently invalidated.
1752              
1753             =head2 change_session_id
1754              
1755             Changes the session ID used by the current session. This should be used on
1756             any change of privilege level, for example on login. Returns the new session
1757             ID.
1758              
1759             =head2 destroy_session
1760              
1761             Destroys the current session and ensures any subsequent session is created
1762             from scratch and not from the request session cookie
1763              
1764             =head2 register_plugin
1765              
1766             =head2 with_plugins( @plugin_names )
1767              
1768             Creates instances of the given plugins and tie them to the app.
1769             The plugin classes are automatically loaded.
1770             Returns the newly created plugins.
1771              
1772             The plugin names are expected to be without the leading C<Dancer2::Plugin>.
1773             I.e., use C<Foo> to mean C<Dancer2::Plugin::Foo>.
1774              
1775             If a given plugin is already tied to the app, the already-existing
1776             instance will be used and returned by C<with_plugins> (think of it
1777             as using a role).
1778              
1779             my @plugins = $app->with_plugins( 'Foo', 'Bar' );
1780              
1781             # now $app uses the plugins Dancer2::Plugin::Foo
1782             # and Dancer2::Plugin::Bar
1783              
1784             =head2 with_plugin( $plugin_name )
1785              
1786             Just like C<with_plugin>, but for a single plugin.
1787              
1788             my $plugin = $app->with_plugin('Foo');
1789              
1790             =head2 add_route
1791              
1792             Register a new route handler.
1793              
1794             $app->add_route(
1795             method => 'get',
1796             regexp => '/somewhere',
1797             code => sub { ... },
1798             options => $conditions,
1799             );
1800              
1801             Returns a new L<< Dancer2::Core::Route >> object created with the passed
1802             arguments.
1803              
1804             =head2 route_exists
1805              
1806             Returns a true value if a route already exists, otherwise false.
1807              
1808             my $route = Dancer2::Core::Route->new(...);
1809             if ($app->route_exists($route)) {
1810             ...
1811             }
1812              
1813             =head2 routes_regexps_for
1814              
1815             Sugar for getting the ordered list of all registered route regexps by method.
1816              
1817             my $regexps = $app->routes_regexps_for( 'get' );
1818              
1819             Returns an ArrayRef with the results.
1820              
1821             =head2 redirect($destination, $status)
1822              
1823             Sets a redirect in the response object. If $destination is not an absolute URI, then it will
1824             be made into an absolute URI, relative to the URI in the request.
1825              
1826             =head2 halt
1827              
1828             Flag the response object as 'halted'.
1829              
1830             If called during request dispatch, immediately returns the response
1831             to the dispatcher and after hooks will not be run.
1832              
1833             =head2 pass
1834              
1835             Flag the response object as 'passed'.
1836              
1837             If called during request dispatch, immediately returns the response
1838             to the dispatcher.
1839              
1840             =head2 forward
1841              
1842             Create a new request which is a clone of the current one, apart
1843             from the path location, which points instead to the new location.
1844             This is used internally to chain requests using the forward keyword.
1845              
1846             This method takes 3 parameters: the url to forward to, followed by an
1847             optional hashref of parameters added to the current request parameters,
1848             followed by a hashref of options regarding the redirect, such as
1849             C<method> to change the request method.
1850              
1851             For example:
1852              
1853             forward '/login', { login_failed => 1 }, { method => 'GET' });
1854              
1855             =head2 app
1856              
1857             Returns itself. This is simply available as a shim to help transition from
1858             a previous version in which hooks were sent a context object (originally
1859             C<Dancer2::Core::Context>) which has since been removed.
1860              
1861             # before
1862             hook before => sub {
1863             my $ctx = shift;
1864             my $app = $ctx->app;
1865             };
1866              
1867             # after
1868             hook before => sub {
1869             my $app = shift;
1870             };
1871              
1872             This meant that C<< $app->app >> would fail, so this method has been provided
1873             to make it work.
1874              
1875             # now
1876             hook before => sub {
1877             my $WannaBeCtx = shift;
1878             my $app = $WannaBeContext->app; # works
1879             };
1880              
1881             =head2 lexical_prefix
1882              
1883             Allow for setting a lexical prefix
1884              
1885             $app->lexical_prefix('/blog', sub {
1886             ...
1887             });
1888              
1889             All the route defined within the callback will have a prefix appended to the
1890             current one.
1891              
1892             =head2 C< $SIG{__DIE__} > Compatibility via C< $Dancer2::Core::App::EVAL_SHIM >
1893              
1894             If an installation wishes to use C< $SIG{__DIE__} > hooks to enhance
1895             their error handling then it may be required to ensure that certain
1896             bookkeeping code is executed within every C<eval BLOCK> that Dancer2
1897             performs. This can be accomplished by overriding the global variable
1898             C<$Dancer2::Core::App::EVAL_SHIM> with a subroutine which does whatever
1899             logic is required.
1900              
1901             This routine must perform the equivalent of the following subroutine:
1902              
1903             our $EVAL_SHIM = sub {
1904             my $code = shift;
1905             return $code->(@_);
1906             };
1907              
1908             An example of overriding this sub might be as follows:
1909              
1910             $Dancer2::Core::App::EVAL_SHIM = sub {
1911             my $code = shift;
1912             local $IGNORE_EVAL_COUNTER = $IGNORE_EVAL_COUNTER + 1;
1913             return $code->(@_);
1914             };
1915              
1916             B<Note:> that this is a GLOBAL setting, which must be set up before
1917             any form of dispatch or use of Dancer2.
1918              
1919             =head1 AUTHOR
1920              
1921             Dancer Core Developers
1922              
1923             =head1 COPYRIGHT AND LICENSE
1924              
1925             This software is copyright (c) 2023 by Alexis Sukrieh.
1926              
1927             This is free software; you can redistribute it and/or modify it under
1928             the same terms as the Perl 5 programming language system itself.
1929              
1930             =cut