lib/SGN/Controller/CGI.pm

   1 =head1 NAME
   2
   3 SGN::Controller::CGI - run SGN CGI scripts
   4
   5 =cut
   6
   7 package SGN::Controller::CGI;
   8
   9 use Moose;
  10 use namespace::autoclean;
  11
  12 BEGIN{ extends 'Catalyst::Controller::CGIBin'; }
  13
  14 __PACKAGE__->config(
  15     cgi_root_path => '/',
  16     CGI => {
  17         pass_env => [qw[
  18             PERL5LIB
  19             PATH
  20             PROJECT_NAME
  21             HOME
  22             R_LIBS
  23             R_LIBS_USER
  24             R_LIBS_SITE
  25         ]],
  26     },
  27     cgi_file_pattern => '*.pl',
  28 );
  29
  30
  31 use Carp;
  32 use File::Basename;
  33
  34 my %skip = map { $_ => 1 } qw(
  35   another_page_that_doesnt_compile.pl
  36   page_with_syntax_error.pl
  37 );
  38
  39 # all our .pl cgis are perl, just match the filenames, which speeds up
  40 # startup considerably.
  41 sub is_perl_cgi {
  42     my ($self,$path) = @_;
  43     return 0 if $skip{ basename($path) };
  44     return $path =~ /\.pl$/;
  45 }
  46
  47 if( $ENV{SGN_SKIP_CGI} ) {
  48     override 'cgi_dir' => sub { File::Spec->devnull },
  49 }
  50
  51 # force CGI backtrace only if app is starting, and is in debug mode
  52 if( eval{ SGN->debug } ) {
  53     around 'wrap_cgi' => sub {
  54         my $orig = shift;
  55         my $self = shift;
  56         my ($c) = @_;
  57         local $SIG{__DIE__} =
  58             $c->debug
  59                 ? sub {
  60                     die map {
  61                         s/\sCatalyst::Controller::CGIBin.+//s;
  62                         $_
  63                     } Carp::longmess(@_);
  64                   }
  65                 : $SIG{__DIE__};
  66         $self->$orig( @_ );
  67     };
  68 }
  69
  70 # remove the content-length for CGI responses after running them, let
  71 # catalyst recalculate it later in the response cycle.  this works
  72 # around a bug somewhere in HTTP::Request::AsCGI
  73 after 'cgi_to_response' => sub {
  74     my ( $self, $c ) = @_;
  75     $c->res->headers->remove_header('content-length');
  76 };
  77
  78 sub cgi_action_for {
  79     my ( $self, $path ) = @_;
  80
  81     my $action_name = $self->cgi_action($path)
  82         or return;
  83
  84     return $self->action_for( $action_name )
  85 }
  86
  87 1;