File Coverage

blib/lib/Dancer2/Core/App.pm
Criterion Covered Total %
statement 675 705 95.7
branch 222 258 86.0
condition 78 124 62.9
subroutine 104 110 94.5
pod 15 46 32.6
total 1094 1243 88.0


line stmt bran cond sub pod time code
1             # ABSTRACT: encapsulation of Dancer2 packages
2             package Dancer2::Core::App;
3             $Dancer2::Core::App::VERSION = '2.0.1';
4 156     156   1013808 use Moo;
  156         1093527  
  156         1068  
5 156     156   230743 use Carp qw;
  156         332  
  156         10783  
6 156     156   1012 use Scalar::Util 'blessed';
  156         348  
  156         9382  
7 156     156   896 use List::Util ();
  156         536  
  156         3905  
8 156     156   5832 use Module::Runtime 'is_module_name';
  156         10635  
  156         1571  
9 156     156   72736 use Safe::Isa;
  156         83167  
  156         25533  
10 156     156   72838 use Sub::Quote;
  156         1052283  
  156         13714  
11 156     156   1411 use File::Spec;
  156         344  
  156         5707  
12 156     156   785 use Module::Runtime qw< require_module use_module >;
  156         393  
  156         1319  
13 156     156   68573 use Ref::Util qw< is_ref is_arrayref is_globref is_scalarref is_regexpref >;
  156         265342  
  156         15250  
14 156     156   1212 use Sub::Util qw/ set_subname subname /;
  156         336  
  156         14825  
15              
16 156     156   81519 use Plack::App::File;
  156         3471898  
  156         7491  
17 156     156   78271 use Plack::Middleware::FixMissingBodyInRedirect;
  156         1402530  
  156         7458  
18 156     156   75968 use Plack::Middleware::Head;
  156         57150  
  156         6039  
19 156     156   75308 use Plack::Middleware::Conditional;
  156         48920  
  156         6130  
20 156     156   77386 use Plack::Middleware::ConditionalGET;
  156         120265  
  156         7141  
21              
22 156     156   72006 use Dancer2::FileUtils 'path';
  156         444  
  156         13380  
23 156     156   80424 use Dancer2::ConfigReader;
  156         910  
  156         7976  
24 156     156   1572 use Dancer2::Core;
  156         352  
  156         4081  
25 156     156   91578 use Dancer2::Core::Cookie;
  156         797  
  156         8112  
26 156     156   111448 use Dancer2::Core::Error;
  156         826  
  156         8843  
27 156     156   1457 use Dancer2::Core::Types;
  156         348  
  156         1701  
28 156     156   2172244 use Dancer2::Core::Route;
  156         906  
  156         7712  
29 156     156   88441 use Dancer2::Core::Hook;
  156         791  
  156         7161  
30 156     156   102199 use Dancer2::Core::Request;
  156         875  
  156         9527  
31 156     156   1045 use Dancer2::Core::Factory;
  156         327  
  156         4887  
32              
33 156     156   91081 use Dancer2::Handler::File;
  156         938  
  156         1596534  
