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 sub class_forward_test_method {
  59     my ( $self, $c ) = @_;
  60     $c->response->headers->header( 'X-Class-Forward-Test-Method' => 1 );
  61 }
  62
  63 {
  64     no warnings 'redefine';
  65     sub Catalyst::Log::error { }
  66 }
  67 1;