X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCatalyst%2FController%2FWrapCGI.pm;h=262e960025b190fc51d0d1ede00e24273af698a6;hb=f410f043b41cc59d08cb1aa015378888c8fe88b7;hp=71b35926e5ce0609d0aeeb98e0a0a70d1cec63b7;hpb=2340af9d7778ff7ed8e40289015463570ed09c6e;p=catagits%2FCatalyst-Controller-WrapCGI.git diff --git a/lib/Catalyst/Controller/WrapCGI.pm b/lib/Catalyst/Controller/WrapCGI.pm index 71b3592..262e960 100644 --- a/lib/Catalyst/Controller/WrapCGI.pm +++ b/lib/Catalyst/Controller/WrapCGI.pm @@ -1,13 +1,17 @@ package Catalyst::Controller::WrapCGI; -use strict; -use warnings; -use parent 'Catalyst::Controller'; +use Moose; +use mro 'c3'; -use HTTP::Request::AsCGI; -use HTTP::Request; -use URI; +extends 'Catalyst::Controller'; + +use HTTP::Request::AsCGI (); +use HTTP::Request (); +use URI (); use Catalyst::Exception (); +use URI::Escape; + +use namespace::clean -except => 'meta'; =head1 NAME @@ -15,11 +19,11 @@ Catalyst::Controller::WrapCGI - Run CGIs in Catalyst =head1 VERSION -Version 0.0025 +Version 0.0030 =cut -our $VERSION = '0.0025'; +our $VERSION = '0.0030'; =head1 SYNOPSIS @@ -47,6 +51,7 @@ In your .conf, configure which environment variables to pass: pass_env PERL5LIB pass_env PATH pass_env /^MYAPP_/ + kill_env MOD_PERL @@ -62,14 +67,20 @@ If you just want to run CGIs from files, see L. =head1 CONFIGURATION -C<$your_controller->{CGI}{pass_env}> should be an array of environment variables +C<< $your_controller->{CGI}{pass_env} >> should be an array of environment variables or regular expressions to pass through to your CGIs. Entries surrounded by C characters are considered regular expressions. -Default is to pass the whole of C<%ENV>. +C<< $your_controller->{CGI}{kill_env} >> should be an array of environment +variables or regular expressions to remove from the environment before passing +it to your CGIs. Entries surrounded by C characters are considered regular +expressions. + +Default is to pass the whole of C<%ENV>, except for C (that is, the +default C is C<[ 'MOD_PERL' ]>. -C<{CGI}{username_field}> should be the field for your user's name, which will be -read from C<$c->user->obj>. Defaults to 'username'. +C<< $your_controller->{CGI}{username_field} >> should be the field for your user's name, which will be +read from C<< $c->user->obj >>. Defaults to 'username'. See L for an example. @@ -83,17 +94,20 @@ open my $REAL_STDOUT, ">>&=".fileno(*STDOUT); =head1 METHODS -=head2 $self->cgi_to_response($c, $coderef) +=head2 cgi_to_response + +C<<$self->cgi_to_response($c, $coderef)>> Does the magic of running $coderef in a CGI environment, and populating the appropriate parts of your Catalyst context with the results. -Calls wrap_cgi (below.) +Calls L. =cut 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 @@ -110,7 +124,9 @@ sub cgi_to_response { $c->res->headers($res->headers); } -=head2 $self->wrap_cgi($c, $coderef) +=head2 wrap_cgi + +C<<$self->wrap_cgi($c, $coderef)>> Runs $coderef in a CGI environment using L, returns an L. @@ -121,7 +137,7 @@ The environment variables to pass on are taken from the configuration for your Controller, see L for an example. If you don't supply a list of environment variables to pass, the whole of %ENV is used. -Used by cgi_to_response (above), which is probably what you want to use as well. +Used by L, which is probably what you want to use as well. =cut @@ -147,22 +163,7 @@ sub wrap_cgi { } } - my @env; - - my $pass_env = $self->{CGI}{pass_env}; - $pass_env = [] if not defined $pass_env; - $pass_env = [ $pass_env ] unless ref $pass_env; - - for (@$pass_env) { - if (m!^/(.*)/\z!) { - my $re = qr/$1/; - push @env, grep /$re/, keys %ENV; - } else { - push @env, $_; - } - } - - @env = keys %ENV unless @env; + my $filtered_env = $self->_filtered_env(\%ENV); $req->content($body_content); $req->content_length(length($body_content)); @@ -172,10 +173,16 @@ sub wrap_cgi { my $username = (($c->can('user_exists') && $c->user_exists) ? eval { $c->user->obj->$username_field } : ''); + + my $path_info = '/'.join '/' => map uri_escape_utf8($_), @{ $c->req->args }; + my $env = HTTP::Request::AsCGI->new( $req, ($username ? (REMOTE_USER => $username) : ()), - map { ($_, $ENV{$_}) } @env + %$filtered_env, + PATH_INFO => $path_info, + FILEPATH_INFO => '/'.$c->action.$path_info, # eww + SCRIPT_NAME => $c->uri_for($c->action)->path ); { @@ -201,6 +208,44 @@ 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 }; +} + +__PACKAGE__->meta->make_immutable; + =head1 ACKNOWLEDGEMENTS Original development sponsored by L @@ -210,10 +255,18 @@ Original development sponsored by L L, L, L, L, L -=head1 AUTHOR +=head1 AUTHORS + +Originally written by: Matt S. Trout, C<< >> +Contributors: + +Rafael Kitover C<< >> + +Hans Dieter Pearcey C<< >> + =head1 BUGS Please report any bugs or feature requests to C