34              
35             our $EVAL_SHIM; $EVAL_SHIM ||= sub {
36             my $code = shift;
37             $code->(@_);
38             };
39              
40              
41             # we have hooks here
42             with qw<
43             Dancer2::Core::Role::Hookable
44             Dancer2::Core::Role::HasConfig
45             Dancer2::Core::Role::HasLocation
46             Dancer2::Core::Role::HasEnvironment
47             >;
48              
49 282     282 0 2499 sub supported_engines { [ qw ] }
50              
51             sub with_plugins {
52 37     37 1 203 my ( $self, @plugins ) = @_;
53 37         483 return map $self->_with_plugin($_), @plugins;
54              
55             }
56              
57             sub _with_plugin {
58 37     37   229 my( $self, $plugin ) = @_;
59              
60 37 100       323 if ( is_ref($plugin) ) {
61             # passing the plugin as an already-created object
62              
63             # already loaded?
64 1 50       4 if( my ( $already ) = grep { ref($plugin) eq ref $_; } @{ $self->plugins } ) {
  2         18  
  1         35  
65 0 0       0 die "trying to load two different objects for plugin ". ref $plugin
66             if refaddr($plugin) != refaddr $already ;
67              
68             }
69             else {
70 1         3 push @{ $self->plugins }, $plugin;
  1         26  
71             }
72              
73 1         12 return $plugin;
74             }
75              
76             # short plugin names get Dancer2::Plugin:: prefix
77             # plugin names starting with a '+' are full package names
78 36 100       342 if ( $plugin !~ s/^\+// ) {
79 7         47 $plugin =~ s/^(?!Dancer2::Plugin::)/Dancer2::Plugin::/;
80             }
81              
82             # check if it's already there
83 36 100       82 if( my ( $already ) = grep { $plugin eq ref $_ } @{ $self->plugins } ) {
  12         171  
  36         1245  
84 2         15 return $already;
85             }
86              
87 34         666 push @{ $self->plugins },
  34         748  
88             $plugin = use_module($plugin)->new( app => $self );
89              
90 34         618 return $plugin;
91             }
92              
93             sub with_plugin {
94 37     37 1 13291 my( $self, $plugin ) = @_;
95              
96 37 50       156 croak "expected a single argument"
97             unless @_ == 2;
98              
99 37         258 ( $self->with_plugins($plugin) )[0];
100             }
101              
102             has _factory => (
103             is => 'ro',
104             isa => InstanceOf['Dancer2::Core::Factory'],
105             lazy => 1,
106             default => sub { Dancer2::Core::Factory->new },
107             );
108              
109             has logger_engine => (
110             is => 'ro',
111             isa => ConsumerOf['Dancer2::Core::Role::Logger'],
112             lazy => 1,
113             builder => '_build_logger_engine',
114             writer => 'set_logger_engine',
115             );
116              
117             has session_engine => (
118             is => 'ro',
119             isa => ConsumerOf['Dancer2::Core::Role::SessionFactory'],
120             lazy => 1,
121             builder => '_build_session_engine',
122             writer => 'set_session_engine',
123             );
124              
125             has template_engine => (
126             is => 'ro',
127             isa => ConsumerOf['Dancer2::Core::Role::Template'],
128             lazy => 1,
129             builder => '_build_template_engine',
130             writer => 'set_template_engine',
131             );
132              
133             has serializer_engine => (
134             is => 'ro',
135             isa => ConsumerOf['Dancer2::Core::Role::Serializer'],
136             lazy => 1,
137             builder => '_build_serializer_engine',
138             writer => 'set_serializer_engine',
139             predicate => 'has_serializer_engine',
140             );
141              
142             has '+local_triggers' => (
143             default => sub {
144             my $self = shift;
145             my $triggers = {
146             # general triggers we want to allow, besides engines
147             views => sub {
148             my $self = shift;
149             my $value = shift;
150             $self->template_engine->views($value);
151             },
152              
153             layout => sub {
154             my $self = shift;
155             my $value = shift;
156             $self->template_engine->layout($value);
157             },
158              
159             layout_dir => sub {
160             my $self = shift;
161             my $value = shift;
162             $self->template_engine->layout_dir($value);
163             },
164              
165             log => sub {
166             my ( $self, $value, $config ) = @_;
167              
168             # This will allow to set the log level
169             # using: set log => warning
170             $self->logger_engine->log_level($value);
171             },
172             };
173              
174             foreach my $engine ( @{ $self->supported_engines } ) {
175             $triggers->{$engine} = sub {
176             my $self = shift;
177             my $value = shift;
178             my $config = shift;
179              
180             is_ref($value) and return $value;
181              
182             my $build_method = "_build_${engine}_engine";
183             my $setter_method = "set_${engine}_engine";
184             my $engine_instance = $self->$build_method( $value, $config );
185              
186             # set the engine with the new value from the builder
187             $self->$setter_method($engine_instance);
188              
189             return $engine_instance;
190             };
191             }
192              
193             return $triggers;
194             },
195             );
196              
197             sub _build_logger_engine {
198 178     178   7403 my $self = shift;
199 178         734 my $value = shift;
200 178         680 my $config = shift;
201              
202 178 100       4818 defined $config or $config = $self->config;
203 178 100       2992 defined $value or $value = $config->{logger};
204              
205 178 100       927 is_ref($value) and return $value;
206              
207             # XXX This is needed for the tests that create an app without
208             # a runner.
209 177 50       1268 defined $value or $value = 'console';
210              
211 177 100       1296 is_module_name($value)
212             or croak "Cannot load logger engine '$value': illegal module name";
213              
214 176         4760 my $engine_options =
215             $self->_get_config_for_engine( logger => $value, $config );
216              
217             my $logger = $self->_factory->create(
218             logger => $value,
219 176         5196 %{$engine_options},
  176         7217  
220             location => $self->config_reader->config_location,
221             environment => $self->environment,
222             app_name => $self->name,
223             postponed_hooks => $self->postponed_hooks
224             );
225              
226 176 100       6303 exists $config->{log} and $logger->log_level($config->{log});
227              
228 176         8091 return $logger;
229             }
230              
231             sub _build_session_engine {
232 187     187   47148 my $self = shift;
233 187         970 my $value = shift;
234 187         1380 my $config = shift;
235              
236 187 100       5097 defined $config or $config = $self->config;
237 187 100 100     3539 defined $value or $value = $config->{'session'} || 'simple';
238              
239 187 100       843 is_ref($value) and return $value;
240              
241 184 100       1560 is_module_name($value)
242             or croak "Cannot load session engine '$value': illegal module name";
243              
244 183         4414 my $engine_options =
245             $self->_get_config_for_engine( session => $value, $config );
246              
247 183         813 Scalar::Util::weaken( my $weak_self = $self );
248              
249             # Note that engine options will replace the default session_dir (if provided).
250             return $self->_factory->create(
251             session => $value,
252             session_dir => path( $self->config->{appdir}, 'sessions' ),
253 183         2651 %{$engine_options},
254             postponed_hooks => $self->postponed_hooks,
255              
256 3     3   40 log_cb => sub { $weak_self->log(@_) },
257 183         5840 );
258             }
259              
260             sub _build_template_engine {
261 175     175   5255 my $self = shift;
262 175         481 my $value = shift;
263 175         459 my $config = shift;
264              
265 175 100       4597 defined $config or $config = $self->config;
266 175 100       2294 defined $value or $value = $config->{'template'};
267              
268 175 50       719 defined $value or return;
269 175 50       675 is_ref($value) and return $value;
270              
271 175 100       980 is_module_name($value)
272             or croak "Cannot load template engine '$value': illegal module name";
273              
274 174         4078 my $engine_options =
275             $self->_get_config_for_engine( template => $value, $config );
276              
277             my $engine_attrs = {
278             config => $engine_options,
279             layout => $config->{layout},
280             layout_dir => ( $config->{layout_dir} || 'layouts' ),
281             views => $config->{views},
282 174   50     2596 };
283              
284 174         685 Scalar::Util::weaken( my $weak_self = $self );
285              
286             return $self->_factory->create(
287             template => $value,
288 174         4333 %{$engine_attrs},
289             postponed_hooks => $self->postponed_hooks,
290              
291 7     7   58 log_cb => sub { $weak_self->log(@_) },
292 174         4794 );
293             }
294              
295             sub _build_serializer_engine {
296 22     22   73 my $self = shift;
297 22         57 my $value = shift;
298 22         49 my $config = shift;
299              
300 22 50       340 defined $config or $config = $self->config;
301 22 50       86 defined $value or $value = $config->{serializer};
302              
303 22 50       78 defined $value or return;
304 22 50       85 is_ref($value) and return $value;
305              
306 22         142 my $engine_options =
307             $self->_get_config_for_engine( serializer => $value, $config );
308              
309 22         79 Scalar::Util::weaken( my $weak_self = $self );
310              
311             return $self->_factory->create(
312             serializer => $value,
313             config => $engine_options,
314             postponed_hooks => $self->postponed_hooks,
315              
316 6     6   61 log_cb => sub { $weak_self->log(@_) },
317 22         1030 );
318             }
319              
320             sub _get_config_for_engine {
321 560     560   2506 my $self = shift;
322 560         1322 my $engine = shift;
323 560         1273 my $name = shift;
324 560         1432 my $config = shift;
325              
326 560 100 100     4233 defined $config->{'engines'} && defined $config->{'engines'}{$engine}
327             or return {};
328              
329             # try both camelized name and regular name
330 24         65 my $engine_config = {};
331 24         180 foreach my $engine_name ( $name, Dancer2::Core::camelize($name) ) {
332 31 100       458 if ( defined $config->{'engines'}{$engine}{$engine_name} ) {
333 20         70 $engine_config = $config->{'engines'}{$engine}{$engine_name};
334 20         55 last;
335             }
336             }
337              
338 24         87 return $engine_config;
339             }
340              
341             has postponed_hooks => (
342             is => 'ro',
343             isa => HashRef,
344             default => sub { {} },
345             );
346              
347             # TODO I'd be happier with a HashRef, really
348             has plugins => (
349             is => 'rw',
350             isa => ArrayRef,
351             default => sub { [] },
352             );
353              
354             has route_handlers => (
355             is => 'rw',
356             isa => ArrayRef,
357             default => sub { [] },
358             );
359              
360             has name => (
361             is => 'ro',
362             isa => Str,
363             default => sub { (caller(1))[0] },
364             );
365              
366             has request => (
367             is => 'ro',
368             isa => InstanceOf['Dancer2::Core::Request'],
369             writer => '_set_request',
370             clearer => 'clear_request',
371             predicate => 'has_request',
372             );
373              
374             sub set_request {
375 718     718 0 2164 my ($self, $request, $defined_engines) = @_;
376             # typically this is passed in as an optimization within the
377             # dispatch loop but may be called elsewhere
378 718   66     3152 $defined_engines ||= $self->defined_engines;
379             # populate request in app and all engines
380 718         23837 $self->_set_request($request);
381 718         28426 Scalar::Util::weaken( my $weak_request = $request );
382 718         1515 $_->set_request( $weak_request ) for @{$defined_engines};
  718         20649  
383             }
384              
385             has response => (
386             is => 'ro',
387             isa => InstanceOf['Dancer2::Core::Response'],
388             lazy => 1,
389             writer => 'set_response',
390             clearer => 'clear_response',
391             builder => '_build_response',
392             predicate => 'has_response',
393             );
394              
395             has with_return => (
396             is => 'ro',
397             predicate => 1,
398             writer => 'set_with_return',
399             clearer => 'clear_with_return',
400             );
401              
402             has session => (
403             is => 'ro',
404             isa => InstanceOf['Dancer2::Core::Session'],
405             lazy => 1,
406             builder => '_build_session',
407             writer => 'set_session',
408             clearer => 'clear_session',
409             predicate => '_has_session',
410             );
411              
412             has config_reader => (
413             is => 'ro',
414             isa => InstanceOf['Dancer2::ConfigReader'],
415             lazy => 0,
416             builder => '_build_config_reader',
417             );
418              
419             sub _build_config_reader {
420 253     253   4479160 my ($self) = @_;
421             my $cfgr = Dancer2::ConfigReader->new(
422             environment => $self->environment,
423 253   66     7396 location => $ENV{DANCER_CONFDIR} || $self->location,
424             default_config => $self->_build_default_config(),
425             );
426 253         816046 return $cfgr;
427             }
428              
429             has '+config' => (
430             is => 'ro',
431             isa => HashRef,
432             lazy => 1,
433             builder => '_build_config',
434             );
435              
436             sub _build_config {
437 253     253   3550 my ($self) = @_;
438              
439 253         1377 my $config_reader = $self->config_reader;
440 253         6386 my $config = $config_reader->config;
441              
442 251 100 66     12192 if ( $config && $config->{'engines'} ) {
443 2         5 $self->_validate_engine($_) for keys %{ $config->{'engines'} };
  2         19  
444             }
445              
446 250         6450 return $config;
447             }
448              
449             sub _build_response {
450 685     685   8862 my $self = shift;
451             return Dancer2::Core::Response->new(
452 685 100       18674 server_tokens => !$self->config->{'no_server_tokens'},
453             $self->has_serializer_engine
454             ? ( serializer => $self->serializer_engine )
455             : (),
456             );
457             }
458              
459             sub _build_session {
460 93     93   1099 my $self = shift;
461 93         188 my $session;
462              
463             # Find the session engine
464 93         1916 my $engine = $self->session_engine;
465              
466             # find the session cookie if any
467 93 100       948 if ( !$self->has_destroyed_session ) {
468 88         199 my $session_id;
469 88         507 my $session_cookie = $self->cookie( $engine->cookie_name );
470 88 100       1601 defined $session_cookie and
471             $session_id = $session_cookie->value;
472              
473             # if we have a session cookie, try to retrieve the session
474 88 100       324 if ( defined $session_id ) {
475             eval {
476             $EVAL_SHIM->(sub {
477 53     53   347 $session = $engine->retrieve( id => $session_id );
478 53         449 });
479 50         332 1;
480             }
481 53 100       154 or do {
482 3   50     14 my $err = $@ || "Zombie Error";
483 3 50       20 if ( $err !~ /Unable to retrieve session/ ) {
484 0         0 croak "Failed to retrieve session: $err"
485             } else {
486             # XXX we throw away the error entirely? Why?
487             }
488             };
489             }
490             }
491              
492             # create the session if none retrieved
493 93   66     1545 return $session ||= $engine->create();
494             }
495              
496             sub has_session {
497 944     944 1 1797 my $self = shift;
498              
499 944         19791 my $engine = $self->session_engine;
500              
501 944   66     22399 return $self->_has_session
502             || ( $self->cookie( $engine->cookie_name )
503             && !$self->has_destroyed_session );
504             }
505              
506             has destroyed_session => (
507             is => 'ro',
508             isa => InstanceOf ['Dancer2::Core::Session'],
509             predicate => 1,
510             writer => 'set_destroyed_session',
511             clearer => 'clear_destroyed_session',
512             );
513              
514             has 'prep_apps' => (
515             'is' => 'ro',
516             'isa' => ArrayRef,
517             'default' => sub { [] },
518             );
519              
520             sub find_plugin {
521 2     2 0 7 my ( $self, $name ) = @_;
522 2     2   12 my $plugin = List::Util::first { ref($_) eq $name } @{ $self->plugins };
  2         30  
  2         80  
523 2 100       37 $plugin or return;
524 1         6 return $plugin;
525             }
526              
527             sub destroy_session {
528 17     17 1 43 my $self = shift;
529              
530             # Find the session engine
531 17         349 my $engine = $self->session_engine;
532              
533             # Expire session, set the expired cookie and destroy the session
534             # Setting the cookie ensures client gets an expired cookie unless
535             # a new session is created and supercedes it
536 17         415 my $session = $self->session;
537 17         748 $session->expires(-86400); # yesterday
538 17         2127 $engine->destroy( id => $session->id );
539              
540             # Invalidate session cookie in request
541             # and clear session in app and engines
542 17         422 $self->set_destroyed_session($session);
543 17         986 $self->clear_session;
544 17         99 $_->clear_session for @{ $self->defined_engines };
  17         62  
545              
546 17         2109 return;
547             }
548              
549             sub setup_session {
550 118     118 0 255 my $self = shift;
551              
552 118         199 for my $engine ( @{ $self->defined_engines } ) {
  118         403  
553 354 50       18914 $self->has_session ?
554             $engine->set_session( $self->session ) :
555             $engine->clear_session;
556             }
557             }
558              
559             sub change_session_id {
560 5     5 1 29 my $self = shift;
561              
562 5         120 my $session = $self->session;
563              
564             # Find the session engine
565 5         335 my $engine = $self->session_engine;
566              
567 5 100       88 if ($engine->can('_change_id')) {
568              
569             # session engine can change session ID
570 3         15 $engine->change_id( session => $session );
571             }
572             else {
573              
574             # Method order is important in here...
575             #
576             # On session build if there is no destroyed session then the session
577             # builder tries to recreate the session using the existing session
578             # cookie. We really don't want to do that in this case so it is
579             # important to create the new session before the
580             # clear_destroyed_session method is called.
581             #
582             # This sucks.
583             #
584             # Sawyer suggested:
585             #
586             # What if you take the session cookie logic out of that attribute into
587             # another attribute and clear that attribute?
588             # That would force the session rebuilt to rebuilt the attribute and
589             # get a different cookie value, no?
590             #
591             # TODO: think about this some more.
592              
593             # grab data, destroy session and store data again
594 2         6 my %data = %{$session->data};
  2         74  
595              
596             # destroy existing session
597 2         36 $self->destroy_session;
598              
599             # get new session
600 2         48 $session = $self->session;
601              
602             # write data from old session into new
603             # Some engines add session id to data so skip id.
604 2         98 while (my ($key, $value) = each %data ) {
605 2 50       22 $session->write($key => $value) unless $key eq 'id';
606             }
607              
608             # clear out destroyed session - no longer relevant
609 2         111 $self->clear_destroyed_session;
610             }
611              
612 5         142 return $session->id;
613             }
614              
615             has prefix => (
616             is => 'rw',
617             isa => Maybe [Dancer2Prefix],
618             predicate => 1,
619             coerce => sub {
620             my $prefix = shift;
621             defined($prefix) and $prefix eq "/" and return;
622             return $prefix;
623             },
624             );
625              
626             # routes registry, stored by method:
627             has routes => (
628             is => 'rw',
629             isa => HashRef,
630             default => sub {
631             { get => [],
632             head => [],
633             post => [],
634             put => [],
635             del => [],
636             options => [],
637             };
638             },
639             );
640              
641             has 'route_names' => (
642             'is' => 'rw',
643             'isa' => HashRef,
644             'default' => sub { {} },
645             );
646              
647             # add_hook will add the hook to the first "hook candidate" it finds that support
648             # it. If none, then it will try to add the hook to the current application.
649             around add_hook => sub {
650             my $orig = shift;
651             my $self = shift;
652              
653             # saving caller information
654             my ( $package, $file, $line ) = caller(4); # deep to 4 : user's app code
655             my $add_hook_caller = [ $package, $file, $line ];
656              
657             my ($hook) = @_;
658             my $name = $hook->name;
659             my $hook_aliases = $self->all_hook_aliases;
660              
661             # look for an alias
662             defined $hook_aliases->{$name} and $name = $hook_aliases->{$name};
663             $hook->name($name);
664              
665             # if that hook belongs to the app, register it now and return
666             $self->has_hook($name) and return $self->$orig(@_);
667              
668             # at this point the hook name must be formatted like:
669             # '$type.$candidate.$name', eg: 'engine.template.before_render' or
670             # 'plugin.database.before_dbi_connect'
671             my ( $hookable_type, $hookable_name, $hook_name ) = split( /\./, $name );
672              
673             ( defined $hookable_name && defined $hook_name )
674             or croak "Invalid hook name `$name'";
675              
676             grep /^$hookable_type$/, qw(core engine handler plugin)
677             or croak "Unknown hook type `$hookable_type'";
678              
679             # register the hooks for existing hookable candidates
680             foreach my $hookable ( $self->hook_candidates ) {
681             $hookable->has_hook($name) and $hookable->add_hook(@_);
682             }
683              
684             # we register the hook for upcoming objects;
685             # that way, each components that can claim the hook will have a chance
686             # to register it.
687              
688             my $postponed_hooks = $self->postponed_hooks;
689              
690             # Hmm, so the hook was not claimed, at this point we'll cache it and
691             # register it when the owner is instantiated
692             $postponed_hooks->{$hookable_type}{$hookable_name} ||= {};
693             $postponed_hooks->{$hookable_type}{$hookable_name}{$name} ||= {};
694             $postponed_hooks->{$hookable_type}{$hookable_name}{$name}{hook} = $hook;
695             $postponed_hooks->{$hookable_type}{$hookable_name}{$name}{caller} =
696             $add_hook_caller;
697              
698             };
699              
700             around execute_hook => sub {
701             my $orig = shift;
702             my $self = shift;
703              
704             local $Dancer2::Core::Route::REQUEST = $self->request;
705             local $Dancer2::Core::Route::RESPONSE = $self->response;
706              
707             my ( $hook, @args ) = @_;
708             if ( !$self->has_hook($hook) ) {
709             foreach my $cand ( $self->hook_candidates ) {
710             $cand->has_hook($hook) and return $cand->execute_hook(@_);
711             }
712             }
713              
714             return $self->$orig(@_);
715             };
716              
717             sub _build_default_config {
718 253     253   11455 my $self = shift;
719              
720 253   33     7496 my $public = $ENV{DANCER_PUBLIC} || path( $self->location, 'public' );
721             return {
722             content_type => ( $ENV{DANCER_CONTENT_TYPE} || 'text/html' ),
723             charset => ( $ENV{DANCER_CHARSET} || '' ),
724             logger => ( $ENV{DANCER_LOGGER} || 'console' ),
725             views => ( $ENV{DANCER_VIEWS}
726 253   50     9839 || path( $self->location, 'views' ) ),
      50        
      50        
      33        
727             environment => $self->environment,
728             appdir => $self->location,
729             public_dir => $public,
730             template => 'Tiny',
731             route_handlers => [
732             [
733             AutoPage => 1
734             ],
735             ],
736             };
737             }
738              
739             sub _init_hooks {
740 250     250   661 my $self = shift;
741              
742             # Hook to flush the session at the end of the request,
743             # this way, we're sure we flush only once per request
744             #
745             # Note: we create a weakened copy $self
746             # before closing over the weakened copy
747             # to avoid circular memory refs.
748 250         818 Scalar::Util::weaken(my $app = $self);
749              
750             $self->add_hook(
751             Dancer2::Core::Hook->new(
752             name => 'core.app.after_request',
753             code => sub {
754 498     498   1190 my $response = $Dancer2::Core::Route::RESPONSE;
755              
756             # make sure an engine is defined, if not, nothing to do
757 498         11449 my $engine = $app->session_engine;
758 498 50       4892 defined $engine or return;
759              
760             # if a session has been instantiated or we already had a
761             # session, first flush the session so cookie-based sessions can
762             # update the session ID if needed, then set the session cookie
763             # in the response
764             #
765             # if there is NO session object but the request has a cookie with
766             # a session key, create a dummy session with the same ID (without
767             # actually retrieving and flushing immediately) and generate the
768             # cookie header from the dummy session. Lazy Sessions FTW!
769              
770 498 100       2910 if ( $app->has_session ) {
    100          
771 76         199 my $session;
772 76 100       297 if ( $app->_has_session ) { # Session object exists
773 73         1433 $session = $app->session;
774 73 100       1866 $session->is_dirty and $engine->flush( session => $session );
775             }
776             else { # Cookie header exists. Create a dummy session object
777 3         18 my $cookie = $app->cookie( $engine->cookie_name );
778 3         89 my $session_id = $cookie->value;
779 3         91 $session = Dancer2::Core::Session->new( id => $session_id );
780             }
781 76         919 $engine->set_cookie_header(
782             response => $response,
783             session => $session
784             );
785             }
786             elsif ( $app->has_destroyed_session ) {
787 12         104 my $session = $app->destroyed_session;
788 12         70 $engine->set_cookie_header(
789             response => $response,
790             session => $session,
791             destroyed => 1
792             );
793             }
794             },
795             )
796 250         6490 );
797             }
798              
799             sub supported_hooks {
800 471     471 0 5860 qw/
801             core.app.before_request
802             core.app.after_request
803             core.app.route_exception
804             core.app.hook_exception
805             core.app.before_file_render
806             core.app.after_file_render
807             core.error.before
808             core.error.after
809             core.error.init
810             /;
811             }
812              
813             sub hook_aliases {
814 1887     1887 0 3755 my $self = shift;
815 1887   100     16139 $self->{'hook_aliases'} ||= {
816             before => 'core.app.before_request',
817             before_request => 'core.app.before_request',
818             after => 'core.app.after_request',
819             after_request => 'core.app.after_request',
820             init_error => 'core.error.init',
821             before_error => 'core.error.before',
822             after_error => 'core.error.after',
823             on_route_exception => 'core.app.route_exception',
824             on_hook_exception => 'core.app.hook_exception',
825              
826             before_file_render => 'core.app.before_file_render',
827             after_file_render => 'core.app.after_file_render',
828             before_handler_file_render => 'handler.file.before_render',
829             after_handler_file_render => 'handler.file.after_render',
830              
831              
832             # compatibility from Dancer1
833             before_error_render => 'core.error.before',
834             after_error_render => 'core.error.after',
835             before_error_init => 'core.error.init',
836              
837             # TODO: call $engine->hook_aliases as needed
838             # But.. currently there are use cases where hook_aliases
839             # are needed before the engines are intiialized :(
840             before_template_render => 'engine.template.before_render',
841             after_template_render => 'engine.template.after_render',
842             before_layout_render => 'engine.template.before_layout_render',
843             after_layout_render => 'engine.template.after_layout_render',
844             before_serializer => 'engine.serializer.before',
845             after_serializer => 'engine.serializer.after',
846             };
847             }
848              
849             sub defined_engines {
850 1642     1642 0 4571 my $self = shift;
851             return [
852 1642 100       38204 $self->template_engine,
853             $self->session_engine,
854             $self->logger_engine,
855             $self->has_serializer_engine
856             ? $self->serializer_engine
857             : (),
858             ];
859             }
860              
861             # FIXME not needed anymore, I suppose...
862 0     0 0 0 sub api_version {2}
863              
864             sub register_plugin {
865 0     0 1 0 my $self = shift;
866 0         0 my $plugin = shift;
867              
868 0         0 $self->log( core => "Registered $plugin");
869              
870 0         0 push @{ $self->plugins }, $plugin;
  0         0  
871             }
872              
873             # This method overrides the default one from Role::ConfigReader
874             sub settings {
875 961     961 0 2257 my $self = shift;
876 961         1908 +{ %{ Dancer2::runner()->config }, %{ $self->config } };
  961         3400  
  961         34962  
877             }
878              
879             sub cleanup {
880 709     709 0 1572 my $self = shift;
881 709         19224 $self->clear_request;
882 709         18099 $self->clear_response;
883 709         17657 $self->clear_session;
884 709         16852 $self->clear_destroyed_session;
885             # Clear engine attributes
886 709         3878 for my $engine ( @{ $self->defined_engines } ) {
  709         2457  
887 2208         94818 $engine->clear_session;
888 2208         47797 $engine->clear_request;
889             }
890             }
891              
892             sub _validate_engine {
893 29     29   318 my $self = shift;
894 29         71 my $name = shift;
895              
896 29 100       233 grep +( $_ eq $name ), @{ $self->supported_engines }
  29         138  
897             or croak "Engine '$name' is not supported.";
898             }
899              
900             sub engine {
901 27     27 0 1178 my $self = shift;
902 27         93 my $name = shift;
903              
904 27         179 $self->_validate_engine($name);
905              
906 26         77 my $attr_name = "${name}_engine";
907 26         932 return $self->$attr_name;
908             }
909              
910             sub template {
911 37     37 0 849 my $self = shift;
912              
913 37         905 my $template = $self->template_engine;
914 37         1092 $template->set_settings( $self->config );
915              
916             # A session will not exist if there is no request (global keyword)
917             #
918             # A session may exist but the route code may not have instantiated
919             # the session object (sessions are lazy). If this is the case, do
920             # that now, so the templates have the session data for rendering.
921 37 100 100     2479 $self->has_request && $self->has_session && ! $template->has_session
      100        
922             and $self->setup_session;
923              
924             # return content
925 37 100       376 if ($self->has_with_return) {
926 33         118 my $old_with_return = $self->with_return;
927 33         86 my $local_response;
928             $self->set_with_return( sub {
929 3   33 3   50 $local_response ||= shift;
930 33         256 });
931             # Catch any exceptions that may happen during template processing
932 33         91 my $content = eval { $template->process( @_ ) };
  33         232  
933 33         23621 my $eval_result = $@;
934 33         306 $self->set_with_return($old_with_return);
935             # If there was a previous response set before the exception (or set as
936             # part of the exception handling), then use that, otherwise throw the
937             # exception as normal
938 33 100       170 if ($local_response) {
    100          
939 3         13 $self->with_return->($local_response);
940             } elsif ($eval_result) {
941 6         96 die $eval_result;
942             }
943 24         179 return $content;
944             }
945 4         27 return $template->process( @_ );
946             }
947              
948             sub hook_candidates {
949 45     45 0 110 my $self = shift;
950              
951 45         100 my @engines = @{ $self->defined_engines };
  45         149  
952              
953 45         7482 my @route_handlers;
954 45         96 for my $handler ( @{ $self->route_handlers } ) {
  45         1080  
955 45         458 my $handler_code = $handler->{handler};
956 45 50 33     610 blessed $handler_code and $handler_code->can('supported_hooks')
957             and push @route_handlers, $handler_code;
958             }
959              
960             # TODO : get the list of all plugins registered
961 45         94 my @plugins = @{ $self->plugins };
  45         1055  
962              
963 45         442 ( @route_handlers, @engines, @plugins );
964             }
965              
966             sub all_hook_aliases {
967 339     339 0 834 my $self = shift;
968              
969 339         1524 my $aliases = $self->hook_aliases;
970 339         843 for my $plugin ( grep { $_->can('hook_aliases') } @{ $self->plugins } ) {
  13         198  
  339         8357  
971 13         32 $aliases = { %{$aliases}, %{ $plugin->hook_aliases } };
  13         105  
  13         57  
972             }
973              
974 339         3730 return $aliases;
975             }
976              
977             sub mime_type {
978 10     10 0 28 my $self = shift;
979 10         65 my $runner = Dancer2::runner();
980              
981             exists $self->config->{default_mime_type}
982             ? $runner->mime_type->default( $self->config->{default_mime_type} )
983 10 100       364 : $runner->mime_type->reset_default;
984              
985 10         602 $runner->mime_type;
986             }
987              
988             sub log {
989 2820     2820 0 44956 my $self = shift;
990 2820         4814 my $level = shift;
991              
992 2820 50       66100 my $logger = $self->logger_engine
993             or croak "No logger defined";
994              
995 2820         37951 $logger->$level(@_);
996             }
997              
998             sub send_as {
999 11     11 0 25 my $self = shift;
1000 11         43 my ( $type, $data, $options ) = @_;
1001 11   100     71 $options ||= {};
1002              
1003 11 100       341 $type or croak "Can not send_as using an undefined type";
1004              
1005 10 100 100     77 if ( lc($type) eq 'html' || lc($type) eq 'plain' ) {
1006 5 50       20 if ( $type ne lc $type ) {
1007 0         0 local $Carp::CarpLevel = 2;
1008 0         0 carp sprintf( "Please use %s as the type for 'send_as', not %s", lc($type), $type );
1009             }
1010              
1011 5   50     112 $options->{charset} = $self->config->{charset} || 'UTF-8';
1012 5         124 my $content = Encode::encode( $options->{charset}, $data );
1013 5   33     314 $options->{content_type} ||= join '/', 'text', lc $type;
1014             # Explicit return needed here, as if we are currently rendering a
1015             # template then with_return will not longjump
1016 5         28 return $self->send_file( \$content, %$options );
1017             }
1018              
1019             # Try and load the serializer class
1020 5         16 my $serializer_class = "Dancer2::Serializer::$type";
1021             eval {
1022             $EVAL_SHIM->(sub {
1023 5     5   33 require_module( $serializer_class );
1024 5         38 });
1025 3         110 1;
1026 5 100       12 } or do {
1027 2   50     940 my $err = $@ || "Zombie Error";
1028 2         596 croak "Unable to load serializer class for $type: $err";
1029             };
1030              
1031             # load any serializer engine config
1032 3   50     120 my $engine_options =
1033             $self->_get_config_for_engine( serializer => $type, $self->config ) || {};
1034 3         80 my $serializer = $serializer_class->new( config => $engine_options );
1035 3         97 my $content = $serializer->serialize( $data );
1036 3   66     29 $options->{content_type} ||= $serializer->content_type;
1037 3         22 $self->send_file( \$content, %$options );
1038             }
1039              
1040             sub send_error {
1041 8     8 0 16 my $self = shift;
1042 8         75 my ( $message, $status ) = @_;
1043              
1044 8 100       201 my $err = Dancer2::Core::Error->new(
1045             message => $message,
1046             app => $self,
1047             ( status => $status )x!! $status,
1048              
1049             $self->has_serializer_engine
1050             ? ( serializer => $self->serializer_engine )
1051             : (),
1052             )->throw;
1053              
1054             # Immediately return to dispatch if with_return coderef exists
1055 8 50       226 $self->has_with_return && $self->with_return->($err);
1056 0         0 return $err;
1057             }
1058              
1059             sub send_file {
1060 19     19 0 42 my $self = shift;
1061 19         36 my $thing = shift;
1062 19         77 my %options = @_;
1063              
1064 19         49 my ($content_type, $charset, $file_path);
1065              
1066             # are we're given a filehandle? (based on what Plack::Middleware::Lint accepts)
1067             my $is_filehandle = Plack::Util::is_real_fh($thing)
1068 19   33     122 || ( is_globref($thing) && *{$thing}{IO} && *{$thing}{IO}->can('getline') )
1069             || ( Scalar::Util::blessed($thing) && $thing->can('getline') );
1070 19         1511 my ($fh) = ($thing)x!! $is_filehandle;
1071              
1072             # if we're given an IO::Scalar object, DTRT (take the scalar ref from it)
1073 19 50 33     74 if (Scalar::Util::blessed($thing) && $thing->isa('IO::Scalar')) {
1074 0         0 $thing = $thing->sref;
1075             }
1076              
1077             # if we're given a SCALAR reference, build a filehandle to it
1078 19 100       69 if ( is_scalarref($thing) ) {
1079             ## no critic qw(InputOutput::RequireCheckedOpen)
1080 9         139 open $fh, "<", $thing;
1081             }
1082              
1083             # If we haven't got a filehandle, create one to the requested content
1084 19 100       60 if (! $fh) {
1085 9         20 my $path = $thing;
1086             # remove prefix from given path (if not a filehandle)
1087 9         274 my $prefix = $self->prefix;
1088 9 50 33     90 if ( $prefix && $prefix ne '/' ) {
1089 0         0 $path =~ s/^\Q$prefix\E//;
1090             }
1091             # static file dir - either system root or public_dir
1092             my $dir = $options{system_path}
1093             ? File::Spec->rootdir
1094             : $ENV{DANCER_PUBLIC}
1095             || $self->config->{public_dir}
1096 9 100 33     248 || path( $self->location, 'public' );
1097              
1098 9         173 $file_path = Dancer2::Handler::File->merge_paths( $path, $dir );
1099             my $err_response = sub {
1100 0     0   0 my $status = shift;
1101 0         0 $self->response->status($status);
1102 0         0 $self->response->header( 'Content-Type', 'text/plain' );
1103 0         0 $self->response->content( Dancer2::Core::HTTP->status_message($status) );
1104 0         0 $self->with_return->( $self->response );
1105 9         63 };
1106 9 50       32 $err_response->(403) if !defined $file_path;
1107 9 50       297 $err_response->(404) if !-f $file_path;
1108 9 50       109 $err_response->(403) if !-r $file_path;
1109              
1110             # Read file content as bytes
1111 9         102 $fh = Dancer2::FileUtils::open_file( "<", $file_path );
1112 9         60 binmode $fh;
1113 9   50     58 $content_type = Dancer2::runner()->mime_type->for_file($file_path) || 'text/plain';
1114 9 100       246 if ( $content_type =~ m!^text/! ) {
1115 5   50     151 $charset = $self->config->{charset} || "utf-8";
1116             }
1117             }
1118              
1119             # Now we are sure we can render the file...
1120 19         672 $self->execute_hook( 'core.app.before_file_render', $file_path );
1121              
1122             # response content type and charset
1123 19 100       242 ( exists $options{'content_type'} ) and $content_type = $options{'content_type'};
1124 19 100       89 ( exists $options{'charset'} ) and $charset = $options{'charset'};
1125 19 100 100     137 $content_type .= "; charset=$charset" if $content_type and $charset;
1126 19 100       354 ( defined $content_type )
1127             and $self->response->header('Content-Type' => $content_type );
1128              
1129             # content disposition
1130             ( exists $options{filename} )
1131             and $self->response->header( 'Content-Disposition' =>
1132 19 100 100     6422 ($options{content_disposition} || "attachment") . "; filename=\"$options{filename}\"" );
1133              
1134             # use a delayed response unless server does not support streaming
1135 19 100       291 my $use_streaming = exists $options{streaming} ? $options{streaming} : 1;
1136 19         34 my $response;
1137 19         166 my $env = $self->request->env;
1138 19 100 66     169 if ( $env->{'psgi.streaming'} && $use_streaming ) {
1139             my $cb = sub {
1140 18     18   45 my $responder = $Dancer2::Core::Route::RESPONDER;
1141 18         35 my $res = $Dancer2::Core::Route::RESPONSE;
1142 18         520 return $responder->(
1143             [ $res->status, $res->headers_to_array, $fh ]
1144             );
1145 18         127 };
1146              
1147 18         58 Scalar::Util::weaken( my $weak_self = $self );
1148              
1149             $response = Dancer2::Core::Response::Delayed->new(
1150 0     0   0 error_cb => sub { $weak_self->logger_engine->log( warning => @_ ) },
1151 18         579 cb => $cb,
1152             request => $Dancer2::Core::Route::REQUEST,
1153             response => $Dancer2::Core::Route::RESPONSE,
1154             );
1155             }
1156             else {
1157 1         14 $response = $self->response;
1158             # direct assignment to hash element, avoids around modifier
1159             # trying to serialise this this content.
1160 1         8 $response->{content} = Dancer2::FileUtils::read_glob_content($fh);
1161 1         37 $response->is_encoded(1); # bytes are already encoded
1162             }
1163              
1164 19         28139 $self->execute_hook( 'core.app.after_file_render', $response );
1165 19         754 $self->with_return->( $response );
1166             }
1167              
1168             sub BUILD {
1169             my $self = shift;
1170             $self->init_route_handlers();
1171             $self->_init_hooks();
1172             }
1173              
1174             sub finish {
1175 218     218 0 575 my $self = shift;
1176              
1177             # normalize some values that require calculations
1178             defined $self->config->{'static_handler'}
1179 218 100       4427 or $self->config->{'static_handler'} = -d $self->config->{'public_dir'};
1180              
1181 218         14818 $self->register_route_handlers;
1182 218         3061 $self->compile_hooks;
1183              
1184 218 50 66     1963 @{$self->plugins}
  218         4863  
1185             && $self->plugins->[0]->can('_add_postponed_plugin_hooks')
1186             && $self->plugins->[0]->_add_postponed_plugin_hooks(
1187             $self->postponed_hooks
1188             );
1189              
1190 218         3324 foreach my $prep_cb ( @{ $self->prep_apps } ) {
  218         1443  
1191 4         20 $prep_cb->($self);
1192             }
1193             }
1194              
1195             sub init_route_handlers {
1196 253     253 0 595 my $self = shift;
1197              
1198 253         6858 my $handlers_config = $self->config->{route_handlers};
1199 250         8354 for my $handler_data ( @{$handlers_config} ) {
  250         990  
1200 249         600 my ($handler_name, $config) = @{$handler_data};
  249         968  
1201 249 50       1190 $config = {} if !is_ref($config);
1202              
1203 249         7592 my $handler = $self->_factory->create(
1204             Handler => $handler_name,
1205             app => $self,
1206             %$config,
1207             postponed_hooks => $self->postponed_hooks,
1208             );
1209              
1210 249         322064 push @{ $self->route_handlers }, {
  249         8628  
1211             name => $handler_name,
1212             handler => $handler,
1213             };
1214             }
1215             }
1216              
1217             sub register_route_handlers {
1218 218     218 0 581 my $self = shift;
1219 218         495 for my $handler ( @{$self->route_handlers} ) {
  218         5872  
1220 216         2324 my $handler_code = $handler->{handler};
1221 216         1552 $handler_code->register($self);
1222             }
1223             }
1224              
1225             sub compile_hooks {
1226 221     221 0 712 my ($self) = @_;
1227              
1228 221         1121 for my $position ( $self->supported_hooks ) {
1229 1989         13848 my $compiled_hooks = [];
1230 1989         2956 for my $hook ( @{ $self->hooks->{$position} } ) {
  1989         36858  
1231 272         2750 Scalar::Util::weaken( my $app = $self );
1232             my $compiled = set_subname subname($hook) => sub {
1233             # don't run the filter if halt has been used
1234 731 100 66 731   4395 $Dancer2::Core::Route::RESPONSE &&
1235             $Dancer2::Core::Route::RESPONSE->is_halted
1236             and return;
1237              
1238 730         2981 eval { $EVAL_SHIM->($hook,@_); 1; }
  715         5016  
1239 730 100       6836 or do {
1240 9   50     51 my $err = $@ || "Zombie Error";
1241 9         31 my $is_hook_exception = $position eq 'core.app.hook_exception';
1242             # Don't execute the hook_exception hook if the exception
1243             # has been generated from a hook exception handler itself,
1244             # thus preventing potentially recursive code.
1245 9 100       305 $app->execute_hook( 'core.app.hook_exception', $app, $err, $position )
1246             unless $is_hook_exception;
1247 8         220 my $is_halted = $app->response->is_halted; # Capture before cleanup
1248             # We can't cleanup if we're in the hook for a hook
1249             # exception, as this would clear the custom response that
1250             # may have been set by the hook. However, there is no need
1251             # to do so, as the upper hook that called this hook
1252             # exception will perform the cleanup instead anyway
1253 8 100       277 $app->cleanup
1254             unless $is_hook_exception;
1255             # Allow the hook function to halt the response, thus
1256             # retaining any response it may have set. Otherwise the
1257             # croak from this function will overwrite any content that
1258             # may have been set by the hook
1259 8 100       80 return if $is_halted;
1260             # Default behavior if nothing else defined
1261 5         31 $app->log('error', "Exception caught in '$position' filter: $err");
1262 5         997 croak "Exception caught in '$position' filter: $err";
1263             };
1264 272         6119 };
1265              
1266 272         762 push @{$compiled_hooks}, $compiled;
  272         1026  
1267             }
1268 1989         17310 $self->replace_hook( $position, $compiled_hooks );
1269             }
1270             }
1271              
1272             sub lexical_prefix {
1273 5     5 1 2270 my $self = shift;
1274 5         14 my $prefix = shift;
1275 5         12 my $cb = shift;
1276              
1277 5 100       27 $prefix eq '/' and undef $prefix;
1278              
1279             # save the app prefix
1280 5         137 my $app_prefix = $self->prefix;
1281              
1282             # alter the prefix for the callback
1283 5 100       94 my $new_prefix =
    100          
1284             ( defined $app_prefix ? $app_prefix : '' )
1285             . ( defined $prefix ? $prefix : '' );
1286              
1287             # if the new prefix is empty, it's a meaningless prefix, just ignore it
1288 5 100       95 length $new_prefix and $self->prefix($new_prefix);
1289              
1290 5         158 my $err;
1291 5         27 my $ok= eval { $EVAL_SHIM->($cb); 1 }
  4         17  
1292 5 100 50     15 or do { $err = $@ || "Zombie Error"; };
  1         31  
1293              
1294             # restore app prefix
1295 5         120 $self->prefix($app_prefix);
1296              
1297 5 100       562 $ok or croak "Unable to run the callback for prefix '$prefix': $err";
1298             }
1299              
1300             sub add_route {
1301 676     676 1 3054 my $self = shift;
1302 676         3404 my %route_attrs = @_;
1303              
1304             my $route = Dancer2::Core::Route->new(
1305             type_library => $self->config->{type_library},
1306 676         18967 prefix => $self->prefix,
1307             %route_attrs,
1308             );
1309              
1310 676         176321 my $method = $route->method;
1311 676         3090 push @{ $self->routes->{$method} }, $route;
  676         18327  
1312              
1313 676 100 100     12362 if ( $method ne 'head' && $route->has_name() ) {
1314 11         38 my $name = $route->name;
1315 11 100       247 $self->route_names->{$name}
1316             and die "Route with this name ($name) already exists";
1317              
1318 10         219 $self->route_names->{$name} = $route;
1319             }
1320              
1321 675         7778 return $route;
1322             }
1323              
1324             sub route_exists {
1325 0     0 1 0 my $self = shift;
1326 0         0 my $route = shift;
1327              
1328 0         0 my $routes = $self->routes->{ $route->method };
1329              
1330 0         0 foreach my $existing_route (@$routes) {
1331 0 0       0 $existing_route->spec_route eq $route->spec_route
1332             and return 1;
1333             }
1334              
1335 0         0 return 0;
1336             }
1337              
1338             sub routes_regexps_for {
1339 1     1 1 1222 my $self = shift;
1340 1         4 my $method = shift;
1341              
1342 1         2 return [ map $_->regexp, @{ $self->routes->{$method} } ];
  1         37  
1343             }
1344              
1345             sub cookie {
1346 583     583 0 1201 my $self = shift;
1347              
1348 583 50       5076 @_ == 1 and return $self->request->cookies->{ $_[0] };
1349              
1350             # writer
1351 0         0 my ( $name, $value, %options ) = @_;
1352 0         0 my $c =
1353             Dancer2::Core::Cookie->new( name => $name, value => $value, %options );
1354 0         0 $self->response->push_header( 'Set-Cookie' => $c->to_header );
1355             }
1356              
1357             sub redirect {
1358 26     26 1 88 my $self = shift;
1359 26         64 my $destination = shift;
1360 26         77 my $status = shift;
1361              
1362 26 100       151 if ($destination =~ m{^/(?!/)}) {
1363             # If the app is mounted to something other than "/", we must
1364             # preserve its path.
1365 12         313 my $script_name = $self->request->script_name;
1366 12         131 $script_name =~ s{/$}{}; # Remove trailing slash (if present).
1367 12         41 $destination = $script_name . $destination;
1368             }
1369              
1370 26         722 $self->response->redirect( $destination, $status );
1371              
1372             # Short circuit any remaining before hook / route code
1373             # ('pass' and after hooks are still processed)
1374 26 50       4821 $self->has_with_return
1375             and $self->with_return->($self->response);
1376             }
1377              
1378             sub halt {
1379 7     7 1 14 my $self = shift;
1380 7         167 $self->response->halt( @_ );
1381              
1382             # Short citcuit any remaining hook/route code
1383 7 50       466 $self->has_with_return
1384             and $self->with_return->($self->response);
1385             }
1386              
1387             sub pass {
1388 2     2 1 6 my $self = shift;
1389 2         249 $self->response->pass;
1390              
1391             # Short citcuit any remaining hook/route code
1392 2 50       136 $self->has_with_return
1393             and $self->with_return->($self->response);
1394             }
1395              
1396             sub forward {
1397 44     44 1 95 my $self = shift;
1398 44         98 my $url = shift;
1399 44         87 my $params = shift;
1400 44         107 my $options = shift;
1401              
1402 44         288 my $new_request = $self->make_forward_to( $url, $params, $options );
1403              
1404 44 50       410 $self->has_with_return
1405             and $self->with_return->($new_request);
1406              
1407             # nothing else will run after this
1408             }
1409              
1410             # Create a new request which is a clone of the current one, apart
1411             # from the path location, which points instead to the new location
1412             sub make_forward_to {
1413 53     53 0 252 my $self = shift;
1414 53         111 my $url = shift;
1415 53         110 my $params = shift;
1416 53         132 my $options = shift;
1417              
1418 53         194 my $overrides = { PATH_INFO => $url };
1419             exists $options->{method} and
1420 53 100       239 $overrides->{REQUEST_METHOD} = $options->{method};
1421              
1422             # "clone" the existing request
1423 53         396 my $new_request = $self->request->_shallow_clone( $params, $overrides );
1424              
1425             # If a session object was created during processing of the original request
1426             # i.e. a session object exists but no cookie existed
1427             # add a cookie so the dispatcher can assign the session to the appropriate app
1428 53         2008 my $engine = $self->session_engine;
1429 53 100 66     2010 $engine && $self->_has_session or return $new_request;
1430 11         41 my $name = $engine->cookie_name;
1431 11 100       43 exists $new_request->cookies->{$name} and return $new_request;
1432 10         264 $new_request->cookies->{$name} =
1433             Dancer2::Core::Cookie->new( name => $name, value => $self->session->id );
1434              
1435 10         42 return $new_request;
1436             }
1437              
1438 1     1 1 2623 sub app { shift }
1439              
1440             # DISPATCHER
1441             sub to_app {
1442 216     216 0 1353 my $self = shift;
1443              
1444             # build engines
1445             {
1446 216         534 for ( qw ) {
  216         1104  
1447 648         34209 my $attr = "${_}_engine";
1448 648         16464 $self->$attr;
1449             }
1450              
1451             # the serializer engine does not have a default
1452             # and is the only engine that can actually not have a value
1453 216 100       23751 if ( $self->config->{'serializer'} ) {
1454 23         756 $self->serializer_engine;
1455             }
1456             }
1457              
1458 216         5144 $self->finish;
1459              
1460             my $psgi = sub {
1461 628     628   1864658 my $env = shift;
1462              
1463             # pre-request sanity check
1464 628         2576 my $method = uc $env->{'REQUEST_METHOD'};
1465 628 100       3817 $Dancer2::Core::Types::supported_http_methods{$method}
1466             or return [
1467             405,
1468             [ 'Content-Type' => 'text/plain' ],
1469             [ "Method Not Allowed\n\n$method is not supported." ]
1470             ];
1471              
1472 626         1325 my $response;
1473             eval {
1474 626         6262 $EVAL_SHIM->(sub{ $response = $self->dispatch($env)->to_psgi });
  626         3164  
1475 625         8729 1;
1476 626 100       1748 } or do {
1477 1   50     7 my $err = $@ || "Zombie Error";
1478             return [
1479 1         21 500,
1480             [ 'Content-Type' => 'text/plain' ],
1481             [ "Internal Server Error\n\n$err" ],
1482             ];
1483             };
1484              
1485 625         10582 return $response;
1486 216         1661 };
1487              
1488             # Only add static content handler if required
1489 216 100       4737 if ( $self->config->{'static_handler'} ) {
1490             # Use App::File to "serve" the static content
1491             my $static_app = Plack::App::File->new(
1492             root => $self->config->{public_dir},
1493 8     8   2069 content_type => sub { $self->mime_type->for_file( $_[0] ) },
1494 118         3371 )->to_app;
1495             # Conditionally use the static handler wrapped with ConditionalGET
1496             # when the file exists. Otherwise the request passes into our app.
1497             $psgi = Plack::Middleware::Conditional->wrap(
1498             $psgi,
1499 436     436   3020671 condition => sub { -f path( $self->config->{public_dir}, shift->{PATH_INFO} ) },
1500 118     118   10405 builder => sub { Plack::Middleware::ConditionalGET->wrap( $static_app ) },
1501 118         8526 );
1502             }
1503              
1504             # Wrap with common middleware
1505 216 100       11395 if ( ! $self->config->{'no_default_middleware'} ) {
1506             # FixMissingBodyInRedirect
1507 212         4296 $psgi = Plack::Middleware::FixMissingBodyInRedirect->wrap( $psgi );
1508             # Apply Head. After static so a HEAD request on static content DWIM.
1509 212         10554 $psgi = Plack::Middleware::Head->wrap( $psgi );
1510             }
1511              
1512 216         9039 return $psgi;
1513             }
1514              
1515             sub dispatch {
1516 626     626 0 1304 my $self = shift;
1517 626         1371 my $env = shift;
1518              
1519 626         3373 my $runner = Dancer2::runner();
1520 626         1360 my $request;
1521 626         1357 my $request_built_successfully = eval {
1522             $EVAL_SHIM->(sub {
1523 626   100 626   5332 $request = $runner->{'internal_request'} || $self->build_request($env);
1524 626         4292 });
1525 622         3678 1;
1526             };
1527             # Catch bad content causing deserialization to fail when building the request
1528 626 100       2900 if ( ! $request_built_successfully ) {
1529 4         12 my $err = $@;
1530 4         12 Scalar::Util::weaken(my $app = $self);
1531 4         62 return Dancer2::Core::Error->new(
1532             app => $app,
1533             message => $err,
1534             status => 400, # 400 Bad request (dont send again), rather than 500
1535             )->throw;
1536             }
1537              
1538 622         22635 my $cname = $self->session_engine->cookie_name;
1539 622         9705 my $defined_engines = $self->defined_engines;
1540              
1541             DISPATCH:
1542 622         38514 while (1) {
1543 649         3851 my $http_method = lc $request->method;
1544 649         7409 my $path_info = $request->path_info;
1545              
1546             # Add request to app and engines
1547 649         6584 $self->set_request($request, $defined_engines);
1548              
1549 649         88040 $self->log( core => "looking for $http_method $path_info" );
1550              
1551             ROUTE:
1552 649         1462 foreach my $route ( @{ $self->routes->{$http_method} } ) {
  649         14751  
1553             #warn "testing route " . $route->regexp . "\n";
1554             # TODO store in route cache
1555              
1556             # go to the next route if no match
1557 1354 100       12974 my $match = $route->match($request)
1558             or next ROUTE;
1559              
1560 585         25767 $request->_set_route_params($match);
1561 585         3113 $request->_set_route_parameters($match);
1562 585         26392 $request->_set_route($route);
1563              
1564             # Add session to app *if* we have a session and the request
1565             # has the appropriate cookie header for _this_ app.
1566 585 100       3094 if ( my $sess = $runner->{'internal_sessions'}{$cname} ) {
1567 6         219 $self->set_session($sess);
1568             }
1569              
1570             # calling the actual route
1571 585         2821 my $response;
1572              
1573             # this is very evil, but allows breaking out of multiple stack
1574             # frames without throwing an exception. Avoiding exceptions means
1575             # a naive eval won't swallow our flow control mechanisms, and
1576             # avoids __DIE__ handlers. It also prevents some cleanup routines
1577             # from working, since they are expecting control to return to them
1578             # after an eval.
1579             DANCER2_CORE_APP_ROUTE_RETURN: {
1580 585 50       1223 if (!$self->has_with_return) {
  585         3287  
1581             $self->set_with_return(sub {
1582 106     106   565 $response = shift;
1583 156     156   2169 no warnings 'exiting';
  156         401  
  156         276637  
1584 106         1098 last DANCER2_CORE_APP_ROUTE_RETURN;
1585 585         4991 });
1586             }
1587 585         2503 $response = $self->_dispatch_route($route);
1588             };
1589              
1590             # ensure we clear the with_return handler
1591 585         21057 $self->clear_with_return;
1592              
1593             # handle forward requests
1594 585 100       6899 if ( ref $response eq 'Dancer2::Core::Request' ) {
1595             # this is actually a request, not response
1596             # however, we need to clean up the request & response
1597 44         1073 $self->clear_request;
1598 44         1172 $self->clear_response;
1599              
1600             # this is in case we're asked for an old-style dispatching
1601 44 100       596 if ( $runner->{'internal_dispatch'} ) {
1602             # Get the session object from the app before we clean up
1603             # the request context, so we can propagate this to the
1604             # next dispatch cycle (if required).
1605             $self->_has_session
1606 17 100       223 and $runner->{'internal_sessions'}{$cname} =
1607             $self->session;
1608              
1609 17         108 $runner->{'internal_forward'} = 1;
1610 17         54 $runner->{'internal_request'} = $response;
1611 17         69 return $self->response_not_found($request);
1612             }
1613              
1614 27         61 $request = $response;
1615 27         97 next DISPATCH;
1616             }
1617              
1618             # from here we assume the response is a Dancer2::Core::Response
1619              
1620             # halted response, don't process further
1621 541 100       10961 if ( $response->is_halted ) {
1622 34         400 $self->cleanup;
1623 34         301 delete $runner->{'internal_request'};
1624 34         865 return $response;
1625             }
1626              
1627             # pass the baton if the response says so...
1628 507 100       13193 if ( $response->has_passed ) {
1629             ## A previous route might have used splat, failed
1630             ## this needs to be cleaned from the request.
1631             exists $request->{_params}{splat}
1632 9 100       99 and delete $request->{_params}{splat};
1633              
1634 9         158 $response->has_passed(0); # clear for the next round
1635              
1636             # clear the content because if you pass it,
1637             # the next route is in charge of catching it
1638 9         467 $response->clear_content;
1639 9         72 next ROUTE;
1640             }
1641              
1642             # it's just a regular response
1643 498         15697 $self->execute_hook( 'core.app.after_request', $response );
1644 497         2456 $self->cleanup;
1645 497         3754 delete $runner->{'internal_request'};
1646              
1647 497         8613 return $response;
1648             }
1649              
1650             # we don't actually want to continue the loop
1651 73         237 last;
1652             }
1653              
1654             # No response! ensure Core::Dispatcher recognizes this failure
1655             # so it can try the next Core::App
1656             # and set the created request so we don't create it again
1657             # (this is important so we don't ignore the previous body)
1658 73 100       327 if ( $runner->{'internal_dispatch'} ) {
1659 51         145 $runner->{'internal_404'} = 1;
1660 51         175 $runner->{'internal_request'} = $request;
1661             }
1662              
1663             # Render 404 response, cleanup, and return the response.
1664 73         310 my $response = $self->response_not_found($request);
1665 73         273 $self->cleanup;
1666 73         1054 return $response;
1667             }
1668              
1669             sub build_request {
1670 577     577 0 1711 my ( $self, $env ) = @_;
1671 577         1851 Scalar::Util::weaken( my $weak_self = $self );
1672              
1673             # If we have an app, send the serialization engine
1674             my $request = Dancer2::Core::Request->new(
1675             env => $env,
1676             is_behind_proxy => $self->settings->{'behind_proxy'} || 0,
1677 0     0   0 uri_for_route => sub { shift; $weak_self->uri_for_route(@_) },
  0         0  
1678              
1679 577 100 100     2862 $self->has_serializer_engine
1680             ? ( serializer => $self->serializer_engine )
1681             : (),
1682             );
1683              
1684 573         10997 return $request;
1685             }
1686              
1687             # Call any before hooks then the matched route.
1688             sub _dispatch_route {
1689 585     585   1639 my ( $self, $route ) = @_;
1690              
1691 585         1229 local $@;
1692             eval {
1693             $EVAL_SHIM->(sub {
1694 585     585   21297 $self->execute_hook( 'core.app.before_request', $self );
1695 585         4122 });
1696 576         10264 1;
1697 585 100       1393 } or do {
1698 4   50     84 my $err = $@ || "Zombie Error";
1699 4         24 return $self->response_internal_error($err);
1700             };
1701 576         13626 my $response = $self->response;
1702              
1703 576 100       15746 if ( $response->is_halted ) {
1704 2         27 return $self->_prep_response( $response );
1705             }
1706              
1707             eval {
1708 574     574   4461 $EVAL_SHIM->(sub{ $response = $route->execute($self) });
  574         3931  
1709 460         3346 1;
1710 574 100       5187 } or do {
1711 14   50     416 my $err = $@ || "Zombie Error";
1712 14         79 return $self->response_internal_error($err);
1713             };
1714              
1715 460         1599 return $response;
1716             }
1717              
1718             sub _prep_response {
1719 483     483   1617 my ( $self, $response, $content ) = @_;
1720              
1721             # The response object has no back references to the content or app
1722             # Update the default_content_type of the response if any value set in
1723             # config so it can be applied when the response is encoded/returned.
1724 483         13689 my $config = $self->config;
1725 483 50 33     7064 if ( exists $config->{content_type}
1726             and my $ct = $config->{content_type} ) {
1727 483         11092 $response->default_content_type($ct);
1728             }
1729              
1730             # if we were passed any content, set it in the response
1731 483 100       30970 defined $content && $response->content($content);
1732 483         50852 return $response;
1733             }
1734              
1735             sub response_internal_error {
1736 18     18 0 60 my ( $self, $error ) = @_;
1737              
1738 18         692 $self->execute_hook( 'core.app.route_exception', $self, $error );
1739 17         255 $self->log( error => "Route exception: $error" );
1740              
1741 17         303 local $Dancer2::Core::Route::REQUEST = $self->request;
1742 17         417 local $Dancer2::Core::Route::RESPONSE = $self->response;
1743              
1744 17         467 return Dancer2::Core::Error->new(
1745             app => $self,
1746             status => 500,
1747             exception => $error,
1748             )->throw;
1749             }
1750              
1751             sub response_not_found {
1752 99     99 0 296 my ( $self, $request ) = @_;
1753              
1754 99         439 $self->set_request($request);
1755              
1756 99         11777 local $Dancer2::Core::Route::REQUEST = $self->request;
1757 99         2419 local $Dancer2::Core::Route::RESPONSE = $self->response;
1758              
1759 99         9221 my $response = Dancer2::Core::Error->new(
1760             app => $self,
1761             status => 404,
1762             message => $request->path,
1763             )->throw;
1764              
1765 99         1612 $self->cleanup;
1766              
1767 99         1402 return $response;
1768             }
1769              
1770             sub uri_for_route {
1771 18     18 0 63 my ( $self, $route_name, $route_params, $query_params, $dont_escape ) = @_;
1772 18 100       348 my $route = $self->route_names->{$route_name}
1773             or die "Cannot find route named '$route_name'";
1774              
1775 16         170 my $string = $route->spec_route;
1776 16 50       47 is_regexpref($string)
1777             and die "uri_for_route() does not support regexp route paths";
1778              
1779             # Convert splat only to the general purpose structure
1780 16 100       64 if ( is_arrayref($route_params) ) {
1781 4         12 $route_params = { 'splat' => $route_params };
1782             }
1783              
1784             # The regexes are taken and altered from:
1785             # Dancer2::Core::Route::_build_regexp_from_string.
1786              
1787             # Replace :foo with arg (route parameters)
1788             # Not a fan of all this regex play to handle typed parameter -- SX
1789 16         91 my @params = $string =~ m{:([^/.\?]+)}xmsg;
1790              
1791 16         38 foreach my $param (@params) {
1792 14         70 $param =~ s{^([^\[]+).*}{$1}xms;
1793 14 100       72 my $value = $route_params->{$param}
1794             or die "Route $route_name uses the parameter '${param}', which was not provided";
1795              
1796 12         242 $string =~ s!\Q:$param\E(\[[^\]]+\])?!$value!xmsg;
1797             }
1798              
1799             # TODO: Can we cut this down by replacing on the spot?
1800             # I think that will be tricky because we first need all **, then *
1801              
1802 14         58 $string =~ s!\Q**\E!(?#megasplat)!g;
1803 14         42 $string =~ s!\*!(?#splat)!g;
1804              
1805             # TODO: Can we cut this down?
1806 14         79 my @token_or_splat =
1807             $string =~ /\(\?#((?:mega)?splat)\)/g;
1808              
1809 14         28 my $splat_params = $route_params->{'splat'};
1810 14 100 66     93 if ($splat_params && @token_or_splat) {
1811 6 100       13 $#{$splat_params} == $#token_or_splat
  6         39  
1812             or die 'Mismatch in amount of splat args and splat elements';
1813              
1814 4         10 for ( my $i = 0; $i < @{$splat_params}; $i++ ) {
  14         33  
1815 10 100       22 if ( is_arrayref($splat_params->[$i]) ){
1816 4         6 my $megasplat = join '/', @{ $splat_params->[$i] };
  4         10  
1817 4         15 $string =~ s{\Q(?#megasplat)\E}{$megasplat};
1818             } else {
1819 6         29 $string =~ s{\Q(?#splat)\E}{$splat_params->[$i]};
1820             }
1821             }
1822             }
1823              
1824 12         78 return $self->request->uri_for( $string, $query_params, $dont_escape );
1825             }
1826              
1827             1;
1828              
1829             __END__