[Catalyst-commits] r6283 - in trunk: . CatalystX-Controller-WrapCGI CatalystX-Controller-WrapCGI/lib CatalystX-Controller-WrapCGI/lib/CatalystX CatalystX-Controller-WrapCGI/lib/CatalystX/Controller

[matthewt at dev.catalyst.perl.org]

Author: matthewt
Date: 2007-04-09 15:11:49 +0100 (Mon, 09 Apr 2007)
New Revision: 6283

Added:
   trunk/CatalystX-Controller-WrapCGI/
   trunk/CatalystX-Controller-WrapCGI/lib/
   trunk/CatalystX-Controller-WrapCGI/lib/CatalystX/
   trunk/CatalystX-Controller-WrapCGI/lib/CatalystX/Controller/
   trunk/CatalystX-Controller-WrapCGI/lib/CatalystX/Controller/WrapCGI.pm
Log:
initial import of CGI wrapping code

Added: trunk/CatalystX-Controller-WrapCGI/lib/CatalystX/Controller/WrapCGI.pm
===================================================================
--- trunk/CatalystX-Controller-WrapCGI/lib/CatalystX/Controller/WrapCGI.pm	                        (rev 0)
+++ trunk/CatalystX-Controller-WrapCGI/lib/CatalystX/Controller/WrapCGI.pm	2007-04-09 14:11:49 UTC (rev 6283)
@@ -0,0 +1,99 @@
+package CatalystX::Controller::WrapCGI;
+
+# AUTHOR: Matt S Trout, mst at shadowcatsystems.co.uk
+# Original development sponsored by http://www.altinity.com/
+
+use strict;
+use warnings;
+use base 'Catalyst::Controller';
+
+use HTTP::Request::AsCGI;
+use HTTP::Request;
+use URI::Escape;
+
+# Hack-around because Catalyst::Engine::HTTP goes and changes
+# them to be the remote socket, and FCGI.pm does even dumber things.
+
+open(*REAL_STDIN, "<&=".fileno(*STDIN));
+open(*REAL_STDOUT, ">>&=".fileno(*STDOUT));
+
+sub cgi_to_response {
+  my ($self, $c, $script) = @_;
+  my $res = $self->wrap_cgi($c, $script);
+
+  # if the CGI doesn't set the response code but sets location they were
+  # probably trying to redirect so set 302 for them
+
+  if (length($res->headers->header('Location')) && $res->code == 200) {
+    $c->res->status(302);
+  } else { 
+    $c->res->status($res->code);
+  }
+  $c->res->body($res->content);
+  $c->res->headers($res->headers);
+}
+
+sub wrap_cgi {
+  my ($self, $c, $call) = @_;
+  my $req = HTTP::Request->new(
+    map { $c->req->$_ } qw/method uri headers/
+  );
+  my $body = $c->req->body;
+  my $body_content = '';
+
+  $req->content_type($c->req->content_type); # set this now so we can override
+
+  if ($body) { # Slurp from body filehandle
+    local $/; $body_content = <$body>;
+  } else {
+    my $body_params = $c->req->body_parameters;
+    if (keys %$body_params) {
+      my @parts;
+      foreach my $key (keys %$body_params) {
+        my $raw = $body_params->{$key};
+        foreach my $value (ref $raw ? @$raw : ($raw)) {
+          push(@parts, join('=', map { uri_escape($_) } ($key, $value)));
+        }
+      }
+      $body_content = join('&', @parts);
+      $req->content_type('application/x-www-form-urlencoded');
+    }
+  }
+
+  #warn "Body type: ".$req->content_type;
+  #warn "Body: ${body_content}";
+      
+  $req->content($body_content);
+  $req->content_length(length($body_content));
+  my $user = (($c->can('user_exists') && $c->user_exists)
+               ? $c->user_object->username
+                : '');
+  my $env = HTTP::Request::AsCGI->new(
+              $req,
+              REMOTE_USER => $user,
+              PERL5LIB => $ENV{PERL5LIB}  # propagate custom perl lib paths
+            );
+
+  {
+    local *STDIN = \*REAL_STDIN;   # restore the real ones so the filenos
+    local *STDOUT = \*REAL_STDOUT; # are 0 and 1 for the env setup
+
+    my $old = select(REAL_STDOUT); # in case somebody just calls 'print'
+
+    my $saved_error;
+
+    $env->setup;
+    eval { $call->() };
+    $saved_error = $@;
+    $env->restore;
+
+    select($old);
+
+    warn "CGI invoke failed: $saved_error" if $saved_error;
+
+  }
+
+  return $env->response;
+}
+
+1;