lib/Catalyst/Controller/WrapCGI.pm

   1 package Catalyst::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::Escape;
  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   if (length($res->headers->header('Location')) && $res->code == 200) {
  28     $c->res->status(302);
  29   } else {
  30     $c->res->status($res->code);
  31   }
  32   $c->res->body($res->content);
  33   $c->res->headers($res->headers);
  34 }
  35
  36 sub wrap_cgi {
  37   my ($self, $c, $call) = @_;
  38   my $req = HTTP::Request->new(
  39     map { $c->req->$_ } qw/method uri headers/
  40   );
  41   my $body = $c->req->body;
  42   my $body_content = '';
  43
  44   $req->content_type($c->req->content_type); # set this now so we can override
  45
  46   if ($body) { # Slurp from body filehandle
  47     local $/; $body_content = <$body>;
  48   } else {
  49     my $body_params = $c->req->body_parameters;
  50     if (keys %$body_params) {
  51       my @parts;
  52       foreach my $key (keys %$body_params) {
  53         my $raw = $body_params->{$key};
  54         foreach my $value (ref $raw ? @$raw : ($raw)) {
  55           push(@parts, join('=', map { uri_escape($_) } ($key, $value)));
  56         }
  57       }
  58       $body_content = join('&', @parts);
  59       $req->content_type('application/x-www-form-urlencoded');
  60     }
  61   }
  62
  63   #warn "Body type: ".$req->content_type;
  64   #warn "Body: ${body_content}";
  65
  66   $req->content($body_content);
  67   $req->content_length(length($body_content));
  68   my $user = (($c->can('user_exists') && $c->user_exists)
  69                ? $c->user_object->username
  70                 : '');
  71   my $env = HTTP::Request::AsCGI->new(
  72               $req,
  73               REMOTE_USER => $user,
  74               PERL5LIB => $ENV{PERL5LIB}  # propagate custom perl lib paths
  75             );
  76
  77   {
  78     local *STDIN = \*REAL_STDIN;   # restore the real ones so the filenos
  79     local *STDOUT = \*REAL_STDOUT; # are 0 and 1 for the env setup
  80
  81     my $old = select(REAL_STDOUT); # in case somebody just calls 'print'
  82
  83     my $saved_error;
  84
  85     $env->setup;
  86     eval { $call->() };
  87     $saved_error = $@;
  88     $env->restore;
  89
  90     select($old);
  91
  92     warn "CGI invoke failed: $saved_error" if $saved_error;
  93
  94   }
  95
  96   return $env->response;
  97 }
  98
  99 1;