Commit | Line | Data |
dd4e6fd2 |
1 | package TestApp; |
2 | |
3 | use strict; |
836e1134 |
4 | use Catalyst qw/ |
5 | Test::Errors |
6 | Test::Headers |
7 | Test::Plugin |
4ca147fa |
8 | Test::Inline |
836e1134 |
9 | +TestApp::Plugin::FullyQualified |
10 | /; |
1408d0a4 |
11 | use Catalyst::Utils; |
dd4e6fd2 |
12 | |
13 | our $VERSION = '0.01'; |
14 | |
fbcc39ad |
15 | TestApp->config( name => 'TestApp', root => '/some/dir' ); |
dd4e6fd2 |
16 | |
17 | TestApp->setup; |
18 | |
e0e47c71 |
19 | sub index : Private { |
20 | my ( $self, $c ) = @_; |
369c09bc |
21 | $c->res->body('root index'); |
e0e47c71 |
22 | } |
23 | |
e5d7f18c |
24 | sub global_action : Private { |
2656a6de |
25 | my ( $self, $c ) = @_; |
26 | $c->forward('TestApp::View::Dump::Request'); |
27 | } |
28 | |
dd4e6fd2 |
29 | sub execute { |
4d989a5d |
30 | my $c = shift; |
31 | my $class = ref( $c->component( $_[0] ) ) || $_[0]; |
fbcc39ad |
32 | my $action = "$_[1]"; |
dd4e6fd2 |
33 | |
34 | my $method; |
35 | |
4d989a5d |
36 | if ( $action =~ /->(\w+)$/ ) { |
37 | $method = $1; |
dd4e6fd2 |
38 | } |
4d989a5d |
39 | elsif ( $action =~ /\/(\w+)$/ ) { |
40 | $method = $1; |
dd4e6fd2 |
41 | } |
01ba879f |
42 | elsif ( $action =~ /^(\w+)$/ ) { |
43 | $method = $action; |
44 | } |
45 | |
ba599d1c |
46 | if ( $class && $method && $method !~ /^_/ ) { |
1408d0a4 |
47 | my $executed = sprintf( "%s->%s", $class, $method ); |
fbcc39ad |
48 | my @executed = $c->response->headers->header('X-Catalyst-Executed'); |
49 | push @executed, $executed; |
50 | $c->response->headers->header( |
51 | 'X-Catalyst-Executed' => join ', ', |
52 | @executed |
53 | ); |
1408d0a4 |
54 | } |
fbcc39ad |
55 | |
dd4e6fd2 |
56 | return $c->SUPER::execute(@_); |
57 | } |
58 | |
8153c836 |
59 | # Replace the very large HTML error page with |
60 | # useful info if something crashes during a test |
61 | sub finalize_error { |
62 | my $c = shift; |
63 | |
64 | $c->NEXT::finalize_error(@_); |
65 | |
66 | $c->res->status(500); |
67 | $c->res->body( 'FATAL ERROR: ' . join( ', ', @{ $c->error } ) ); |
68 | } |
69 | |
1627551a |
70 | sub class_forward_test_method :Private { |
86d993ab |
71 | my ( $self, $c ) = @_; |
72 | $c->response->headers->header( 'X-Class-Forward-Test-Method' => 1 ); |
73 | } |
74 | |
1627551a |
75 | sub loop_test : Local { |
76 | my ( $self, $c ) = @_; |
77 | |
78 | for( 1..1001 ) { |
79 | $c->forward( 'class_forward_test_method' ); |
80 | } |
81 | } |
82 | |
83 | sub recursion_test : Local { |
84 | my ( $self, $c ) = @_; |
85 | $c->forward( 'recursion_test' ); |
86 | } |
87 | |
369c09bc |
88 | { |
89 | no warnings 'redefine'; |
90 | sub Catalyst::Log::error { } |
91 | } |
4ca147fa |
92 | |
93 | # Make sure we can load Inline plugins. |
94 | |
95 | package Catalyst::Plugin::Test::Inline; |
96 | |
97 | use strict; |
98 | |
99 | use base qw/Catalyst::Base Class::Data::Inheritable/; |
100 | |
101 | 1; |