From: Rafael Kitover <rkitover@cpan.org>
Date: Mon, 27 Apr 2009 03:07:15 +0000 (+0000)
Subject: C::C::WrapCGI - add PATH_INFO support
X-Git-Tag: 0.030~44
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0d83c5de80494ceb3f8bf7c39206b477d5f314e5;p=catagits%2FCatalyst-Controller-WrapCGI.git

C::C::WrapCGI - add PATH_INFO support
---

diff --git a/Changes b/Changes
index b05f4b8..4c79c7e 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,8 @@
 Revision history for Catalyst-Controller-WrapCGI
 
+    - configurable cgi_dir
+    - support for PATH_INFO
+
 0.0029  2009-04-26 20:54:28
     - Allow more control over public paths to CGIBin actions. (confound)
     - Override exit() in CGIBin-wrapped Perl cgis to avoid terminating the
diff --git a/lib/Catalyst/Controller/CGIBin.pm b/lib/Catalyst/Controller/CGIBin.pm
index b31b0da..0277381 100644
--- a/lib/Catalyst/Controller/CGIBin.pm
+++ b/lib/Catalyst/Controller/CGIBin.pm
@@ -22,11 +22,11 @@ Catalyst::Controller::CGIBin - Serve CGIs from root/cgi-bin
 
 =head1 VERSION
 
-Version 0.007
+Version 0.008
 
 =cut
 
-our $VERSION = '0.007';
+our $VERSION = '0.008';
 
 =head1 SYNOPSIS
 
