t/lib/TestApp.pm

   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 use TestApp::Context;
  16
  17 use Moose;
  18 use namespace::autoclean;
  19
  20 our $VERSION = '0.01';
  21
  22 TestApp->config( name => 'TestApp', root => '/some/dir' );
  23
  24 TestApp->context_class( 'TestApp::Context' );
  25 TestApp->setup;
  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 {
  69     no warnings 'redefine';
  70     sub Catalyst::Log::error { }
  71 }
  72
  73 # Make sure we can load Inline plugins.
  74
  75 package Catalyst::Plugin::Test::Inline;
  76
  77 use strict;
  78
  79 use base qw/Class::Data::Inheritable/;
  80
  81 1;