Commit | Line | Data |
e28a6876 |
1 | package TestApp; |
2 | |
3 | use strict; |
4 | use Catalyst qw/ |
5 | Test::MangleDollarUnderScore |
6 | Test::Errors |
7 | Test::Headers |
8 | Test::Plugin |
9 | Test::Inline |
10 | +TestApp::Plugin::FullyQualified |
11 | +TestApp::Plugin::AddDispatchTypes |
12 | +TestApp::Role |
13 | /; |
14 | use Catalyst::Utils; |
15 | |
16 | use Moose; |
17 | use namespace::autoclean; |
18 | |
19 | our $VERSION = '0.01'; |
20 | |
21 | TestApp->config( name => 'TestApp', root => '/some/dir' ); |
22 | |
23 | if (eval { Class::MOP::load_class('CatalystX::LeakChecker'); 1 }) { |
24 | with 'CatalystX::LeakChecker'; |
25 | |
26 | has leaks => ( |
27 | is => 'ro', |
28 | default => sub { [] }, |
29 | ); |
30 | } |
31 | |
32 | sub found_leaks { |
33 | my ($ctx, @leaks) = @_; |
34 | push @{ $ctx->leaks }, @leaks; |
35 | } |
36 | |
37 | sub count_leaks { |
38 | my ($ctx) = @_; |
39 | return scalar @{ $ctx->leaks }; |
40 | } |
41 | |
42 | TestApp->setup; |
43 | |
44 | sub execute { |
45 | my $c = shift; |
46 | my $class = ref( $c->component( $_[0] ) ) || $_[0]; |
47 | my $action = $_[1]->reverse; |
48 | |
49 | my $method; |
50 | |
51 | if ( $action =~ /->(\w+)$/ ) { |
52 | $method = $1; |
53 | } |
54 | elsif ( $action =~ /\/(\w+)$/ ) { |
55 | $method = $1; |
56 | } |
57 | elsif ( $action =~ /^(\w+)$/ ) { |
58 | $method = $action; |
59 | } |
60 | |
61 | if ( $class && $method && $method !~ /^_/ ) { |
62 | my $executed = sprintf( "%s->%s", $class, $method ); |
63 | my @executed = $c->response->headers->header('X-Catalyst-Executed'); |
64 | push @executed, $executed; |
65 | $c->response->headers->header( |
66 | 'X-Catalyst-Executed' => join ', ', |
67 | @executed |
68 | ); |
69 | } |
70 | no warnings 'recursion'; |
71 | return $c->SUPER::execute(@_); |
72 | } |
73 | |
74 | # Replace the very large HTML error page with |
75 | # useful info if something crashes during a test |
76 | sub finalize_error { |
77 | my $c = shift; |
78 | |
79 | $c->next::method(@_); |
80 | |
81 | $c->res->status(500); |
82 | $c->res->body( 'FATAL ERROR: ' . join( ', ', @{ $c->error } ) ); |
83 | } |
84 | |
85 | { |
86 | no warnings 'redefine'; |
87 | sub Catalyst::Log::error { } |
88 | } |
89 | |
90 | # Make sure we can load Inline plugins. |
91 | |
92 | package Catalyst::Plugin::Test::Inline; |
93 | |
94 | use strict; |
95 | |
96 | use base qw/Class::Data::Inheritable/; |
97 | |
98 | 1; |