X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCatalyst%2FEngine.pm;h=0c42af613c91ddf3864f80dd013fe54448b4d75b;hb=8c7d83e1a7ac65611e6063544e7f650a6270f5e6;hp=80ff49f31a9defb79b98098a3185ebb060a1ff67;hpb=34d28dfd33574ce30aca69fb8700b61111d97b92;p=catagits%2FCatalyst-Runtime.git
diff --git a/lib/Catalyst/Engine.pm b/lib/Catalyst/Engine.pm
index 80ff49f..0c42af6 100644
--- a/lib/Catalyst/Engine.pm
+++ b/lib/Catalyst/Engine.pm
@@ -2,12 +2,13 @@ package Catalyst::Engine;
use strict;
use base 'Class::Accessor::Fast';
-use CGI::Cookie;
-use Data::Dumper;
+use CGI::Simple::Cookie;
+use Data::Dump qw/dump/;
use HTML::Entities;
use HTTP::Body;
use HTTP::Headers;
use URI::QueryParam;
+use Scalar::Util ();
# input position and length
__PACKAGE__->mk_accessors(qw/read_position read_length/);
@@ -16,7 +17,7 @@ __PACKAGE__->mk_accessors(qw/read_position read_length/);
use overload '""' => sub { return ref shift }, fallback => 1;
# Amount of data to read from input on each pass
-our $CHUNKSIZE = 4096;
+our $CHUNKSIZE = 64 * 1024;
=head1 NAME
@@ -40,7 +41,8 @@ Finalize body. Prints the response output.
sub finalize_body {
my ( $self, $c ) = @_;
my $body = $c->response->body;
- if ( ref $body && ( $body->can('read') || ref($body) eq 'GLOB' ) ) {
+ no warnings 'uninitialized';
+ if ( Scalar::Util::blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
while ( !eof $body ) {
read $body, my ($buffer), $CHUNKSIZE;
last unless $self->write( $c, $buffer );
@@ -54,7 +56,8 @@ sub finalize_body {
=head2 $self->finalize_cookies($c)
-Create CGI::Cookies from $c->res->cookies, and set them as response headers.
+Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
+response headers.
=cut
@@ -62,15 +65,22 @@ sub finalize_cookies {
my ( $self, $c ) = @_;
my @cookies;
- while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
-
- my $cookie = CGI::Cookie->new(
- -name => $name,
- -value => $cookie->{value},
- -expires => $cookie->{expires},
- -domain => $cookie->{domain},
- -path => $cookie->{path},
- -secure => $cookie->{secure} || 0
+
+ foreach my $name ( keys %{ $c->response->cookies } ) {
+
+ my $val = $c->response->cookies->{$name};
+
+ my $cookie = (
+ Scalar::Util::blessed($val)
+ ? $val
+ : CGI::Simple::Cookie->new(
+ -name => $name,
+ -value => $val->{value},
+ -expires => $val->{expires},
+ -domain => $val->{domain},
+ -path => $val->{path},
+ -secure => $val->{secure} || 0
+ )
);
push @cookies, $cookie->as_string;
@@ -99,7 +109,6 @@ sub finalize_error {
if ( $c->debug ) {
# For pretty dumps
- local $Data::Dumper::Terse = 1;
$error = join '', map {
'
'
. encode_entities($_)
@@ -120,15 +129,11 @@ sub finalize_error {
# Don't show response header state in dump
delete $c->res->{_finalized_headers};
- my $req = _fixup_debug_info($c->req);
- my $res = _fixup_debug_info($c->res);
- my $stash = _fixup_debug_info($c->stash);
-
my @infos;
my $i = 0;
for my $dump ( $c->dump_these ) {
my $name = $dump->[0];
- my $value = encode_entities( Dumper $dump->[1] );
+ my $value = encode_entities( dump( $dump->[1] ));
push @infos, sprintf <<"EOF", $name, $value;
@@ -307,29 +312,35 @@ sets up the L object body using L
sub prepare_body {
my ( $self, $c ) = @_;
+
+ my $length = $c->request->header('Content-Length') || 0;
- $self->read_length( $c->request->header('Content-Length') || 0 );
- my $type = $c->request->header('Content-Type');
-
- unless ( $c->request->{_body} ) {
- $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
- $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
- if exists $c->config->{uploadtmp};
- }
+ $self->read_length( $length );
- if ( $self->read_length > 0 ) {
+ if ( $length > 0 ) {
+ unless ( $c->request->{_body} ) {
+ my $type = $c->request->header('Content-Type');
+ $c->request->{_body} = HTTP::Body->new( $type, $length );
+ $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
+ if exists $c->config->{uploadtmp};
+ }
+
while ( my $buffer = $self->read($c) ) {
$c->prepare_body_chunk($buffer);
}
# paranoia against wrong Content-Length header
- my $remaining = $self->read_length - $self->read_position;
+ my $remaining = $length - $self->read_position;
if ( $remaining > 0 ) {
$self->finalize_read($c);
Catalyst::Exception->throw(
- "Wrong Content-Length value: " . $self->read_length );
+ "Wrong Content-Length value: $length" );
}
}
+ else {
+ # Defined but will cause all body code to be skipped
+ $c->request->{_body} = 0;
+ }
}
=head2 $self->prepare_body_chunk($c)
@@ -352,6 +363,9 @@ Sets up parameters from body.
sub prepare_body_parameters {
my ( $self, $c ) = @_;
+
+ return unless $c->request->{_body};
+
$c->request->body_parameters( $c->request->{_body}->param );
}
@@ -365,7 +379,7 @@ sub prepare_connection { }
=head2 $self->prepare_cookies($c)
-Parse cookies from header. Sets a L object.
+Parse cookies from header. Sets a L object.
=cut
@@ -373,7 +387,7 @@ sub prepare_cookies {
my ( $self, $c ) = @_;
if ( my $header = $c->request->header('Cookie') ) {
- $c->req->cookies( { CGI::Cookie->parse($header) } );
+ $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
}
}
@@ -393,13 +407,15 @@ sub prepare_parameters {
my ( $self, $c ) = @_;
# We copy, no references
- while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
+ foreach my $name ( keys %{ $c->request->query_parameters } ) {
+ my $param = $c->request->query_parameters->{$name};
$param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
$c->request->parameters->{$name} = $param;
}
# Merge query and body parameters
- while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
+ foreach my $name ( keys %{ $c->request->body_parameters } ) {
+ my $param = $c->request->body_parameters->{$name};
$param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
if ( my $old_param = $c->request->parameters->{$name} ) {
if ( ref $old_param eq 'ARRAY' ) {
@@ -430,16 +446,41 @@ process the query string and extract query parameters.
sub prepare_query_parameters {
my ( $self, $c, $query_string ) = @_;
+
+ # Make sure query has params
+ if ( index( $query_string, '=' ) < 0 ) {
+ return;
+ }
+
+ my %query;
# replace semi-colons
$query_string =~ s/;/&/g;
-
- my $u = URI->new( '', 'http' );
- $u->query($query_string);
- for my $key ( $u->query_param ) {
- my @vals = $u->query_param($key);
- $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
+
+ my @params = split /&/, $query_string;
+
+ for my $item ( @params ) {
+
+ my ($param, $value)
+ = map { $self->unescape_uri($_) }
+ split( /=/, $item );
+
+ $param = $self->unescape_uri($item) unless defined $param;
+
+ if ( exists $query{$param} ) {
+ if ( ref $query{$param} ) {
+ push @{ $query{$param} }, $value;
+ }
+ else {
+ $query{$param} = [ $query{$param}, $value ];
+ }
+ }
+ else {
+ $query{$param} = $value;
+ }
}
+
+ $c->request->query_parameters( \%query );
}
=head2 $self->prepare_read($c)
@@ -469,6 +510,9 @@ sub prepare_request { }
sub prepare_uploads {
my ( $self, $c ) = @_;
+
+ return unless $c->request->{_body};
+
my $uploads = $c->request->{_body}->upload;
for my $name ( keys %$uploads ) {
my $files = $uploads->{$name};
@@ -487,8 +531,20 @@ sub prepare_uploads {
# support access to the filename as a normal param
my @filenames = map { $_->{filename} } @uploads;
- $c->request->parameters->{$name} =
- @filenames > 1 ? \@filenames : $filenames[0];
+ # append, if there's already params with this name
+ if (exists $c->request->parameters->{$name}) {
+ if (ref $c->request->parameters->{$name} eq 'ARRAY') {
+ push @{ $c->request->parameters->{$name} }, @filenames;
+ }
+ else {
+ $c->request->parameters->{$name} =
+ [ $c->request->parameters->{$name}, @filenames ];
+ }
+ }
+ else {
+ $c->request->parameters->{$name} =
+ @filenames > 1 ? \@filenames : $filenames[0];
+ }
}
}
@@ -576,11 +632,20 @@ sub write {
print STDOUT $buffer;
}
-sub _fixup_debug_info {
- my $info = encode_entities Dumper shift;
- my @info = split "\n", $info;
- pop @info; shift @info;
- return join "\n",@info;
+=head2 $self->unescape_uri($uri)
+
+Unescapes a given URI using the most efficient method available. Engines such
+as Apache may implement this using Apache's C-based modules, for example.
+
+=cut
+
+sub unescape_uri {
+ my ( $self, $str ) = @_;
+
+ $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+ $str =~ s/\+/ /g;
+
+ return $str;
}
=head2 $self->finalize_output