lib/CatalystX/Controller/WrapCGI.pm

   1 package CatalystX::Controller::WrapCGI;
   2
   3 # AUTHOR: Matt S Trout, mst@shadowcatsystems.co.uk
   4 # Original development sponsored by http://www.altinity.com/
   5
   6 use strict;
   7 use warnings;
   8 use base 'Catalyst::Controller';
   9
  10 use HTTP::Request::AsCGI;
  11 use HTTP::Request;
  12 use URI;
  13
  14 # Hack-around because Catalyst::Engine::HTTP goes and changes
  15 # them to be the remote socket, and FCGI.pm does even dumber things.
  16
  17 open(*REAL_STDIN, "<&=".fileno(*STDIN));
  18 open(*REAL_STDOUT, ">>&=".fileno(*STDOUT));
  19
  20 sub cgi_to_response {
  21   my ($self, $c, $script) = @_;
  22   my $res = $self->wrap_cgi($c, $script);
  23
  24   # if the CGI doesn't set the response code but sets location they were
  25   # probably trying to redirect so set 302 for them
  26
  27   my $location = $res->headers->header('Location');
  28
  29   if (defined $location && length $location && $res->code == 200) {
  30     $c->res->status(302);
  31   } else {
  32     $c->res->status($res->code);
  33   }
  34   $c->res->body($res->content);
  35   $c->res->headers($res->headers);
  36 }
  37
  38 sub wrap_cgi {
  39   my ($self, $c, $call) = @_;
  40   my $req = HTTP::Request->new(
  41     map { $c->req->$_ } qw/method uri headers/
  42   );
  43   my $body = $c->req->body;
  44   my $body_content = '';
  45
  46   $req->content_type($c->req->content_type); # set this now so we can override
  47
  48   if ($body) { # Slurp from body filehandle
  49     local $/; $body_content = <$body>;
  50   } else {
  51     my $body_params = $c->req->body_parameters;
  52     if (%$body_params) {
  53       my $encoder = URI->new;
  54       $encoder->query_form(%$body_params);
  55       $body_content = $encoder->query;
  56       $req->content_type('application/x-www-form-urlencoded');
  57     }
  58   }
  59
  60   $req->content($body_content);
  61   $req->content_length(length($body_content));
  62   my $user = (($c->can('user_exists') && $c->user_exists)
  63                ? eval { $c->user->obj->username }
  64                 : '');
  65   my $env = HTTP::Request::AsCGI->new(
  66               $req,
  67               REMOTE_USER => $user,
  68               %ENV
  69             );
  70
  71   {
  72     local *STDIN = \*REAL_STDIN;   # restore the real ones so the filenos
  73     local *STDOUT = \*REAL_STDOUT; # are 0 and 1 for the env setup
  74
  75     my $old = select(REAL_STDOUT); # in case somebody just calls 'print'
  76
  77     my $saved_error;
  78
  79     $env->setup;
  80     eval { $call->() };
  81     $saved_error = $@;
  82     $env->restore;
  83
  84     select($old);
  85
  86     warn "CGI invoke failed: $saved_error" if $saved_error;
  87
  88   }
  89
  90   return $env->response;
  91 }
  92
  93 1;