lib/Web/Dispatch/ParamParser.pm

   1 package Web::Dispatch::ParamParser;
   2
   3 use strict;
   4 use warnings FATAL => 'all';
   5
   6 use Encode 'decode_utf8';
   7
   8 sub UNPACKED_QUERY () { __PACKAGE__.'.unpacked_query' }
   9 sub UNPACKED_BODY () { __PACKAGE__.'.unpacked_body' }
  10 sub UNPACKED_BODY_OBJECT () { __PACKAGE__.'.unpacked_body_object' }
  11 sub UNPACKED_UPLOADS () { __PACKAGE__.'.unpacked_uploads' }
  12 sub ORIG_ENV () { 'Web::Dispatch.original_env' }
  13
  14 sub get_unpacked_query_from {
  15   return ($_[0]->{+ORIG_ENV}||$_[0])->{+UNPACKED_QUERY} ||= do {
  16     my $p = _unpack_params($_[0]->{QUERY_STRING});
  17     unless (keys %$p == 1 and exists $p->{j} and ref($p->{j}) eq 'ARRAY' and @{$p->{j}} == 1 and $p->{j}[0] =~ /^{/) {
  18       $p;
  19     } else {
  20       require JSON::MaybeXS;
  21       if (my $data = eval {
  22         my %data = %{JSON::MaybeXS::decode_json($p->{j}[0])};
  23         +{ map +($_ => [ $data{$_} ]), keys %data };
  24       }) {
  25         $data
  26       } else {
  27         {}
  28       }
  29     }
  30   };
  31 }
  32
  33 sub get_unpacked_body_from {
  34   return ($_[0]->{+ORIG_ENV}||$_[0])->{+UNPACKED_BODY} ||= do {
  35     my $ct = lc($_[0]->{CONTENT_TYPE}||'');
  36     if (!$_[0]->{CONTENT_LENGTH}) {
  37       {}
  38     } elsif (index($ct, 'application/x-www-form-urlencoded') >= 0) {
  39       $_[0]->{'psgi.input'}->read(my $buf, $_[0]->{CONTENT_LENGTH});
  40       _unpack_params($buf);
  41     } elsif (index($ct, 'multipart/form-data') >= 0) {
  42       my $p = get_unpacked_body_object_from($_[0])->param;
  43       # forcible arrayification (functional, $p does not belong to us,
  44       # do NOT replace this with a side-effect ridden "simpler" version)
  45       +{
  46         map +(ref($p->{$_}) eq 'ARRAY'
  47                ? ($_ => $p->{$_})
  48                : ($_ => [ $p->{$_} ])
  49              ), keys %$p
  50       };
  51     } elsif (index($ct, 'application/json') >= 0) {
  52       $_[0]->{'psgi.input'}->read(my $buf, $_[0]->{CONTENT_LENGTH});
  53       require JSON::MaybeXS;
  54       if (my $data = eval {
  55         my %data = %{JSON::MaybeXS::decode_json($buf)};
  56         +{ map +($_ => [ $data{$_} ]), keys %data };
  57       }) {
  58         $data
  59       } else {
  60         {}
  61       }
  62     } else {
  63       {}
  64     }
  65   };
  66 }
  67
  68 sub get_unpacked_body_object_from {
  69   # we may have no object at all - so use a single element arrayref for ||=
  70   return (($_[0]->{+ORIG_ENV}||$_[0])->{+UNPACKED_BODY_OBJECT} ||= do {
  71     if (!$_[0]->{CONTENT_LENGTH}) {
  72       [ undef ]
  73     } elsif (index(lc($_[0]->{CONTENT_TYPE}||''),'multipart/form-data')==-1) {
  74       [ undef ]
  75     } else {
  76       [ _make_http_body($_[0]) ]
  77     }
  78   })->[0];
  79 }
  80
  81 sub get_unpacked_uploads_from {
  82   $_[0]->{+UNPACKED_UPLOADS} ||= do {
  83     require Web::Dispatch::Upload; require HTTP::Headers;
  84     my ($final, $reason) = (
  85       {}, "field %s exists with value %s but body was not multipart/form-data"
  86     );
  87     if (my $body = get_unpacked_body_object_from($_[0])) {
  88       my $u = $body->upload;
  89       $reason = "field %s exists with value %s but was not an upload";
  90       foreach my $k (keys %$u) {
  91         foreach my $v (ref($u->{$k}) eq 'ARRAY' ? @{$u->{$k}} : $u->{$k}) {
  92           push(@{$final->{$k}||=[]}, Web::Dispatch::Upload->new(
  93             %{$v},
  94             headers => HTTP::Headers->new($v->{headers})
  95           ));
  96         }
  97       }
  98     }
  99     my $b = get_unpacked_body_from($_[0]);
 100     foreach my $k (keys %$b) {
 101       next if $final->{$k};
 102       foreach my $v (@{$b->{$k}}) {
 103         next unless $v;
 104         push(@{$final->{$k}||=[]}, Web::Dispatch::NotAnUpload->new(
 105           filename => $v,
 106           reason => sprintf($reason, $k, $v)
 107         ));
 108       }
 109     }
 110     $final;
 111   };
 112 }
 113
 114 {
 115   # shamelessly stolen from HTTP::Body::UrlEncoded by Christian Hansen
 116
 117   my $DECODE = qr/%([0-9a-fA-F]{2})/;
 118
 119   my %hex_chr;
 120
 121   foreach my $num ( 0 .. 255 ) {
 122     my $h = sprintf "%02X", $num;
 123     $hex_chr{ lc $h } = $hex_chr{ uc $h } = chr $num;
 124   }
 125
 126   sub _unpack_params {
 127     my %unpack;
 128     (my $params = $_[0]) =~ s/\+/ /g;
 129     my ($name, $value);
 130     foreach my $pair (split(/[&;](?:\s+)?/, $params)) {
 131       next unless (($name, $value) = split(/=/, $pair, 2)) == 2;
 132
 133       s/$DECODE/$hex_chr{$1}/gs for ($name, $value);
 134       $_ = decode_utf8 $_ for ($name, $value);
 135
 136       push(@{$unpack{$name}||=[]}, $value);
 137     }
 138     \%unpack;
 139   }
 140 }
 141
 142 {
 143   # shamelessly stolen from Plack::Request by miyagawa
 144
 145   sub _make_http_body {
 146
 147     # Can't actually do this yet, since Plack::Request deletes the
 148     # header structure out of the uploads in its copy of the body.
 149     # I suspect I need to supply miyagawa with a failing test.
 150
 151     #if (my $plack_body = $_[0]->{'plack.request.http.body'}) {
 152     #  # Plack already constructed one; probably wasteful to do it again
 153     #  return $plack_body;
 154     #}
 155
 156     require HTTP::Body;
 157     my $body = HTTP::Body->new(@{$_[0]}{qw(CONTENT_TYPE CONTENT_LENGTH)});
 158     $body->cleanup(1);
 159     my $spin = 0;
 160     my $input = $_[0]->{'psgi.input'};
 161     my $cl = $_[0]->{CONTENT_LENGTH};
 162     while ($cl) {
 163       $input->read(my $chunk, $cl < 8192 ? $cl : 8192);
 164       my $read = length $chunk;
 165       $cl -= $read;
 166       $body->add($chunk);
 167
 168       if ($read == 0 && $spin++ > 2000) {
 169         require Carp;
 170         Carp::croak("Bad Content-Length: maybe client disconnect? ($cl bytes remaining)");
 171       }
 172     }
 173     return $body;
 174   }
 175 }
 176
 177 1;