use strict;
use warnings FATAL => 'all';
+use Encode 'decode_utf8';
+
sub UNPACKED_QUERY () { __PACKAGE__.'.unpacked_query' }
sub UNPACKED_BODY () { __PACKAGE__.'.unpacked_body' }
+sub UNPACKED_BODY_OBJECT () { __PACKAGE__.'.unpacked_body_object' }
+sub UNPACKED_UPLOADS () { __PACKAGE__.'.unpacked_uploads' }
+sub ORIG_ENV () { 'Web::Dispatch.original_env' }
sub get_unpacked_query_from {
- return $_[0]->{+UNPACKED_QUERY} ||= do {
+ return ($_[0]->{+ORIG_ENV}||$_[0])->{+UNPACKED_QUERY} ||= do {
_unpack_params($_[0]->{QUERY_STRING})
};
}
sub get_unpacked_body_from {
- return $_[0]->{+UNPACKED_BODY} ||= do {
- if (($_[0]->{CONTENT_TYPE}||'') eq 'application/x-www-form-urlencoded'
- and defined $_[0]->{CONTENT_LENGTH}) {
+ return ($_[0]->{+ORIG_ENV}||$_[0])->{+UNPACKED_BODY} ||= do {
+ my $ct = lc($_[0]->{CONTENT_TYPE}||'');
+ if (!$_[0]->{CONTENT_LENGTH}) {
+ {}
+ } elsif (index($ct, 'application/x-www-form-urlencoded') >= 0) {
$_[0]->{'psgi.input'}->read(my $buf, $_[0]->{CONTENT_LENGTH});
_unpack_params($buf);
+ } elsif (index($ct, 'multipart/form-data') >= 0) {
+ my $p = get_unpacked_body_object_from($_[0])->param;
+ # forcible arrayification
+ +{
+ map +(ref($p->{$_}) eq 'ARRAY'
+ ? ($_ => $p->{$_})
+ : ($_ => [ $p->{$_} ])
+ ), keys %$p
+ };
} else {
{}
}
};
}
+sub get_unpacked_body_object_from {
+ # we may have no object at all - so use a single element arrayref for ||=
+ return (($_[0]->{+ORIG_ENV}||$_[0])->{+UNPACKED_BODY_OBJECT} ||= do {
+ if (!$_[0]->{CONTENT_LENGTH}) {
+ [ undef ]
+ } elsif (index(lc($_[0]->{CONTENT_TYPE}||''),'multipart/form-data')==-1) {
+ [ undef ]
+ } else {
+ [ _make_http_body($_[0]) ]
+ }
+ })->[0];
+}
+
+sub get_unpacked_uploads_from {
+ $_[0]->{+UNPACKED_UPLOADS} ||= do {
+ require Web::Dispatch::Upload; require HTTP::Headers;
+ my ($final, $reason) = (
+ {}, "field %s exists with value %s but body was not multipart/form-data"
+ );
+ if (my $body = get_unpacked_body_object_from($_[0])) {
+ my $u = $body->upload;
+ $reason = "field %s exists with value %s but was not an upload";
+ foreach my $k (keys %$u) {
+ foreach my $v (ref($u->{$k}) eq 'ARRAY' ? @{$u->{$k}} : $u->{$k}) {
+ push(@{$final->{$k}||=[]}, Web::Dispatch::Upload->new(
+ %{$v},
+ headers => HTTP::Headers->new($v->{headers})
+ ));
+ }
+ }
+ }
+ my $b = get_unpacked_body_from($_[0]);
+ foreach my $k (keys %$b) {
+ next if $final->{$k};
+ foreach my $v (@{$b->{$k}}) {
+ next unless $v;
+ push(@{$final->{$k}||=[]}, Web::Dispatch::NotAnUpload->new(
+ filename => $v,
+ reason => sprintf($reason, $k, $v)
+ ));
+ }
+ }
+ $final;
+ };
+}
+
{
# shamelessly stolen from HTTP::Body::UrlEncoded by Christian Hansen
my ($name, $value);
foreach my $pair (split(/[&;](?:\s+)?/, $params)) {
next unless (($name, $value) = split(/=/, $pair, 2)) == 2;
-
+
s/$DECODE/$hex_chr{$1}/gs for ($name, $value);
+ $_ = decode_utf8 $_ for ($name, $value);
push(@{$unpack{$name}||=[]}, $value);
}
}
}
+{
+ # shamelessly stolen from Plack::Request by miyagawa
+
+ sub _make_http_body {
+
+ # Can't actually do this yet, since Plack::Request deletes the
+ # header structure out of the uploads in its copy of the body.
+ # I suspect I need to supply miyagawa with a failing test.
+
+ #if (my $plack_body = $_[0]->{'plack.request.http.body'}) {
+ # # Plack already constructed one; probably wasteful to do it again
+ # return $plack_body;
+ #}
+
+ require HTTP::Body;
+ my $body = HTTP::Body->new(@{$_[0]}{qw(CONTENT_TYPE CONTENT_LENGTH)});
+ $body->cleanup(1);
+ my $spin = 0;
+ my $input = $_[0]->{'psgi.input'};
+ my $cl = $_[0]->{CONTENT_LENGTH};
+ while ($cl) {
+ $input->read(my $chunk, $cl < 8192 ? $cl : 8192);
+ my $read = length $chunk;
+ $cl -= $read;
+ $body->add($chunk);
+
+ if ($read == 0 && $spin++ > 2000) {
+ require Carp;
+ Carp::croak("Bad Content-Length: maybe client disconnect? ($cl bytes remaining)");
+ }
+ }
+ return $body;
+ }
+}
+
1;