t/lib/TestApp/Context.pm

   1 package TestApp::Context;
   2 use Moose;
   3 extends 'Catalyst::Context';
   4 with 'Catalyst::TraitFor::Context::TestHeaders',
   5      'Catalyst::TraitFor::Context::TestErrors',
   6      'Catalyst::TraitFor::Context::TestPluginServer';
   7
   8 if (eval { Class::MOP::load_class('CatalystX::LeakChecker'); 1 }) {
   9     with 'CatalystX::LeakChecker';
  10
  11     has leaks => (
  12         is      => 'ro',
  13         default => sub { [] },
  14     );
  15 }
  16
  17 sub found_leaks {
  18     my ($ctx, @leaks) = @_;
  19     push @{ $ctx->leaks }, @leaks;
  20 }
  21
  22 sub count_leaks {
  23     my ($ctx) = @_;
  24     return scalar @{ $ctx->leaks };
  25 }
  26
  27 sub execute {
  28     my $c      = shift;
  29     my $class  = ref( $c->component( $_[0] ) ) || $_[0];
  30     my $action = $_[1]->reverse;
  31
  32     my $method;
  33
  34     if ( $action =~ /->(\w+)$/ ) {
  35         $method = $1;
  36     }
  37     elsif ( $action =~ /\/(\w+)$/ ) {
  38         $method = $1;
  39     }
  40     elsif ( $action =~ /^(\w+)$/ ) {
  41         $method = $action;
  42     }
  43
  44     if ( $class && $method && $method !~ /^_/ ) {
  45         my $executed = sprintf( "%s->%s", $class, $method );
  46         my @executed = $c->response->headers->header('X-Catalyst-Executed');
  47         push @executed, $executed;
  48         $c->response->headers->header(
  49             'X-Catalyst-Executed' => join ', ',
  50             @executed
  51         );
  52     }
  53     no warnings 'recursion';
  54     return $c->SUPER::execute(@_);
  55 }
  56
  57 # Replace the very large HTML error page with
  58 # useful info if something crashes during a test
  59 sub finalize_error {
  60     my $c = shift;
  61
  62     $c->next::method(@_);
  63
  64     $c->res->status(500);
  65     $c->res->body( 'FATAL ERROR: ' . join( ', ', @{ $c->error } ) );
  66 }
  67
  68 1;
  69