X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCatalyst%2FController%2FWrapCGI.pm;h=a2897a52b9c8efae9495d88aa7bc748d191cd3e9;hb=49ad9853ee21e140d06393352ecb4f0d5cbc8410;hp=11f2fe76acae586d0cec72aa6786e8cc3e45d3ac;hpb=0d83c5de80494ceb3f8bf7c39206b477d5f314e5;p=catagits%2FCatalyst-Controller-WrapCGI.git diff --git a/lib/Catalyst/Controller/WrapCGI.pm b/lib/Catalyst/Controller/WrapCGI.pm index 11f2fe7..a2897a5 100644 --- a/lib/Catalyst/Controller/WrapCGI.pm +++ b/lib/Catalyst/Controller/WrapCGI.pm @@ -1,5 +1,6 @@ package Catalyst::Controller::WrapCGI; +use 5.008_001; use Moose; use mro 'c3'; @@ -8,19 +9,18 @@ extends 'Catalyst::Controller'; use HTTP::Request::AsCGI (); use HTTP::Request (); use URI (); -use Catalyst::Exception (); +use URI::Escape; +use HTTP::Request::Common; + +use namespace::clean -except => 'meta'; =head1 NAME Catalyst::Controller::WrapCGI - Run CGIs in Catalyst -=head1 VERSION - -Version 0.0030 - =cut -our $VERSION = '0.0030'; +our $VERSION = '0.029'; =head1 SYNOPSIS @@ -48,7 +48,7 @@ In your .conf, configure which environment variables to pass: pass_env PERL5LIB pass_env PATH pass_env /^MYAPP_/ - kill_env MOD_PERL + kill_env MYAPP_BAD @@ -62,22 +62,32 @@ with L 5.8 onward. If you just want to run CGIs from files, see L. +C will be set to C<< $c->user->obj->$username_field >> if +available, or to C<< $c->req->remote_user >> otherwise. + =head1 CONFIGURATION +=head2 pass_env + 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. +=head2 kill_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' ]>. +Default is to pass the whole of C<%ENV>, except for entries listed in +L below. + +=head2 username_field -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'. +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. @@ -91,12 +101,14 @@ 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 @@ -119,18 +131,21 @@ sub cgi_to_response { $c->res->headers($res->headers); } -=head2 $self->wrap_cgi($c, $coderef) +=head2 wrap_cgi -Runs $coderef in a CGI environment using L, returns an +C<< $self->wrap_cgi($c, $coderef) >> + +Runs C<$coderef> in a CGI environment using L, returns an L. -The CGI environment is set up based on $c. +The CGI environment is set up based on C<$c>. 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. +environment variables to pass, the whole of %ENV is used (with exceptions listed +in L. -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 @@ -148,7 +163,28 @@ sub wrap_cgi { local $/; $body_content = <$body>; } else { my $body_params = $c->req->body_parameters; - if (%$body_params) { + + if (my %uploads = %{ $c->req->uploads }) { + my $post = POST 'http://localhost/', + Content_Type => 'form-data', + Content => [ + %$body_params, + map { + my $upl = $uploads{$_}; + $_ => [ + undef, + $upl->filename, + Content => $upl->slurp, + map { + my $header = $_; + map { $header => $_ } $upl->headers->header($header) + } $upl->headers->header_field_names + ] + } keys %uploads + ]; + $body_content = $post->content; + $req->content_type($post->header('Content-Type')); + } elsif (%$body_params) { my $encoder = URI->new; $encoder->query_form(%$body_params); $body_content = $encoder->query; @@ -156,8 +192,6 @@ sub wrap_cgi { } } - my $filtered_env = $self->_filtered_env(\%ENV); - $req->content($body_content); $req->content_length(length($body_content)); @@ -167,13 +201,19 @@ sub wrap_cgi { ? eval { $c->user->obj->$username_field } : ''); - my $path_info = '/'.join '/' => @{ $c->req->args }; + $username ||= $c->req->remote_user if $c->req->can('remote_user'); + + my $path_info = '/'.join '/' => map { + utf8::is_utf8($_) ? uri_escape_utf8($_) : uri_escape($_) + } @{ $c->req->args }; my $env = HTTP::Request::AsCGI->new( $req, ($username ? (REMOTE_USER => $username) : ()), - %$filtered_env, - PATH_INFO => $path_info + PATH_INFO => $path_info, +# eww, this is likely broken: + FILEPATH_INFO => '/'.$c->action.$path_info, + SCRIPT_NAME => $c->uri_for($c->action, $c->req->captures)->path ); { @@ -184,6 +224,8 @@ sub wrap_cgi { my $saved_error; + local %ENV = %{ $self->_filtered_env(\%ENV) }; + $env->setup; eval { $call->() }; $saved_error = $@; @@ -191,14 +233,50 @@ sub wrap_cgi { select($old); - Catalyst::Exception->throw( - message => "CGI invocation failed: $saved_error" - ) if $saved_error; + die $saved_error if $saved_error; } return $env->response; } +=head1 FILTERED ENVIRONMENT + +If you don't use the L option to restrict which environment variables +are passed in, the default is to pass the whole of C<%ENV> except the variables +listed below. + + MOD_PERL + SERVER_SOFTWARE + SERVER_NAME + GATEWAY_INTERFACE + SERVER_PROTOCOL + SERVER_PORT + REQUEST_METHOD + PATH_INFO + PATH_TRANSLATED + SCRIPT_NAME + QUERY_STRING + REMOTE_HOST + REMOTE_ADDR + AUTH_TYPE + REMOTE_USER + REMOTE_IDENT + CONTENT_TYPE + CONTENT_LENGTH + HTTP_ACCEPT + HTTP_USER_AGENT + +C<%ENV> can be further trimmed using L. + +=cut + +my $DEFAULT_KILL_ENV = [qw/ + MOD_PERL SERVER_SOFTWARE SERVER_NAME GATEWAY_INTERFACE SERVER_PROTOCOL + SERVER_PORT REQUEST_METHOD PATH_INFO PATH_TRANSLATED SCRIPT_NAME QUERY_STRING + REMOTE_HOST REMOTE_ADDR AUTH_TYPE REMOTE_USER REMOTE_IDENT CONTENT_TYPE + CONTENT_LENGTH HTTP_ACCEPT HTTP_USER_AGENT +/]; + sub _filtered_env { my ($self, $env) = @_; my @ok; @@ -208,7 +286,7 @@ sub _filtered_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 = $DEFAULT_KILL_ENV unless defined $kill_env; $kill_env = [ $kill_env ] unless ref $kill_env; if (@$pass_env) { @@ -235,27 +313,36 @@ sub _filtered_env { return { map {; $_ => $env->{$_} } @ok }; } +__PACKAGE__->meta->make_immutable; -=head1 ACKNOWLEDGEMENTS +=head1 DIRECT SOCKET/NPH SCRIPTS -Original development sponsored by L +This currently won't work: -=head1 SEE ALSO + #!/usr/bin/perl -L, L, -L, L, L + use CGI ':standard'; -=head1 AUTHORS + $| = 1; -Originally written by: + print header; -Matt S. Trout, C<< >> + for (0..1000) { + print $_, br, "\n"; + sleep 1; + } -Contributors: +because the coderef is executed synchronously with C pointing to a temp +file. -Rafael Kitover C<< >> +=head1 ACKNOWLEDGEMENTS -Hans Dieter Pearcey C<< >> +Original development sponsored by L + +=head1 SEE ALSO + +L, L, +L, L, L =head1 BUGS @@ -289,9 +376,22 @@ L =back +=head1 AUTHOR + +Matt S. Trout C<< >> + +=head1 CONTRIBUTORS + +Rafael Kitover C<< >> + +Hans Dieter Pearcey C<< >> + +Some code stolen from Tatsuhiko Miyagawa's L. + =head1 COPYRIGHT & LICENSE -Copyright (c) 2008 Matt S. Trout +Copyright (c) 2008-2009 L and +L. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.