@@ -287,10 +287,12 @@ sub wrap_nonperl_cgi {
 L<Catalyst::Controller::WrapCGI>, L<CatalystX::GlobalContext>,
 L<Catalyst::Controller>, L<CGI>, L<Catalyst>
 
-=head1 AUTHOR
+=head1 AUTHORS
 
 Rafael Kitover, C<< <rkitover at cpan.org> >>
 
+Hans Dieter Pearcey, C<< <hdp at cpan.org> >>
+
 =head1 BUGS
 
 Please report any bugs or feature requests to C<bug-catalyst-controller-wrapcgi at
diff --git a/lib/Catalyst/Controller/WrapCGI.pm b/lib/Catalyst/Controller/WrapCGI.pm
index e119f5b..11f2fe7 100644
--- a/lib/Catalyst/Controller/WrapCGI.pm
+++ b/lib/Catalyst/Controller/WrapCGI.pm
@@ -5,9 +5,9 @@ use mro 'c3';
 
 extends 'Catalyst::Controller';
 
-use HTTP::Request::AsCGI;
-use HTTP::Request;
-use URI;
+use HTTP::Request::AsCGI ();
+use HTTP::Request ();
+use URI ();
 use Catalyst::Exception ();
 
 =head1 NAME
@@ -16,11 +16,11 @@ Catalyst::Controller::WrapCGI - Run CGIs in Catalyst
 
 =head1 VERSION
 
-Version 0.0029
+Version 0.0030
 
 =cut
 
-our $VERSION = '0.0029';
+our $VERSION = '0.0030';
 
 =head1 SYNOPSIS
 
@@ -102,6 +102,7 @@ Calls wrap_cgi (below.)
 
 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
@@ -133,42 +134,6 @@ Used by cgi_to_response (above), which is probably what you want to use as well.
 
 =cut
 
-sub _filtered_env {
-  my ($self, $env) = @_;
-  my @ok;
-
-  my $pass_env = $self->{CGI}{pass_env};
-  $pass_env = []            if not defined $pass_env;
-  $pass_env = [ $pass_env ] unless ref $pass_env;
-
-  my $kill_env = $self->{CGI}{kill_env};
-  $kill_env = [ 'MOD_PERL' ] unless defined $kill_env;
-  $kill_env = [ $kill_env ]  unless ref $kill_env;
-
-  if (@$pass_env) {
-    for (@$pass_env) {
-      if (m!^/(.*)/\z!) {
-        my $re = qr/$1/;
-        push @ok, grep /$re/, keys %$env;
-      } else {
-        push @ok, $_;
-      }
-    }
-  } else {
-    @ok = keys %$env;
-  }
-
-  for my $k (@$kill_env) {
-    if ($k =~ m!^/(.*)/\z!) {
-      my $re = qr/$1/;
-      @ok = grep { ! /$re/ } @ok;
-    } else {
-      @ok = grep { $_ ne $k } @ok;
-    }
-  }
-  return { map {; $_ => $env->{$_} } @ok };
-}
-
 sub wrap_cgi {
   my ($self, $c, $call) = @_;
   my $req = HTTP::Request->new(
@@ -201,10 +166,14 @@ sub wrap_cgi {
   my $username = (($c->can('user_exists') && $c->user_exists)
                ? eval { $c->user->obj->$username_field }
                 : '');
+
+  my $path_info = '/'.join '/' => @{ $c->req->args };
+
   my $env = HTTP::Request::AsCGI->new(
               $req,
               ($username ? (REMOTE_USER => $username) : ()),
               %$filtered_env,
+              PATH_INFO => $path_info
             );
 
   {
@@ -230,6 +199,43 @@ sub wrap_cgi {
   return $env->response;
 }
 
+sub _filtered_env {
+  my ($self, $env) = @_;
+  my @ok;
+
+  my $pass_env = $self->{CGI}{pass_env};
+  $pass_env = []            if not defined $pass_env;
+  $pass_env = [ $pass_env ] unless ref $pass_env;
+
+  my $kill_env = $self->{CGI}{kill_env};
+  $kill_env = [ 'MOD_PERL' ] unless defined $kill_env;
+  $kill_env = [ $kill_env ]  unless ref $kill_env;
+
+  if (@$pass_env) {
+    for (@$pass_env) {
+      if (m!^/(.*)/\z!) {
+        my $re = qr/$1/;
+        push @ok, grep /$re/, keys %$env;
+      } else {
+        push @ok, $_;
+      }
+    }
+  } else {
+    @ok = keys %$env;
+  }
+
+  for my $k (@$kill_env) {
+    if ($k =~ m!^/(.*)/\z!) {
+      my $re = qr/$1/;
+      @ok = grep { ! /$re/ } @ok;
+    } else {
+      @ok = grep { $_ ne $k } @ok;
+    }
+  }
+  return { map {; $_ => $env->{$_} } @ok };
+}
+
+
 =head1 ACKNOWLEDGEMENTS
 
 Original development sponsored by L<http://www.altinity.com/>
@@ -239,10 +245,18 @@ Original development sponsored by L<http://www.altinity.com/>
 L<Catalyst::Controller::CGIBin>, L<CatalystX::GlobalContext>,
 L<Catalyst::Controller>, L<CGI>, L<Catalyst>
 
-=head1 AUTHOR
+=head1 AUTHORS
+
+Originally written by:
 
 Matt S. Trout, C<< <mst at shadowcat.co.uk> >>
 
+Contributors:
+
+Rafael Kitover C<< <rkitover at cpan.org> >>
+
+Hans Dieter Pearcey C<< <hdp at cpan.org> >>
+
 =head1 BUGS
 
 Please report any bugs or feature requests to C<bug-catalyst-controller-wrapcgi
diff --git a/t/lib/TestApp/Controller/Root.pm b/t/lib/TestApp/Controller/Root.pm
index 9ca47ce..5ade07b 100644
--- a/t/lib/TestApp/Controller/Root.pm
+++ b/t/lib/TestApp/Controller/Root.pm
@@ -16,4 +16,14 @@ sub handle_cgi : Path('/cgi-bin/test.cgi') {
     $self->cgi_to_response($c, $cgi);
 }
 
+sub test_path_info : Path('/cgi-bin/test_pathinfo.cgi') {
+    my ($self, $c) = @_;
+
+    $self->cgi_to_response($c, sub {
+        my $cgi = CGI->new;
+        print $cgi->header;
+        print $ENV{PATH_INFO}
+    });
+}
+
 1;
diff --git a/t/wrap-cgi.t b/t/wrap-cgi.t
index fbf5891..2477c7d 100644
--- a/t/wrap-cgi.t
+++ b/t/wrap-cgi.t
@@ -6,7 +6,7 @@ use warnings;
 use FindBin '$Bin';
 use lib "$Bin/lib";
 
-use Test::More tests => 1;
+use Test::More tests => 2;
 
 use Catalyst::Test 'TestApp';
 use HTTP::Request::Common;
@@ -17,3 +17,7 @@ my $response = request POST '/cgi-bin/test.cgi', [
 ];
 
 is($response->content, 'foo:bar bar:baz', 'POST to CGI');
+
+$response = request '/cgi-bin/test_pathinfo.cgi/path/info';
+
+is($response->content, '/path/info', 'PATH_INFO is correct');