t/lib/TestApp.pm

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