t/lib/TestApp.pm

   1 package TestApp;
   2
   3 use strict;
   4 use Catalyst qw/
   5     Test::MangleDollarUnderScore
   6     Test::Errors
   7     Test::Plugin
   8     Test::Inline
   9     +TestApp::Plugin::FullyQualified
  10     +TestApp::Plugin::AddDispatchTypes
  11     +TestApp::Role
  12 /;
  13 use Catalyst::Utils;
  14
  15 use Moose;
  16 use namespace::autoclean;
  17
  18 our $VERSION = '0.01';
  19
  20 TestApp->config( name => 'TestApp', root => '/some/dir' );
  21
  22 if (eval { Class::MOP::load_class('CatalystX::LeakChecker'); 1 }) {
  23 #    with 'CatalystX::LeakChecker';   # LeakChecker dose not work yet with Catalyst::Context - zby
  24
  25     has leaks => (
  26         is      => 'ro',
  27         default => sub { [] },
  28     );
  29 }
  30
  31 sub found_leaks {
  32     my ($ctx, @leaks) = @_;
  33     push @{ $ctx->leaks }, @leaks;
  34 }
  35
  36 sub count_leaks {
  37     my ($ctx) = @_;
  38     return scalar @{ $ctx->leaks };
  39 }
  40
  41 TestApp->context_class( 'TestApp::Context' );
  42 TestApp->setup;
  43
  44 around prepare => sub {
  45     my $orig = shift;
  46     my $self = shift;
  47
  48     my $c = $self->$orig(@_);
  49
  50     $c->response->header( 'X-Catalyst-Engine' => $c->engine );
  51     $c->response->header( 'X-Catalyst-Debug' => $c->debug ? 1 : 0 );
  52
  53     {
  54         my $components = join( ', ', sort keys %{ $c->components } );
  55         $c->response->header( 'X-Catalyst-Components' => $components );
  56     }
  57
  58     {
  59         no strict 'refs';
  60         my $plugins = join ', ', $self->registered_plugins;
  61         $c->response->header( 'X-Catalyst-Plugins' => $plugins );
  62     }
  63
  64     return $c;
  65 };
  66
  67
  68 {
  69     package TestApp::Context;
  70     use Moose;
  71     extends 'Catalyst::Context';
  72
  73     sub execute {
  74         my $c      = shift;
  75         my $class  = ref( $c->component( $_[0] ) ) || $_[0];
  76         my $action = $_[1]->reverse;
  77
  78         my $method;
  79
  80         if ( $action =~ /->(\w+)$/ ) {
  81             $method = $1;
  82         }
  83         elsif ( $action =~ /\/(\w+)$/ ) {
  84             $method = $1;
  85         }
  86         elsif ( $action =~ /^(\w+)$/ ) {
  87             $method = $action;
  88         }
  89
  90         if ( $class && $method && $method !~ /^_/ ) {
  91             my $executed = sprintf( "%s->%s", $class, $method );
  92             my @executed = $c->response->headers->header('X-Catalyst-Executed');
  93             push @executed, $executed;
  94             $c->response->headers->header(
  95                 'X-Catalyst-Executed' => join ', ',
  96                 @executed
  97             );
  98         }
  99         no warnings 'recursion';
 100         return $c->SUPER::execute(@_);
 101     }
 102
 103     # Replace the very large HTML error page with
 104     # useful info if something crashes during a test
 105     sub finalize_error {
 106         my $c = shift;
 107
 108         $c->next::method(@_);
 109
 110         $c->res->status(500);
 111         $c->res->body( 'FATAL ERROR: ' . join( ', ', @{ $c->error } ) );
 112     }
 113
 114     after prepare_action => sub{
 115         my $c = shift;
 116         $c->res->header( 'X-Catalyst-Action' => $c->req->action );
 117     };
 118
 119 }
 120
 121 {
 122     no warnings 'redefine';
 123     sub Catalyst::Log::error { }
 124 }
 125
 126 # Make sure we can load Inline plugins.
 127
 128 package Catalyst::Plugin::Test::Inline;
 129
 130 use strict;
 131
 132 use base qw/Class::Data::Inheritable/;
 133
 134 1;